diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/.cache/.bld/.config b/cfgs/ORCA2_OCE_MIXED/BLD/.cache/.bld/.config new file mode 100644 index 0000000000000000000000000000000000000000..7eb0f69c0ea03ba841c5f4b99dc04d06163c3f16 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/.cache/.bld/.config @@ -0,0 +1,422 @@ +BLD_DEP_EXCL:: EXE::NONE H::MPIF.H H::NETCDF.INC INC::MPE_LOGF.H INC::MPIF.H INC::NETCDF.INC INC::VT.INC OBJ::CPU_TIME OBJ::GET_COMMAND OBJ::GET_COMMAND_ARGUMENT OBJ::GET_ENVIRONMENT_VARIABLE OBJ::MOVE_ALLOC OBJ::MVBITS OBJ::NONE OBJ::RANDOM_NUMBER OBJ::RANDOM_SEED OBJ::SYSTEM_CLOCK USE::CUDAFOR USE::IEEE_ARITHMETIC USE::IEEE_EXCEPTIONS USE::IEEE_FEATURES USE::ISO_C_BINDING USE::MKL_DFTI USE::MOD_OASIS USE::MPI USE::NETCDF USE::OPENACC USE::RP_EMULATOR USE::XIOS +BLD_DEP_EXE:: +BLD_EXE_NAME::model nemo.exe +BLD_PP::ioipsl 1 +BLD_PP::nemo 1 +BLD_PP::ppr_1d 1 +INFILE_EXT::F FPP::SOURCE +INFILE_EXT::F77 FPP::SOURCE +INFILE_EXT::F90 FPP::FPP9X::SOURCE +INFILE_EXT::F95 FPP::FPP9X::SOURCE +INFILE_EXT::FOR FPP::SOURCE +INFILE_EXT::FTN FPP::SOURCE +INFILE_EXT::a BINARY::LIB +INFILE_EXT::bash SCRIPT::SHELL +INFILE_EXT::c C::SOURCE +INFILE_EXT::cfg CFGFILE +INFILE_EXT::cpp C::C++::SOURCE +INFILE_EXT::csh SCRIPT::SHELL +INFILE_EXT::exe BINARY::EXE +INFILE_EXT::f FORTRAN::SOURCE +INFILE_EXT::f77 FORTRAN::SOURCE +INFILE_EXT::f90 FORTRAN::FORTRAN9X::SOURCE +INFILE_EXT::f95 FORTRAN::FORTRAN9X::SOURCE +INFILE_EXT::for FORTRAN::SOURCE +INFILE_EXT::ftn FORTRAN::SOURCE +INFILE_EXT::h CPP::INCLUDE +INFILE_EXT::h90 CPP::INCLUDE +INFILE_EXT::inc FORTRAN::FORTRAN9X::INCLUDE +INFILE_EXT::interface FORTRAN::FORTRAN9X::INCLUDE::INTERFACE +INFILE_EXT::ksh SCRIPT::SHELL +INFILE_EXT::o BINARY::OBJ +INFILE_EXT::obj BINARY::OBJ +INFILE_EXT::pl SCRIPT::PERL +INFILE_EXT::pm SCRIPT::PERL +INFILE_EXT::pro SCRIPT::PVWAVE +INFILE_EXT::py SCRIPT::PYTHON +INFILE_EXT::sh SCRIPT::SHELL +INFILE_EXT::tcl SCRIPT::TCL +OUTFILE_EXT::CFG .cfg +OUTFILE_EXT::DONE .done +OUTFILE_EXT::ETC .etc +OUTFILE_EXT::EXE .exe +OUTFILE_EXT::FLAGS .flags +OUTFILE_EXT::IDONE .idone +OUTFILE_EXT::INTERFACE .interface +OUTFILE_EXT::LIB .a +OUTFILE_EXT::MOD .mod +OUTFILE_EXT::OBJ .o +OUTFILE_EXT::PDONE .pdone +OUTFILE_EXT::TAR .tar +SRCPKG:: +SRCPKG::ioipsl +SRCPKG::ioipsl__calendar.f90 FORTRAN::FORTRAN9X::SOURCE::MODULE +SRCPKG::ioipsl__defprec.f90 FORTRAN::FORTRAN9X::SOURCE::MODULE +SRCPKG::ioipsl__errioipsl.f90 FORTRAN::FORTRAN9X::SOURCE::MODULE +SRCPKG::ioipsl__flincom.f90 FORTRAN::FORTRAN9X::SOURCE::MODULE +SRCPKG::ioipsl__fliocom.f90 FORTRAN::FORTRAN9X::SOURCE::MODULE +SRCPKG::ioipsl__getincom.f90 FORTRAN::FORTRAN9X::SOURCE::MODULE +SRCPKG::ioipsl__histcom.f90 FORTRAN::FORTRAN9X::SOURCE::MODULE +SRCPKG::ioipsl__ioipsl.f90 FORTRAN::FORTRAN9X::SOURCE::MODULE +SRCPKG::ioipsl__mathelp.f90 FORTRAN::FORTRAN9X::SOURCE::MODULE +SRCPKG::ioipsl__nc4interface.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::ioipsl__restcom.f90 FORTRAN::FORTRAN9X::SOURCE::MODULE +SRCPKG::ioipsl__stringop.f90 FORTRAN::FORTRAN9X::SOURCE::MODULE +SRCPKG::nemo +SRCPKG::nemo__abl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__asmbkg.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__asminc.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__asmpar.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__bdy_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__bdydta.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__bdydyn.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__bdydyn2d.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__bdydyn3d.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__bdyice.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__bdyini.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__bdylib.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__bdytides.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__bdytra.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__bdyvol.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__c1d.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__closea.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__cpl_oasis3.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__crs.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__crsdom.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__crsdomwri.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__crsfld.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__crsini.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__crslbclnk.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__cyclone.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__daymod.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__ddatetoymdhms.h90 CPP::INCLUDE +SRCPKG::nemo__depth_e3.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dia25h.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diaar5.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diacfl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diadct.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diadetide.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diahsb.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diahth.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diamlr.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dianam.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diaobs.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diaptr.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diawri.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diu_bulk.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diu_coolskin.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__diu_layers.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__divhor.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__do_loop_substitute.h90 CPP::INCLUDE +SRCPKG::nemo__dom_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__domain.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__domhgr.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dommsk.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__domqco.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__domtile.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__domutl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__domvvl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__domwri.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__domzgr.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__domzgr_substitute.h90 CPP::INCLUDE +SRCPKG::nemo__dtatsd.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dtauvd.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynadv.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynadv_cen2.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynadv_ubs.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynatf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynatf_qco.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dyndmp.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynhpg.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynkeg.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynldf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynldf_iso.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynldf_iso_lf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynldf_lap_blp.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynldf_lap_blp_lf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynspg.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynspg_exp.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynspg_ts.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynvor.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynzad.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__dynzdf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__eosbn2.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__find_obs_proc.h90 CPP::INCLUDE +SRCPKG::nemo__fldread.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__flo4rk.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__flo_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__floats.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__floblk.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__flodom.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__florst.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__flowri.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__geo2ocean.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__greg2jul.h90 CPP::INCLUDE +SRCPKG::nemo__grt_cir_dis.h90 CPP::INCLUDE +SRCPKG::nemo__grt_cir_dis_saa.h90 CPP::INCLUDE +SRCPKG::nemo__halo_mng.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__icb_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__icbclv.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__icbdia.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__icbdyn.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__icbini.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__icblbc.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__icbrst.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__icbstp.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__icbthm.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__icbtrj.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__icbutl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__in_out_manager.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__iom.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__iom_def.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__iom_nf90.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isf_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfcav.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfcavgam.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfcavmlt.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfcpl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfdiags.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfdynatf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfhdiv.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfload.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfpar.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfparmlt.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfrst.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfstp.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isftbl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__isfutils.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__istate.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__jul2greg.h90 CPP::INCLUDE +SRCPKG::nemo__julian.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__lbc_lnk_call_generic.h90 CPP::INCLUDE +SRCPKG::nemo__lbc_lnk_neicoll_generic.h90 CPP::INCLUDE +SRCPKG::nemo__lbc_lnk_pt2pt_generic.h90 CPP::INCLUDE +SRCPKG::nemo__lbc_nfd_ext_generic.h90 CPP::INCLUDE +SRCPKG::nemo__lbc_nfd_generic.h90 CPP::INCLUDE +SRCPKG::nemo__lbclnk.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__lbcnfd.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__ldfc1d_c2d.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__ldfdyn.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__ldfslp.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__ldftra.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__lib_cray.f90 FORTRAN::FORTRAN9X::SOURCE +SRCPKG::nemo__lib_fortran.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__lib_fortran_generic.h90 CPP::INCLUDE +SRCPKG::nemo__lib_mpp.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__linquad.h90 CPP::INCLUDE +SRCPKG::nemo__maxdist.h90 CPP::INCLUDE +SRCPKG::nemo__module_example.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__mpp_allreduce_generic.h90 CPP::INCLUDE +SRCPKG::nemo__mpp_lbc_north_icb_generic.h90 CPP::INCLUDE +SRCPKG::nemo__mpp_lnk_icb_generic.h90 CPP::INCLUDE +SRCPKG::nemo__mpp_loc_generic.h90 CPP::INCLUDE +SRCPKG::nemo__mpp_map.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__mpp_nfd_generic.h90 CPP::INCLUDE +SRCPKG::nemo__mppini.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__nemo.f90 FORTRAN::FORTRAN9X::SOURCE::PROGRAM +SRCPKG::nemo__nemogcm.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_averg_h2d.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_const.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_conv.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_conv_functions.h90 CPP::INCLUDE +SRCPKG::nemo__obs_fbm.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_grd_bruteforce.h90 CPP::INCLUDE +SRCPKG::nemo__obs_grid.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_inter_h2d.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_inter_sup.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_inter_z1d.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_level_search.h90 CPP::INCLUDE +SRCPKG::nemo__obs_mpp.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_oper.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_prep.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_profiles.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_profiles_def.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_read_altbias.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_read_prof.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_read_surf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_readmdt.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_rot_vel.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_sort.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_sstbias.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_surf_def.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_types.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_utils.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obs_write.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__obsinter_h2d.h90 CPP::INCLUDE +SRCPKG::nemo__obsinter_z1d.h90 CPP::INCLUDE +SRCPKG::nemo__oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__ocealb.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__par_kind.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__par_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__phycst.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__prtctl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__restart.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbc_ice.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbc_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbc_phy.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcabl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcapr.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk_algo_andreas.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk_algo_coare3p0.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk_algo_coare3p6.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk_algo_ecmwf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk_algo_ice_an05.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk_algo_ice_cdn.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk_algo_ice_lg15.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk_algo_ice_lu12.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk_algo_ncar.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk_skin_coare.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcblk_skin_ecmwf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcclo.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbccpl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcdcy.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcflx.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcfwb.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcice_cice.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcice_if.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcmod.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcrnf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcssm.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcssr.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sbcwave.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__single_precision_substitute.h90 CPP::INCLUDE +SRCPKG::nemo__solfrac_mod.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__sshwzv.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__step.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__step_diu.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__step_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__stopar.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__stopts.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__storng.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__stpctl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__stpmlf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__str_c_to_for.h90 CPP::INCLUDE +SRCPKG::nemo__tide.h90 CPP::INCLUDE +SRCPKG::nemo__tide_mod.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__timing.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traadv.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traadv_cen.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traadv_cen_lf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traadv_fct.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traadv_mus.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traadv_qck.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traadv_qck_lf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traadv_ubs.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traadv_ubs_lf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traatf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traatf_qco.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trabbc.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trabbl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__tradmp.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traisf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traldf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traldf_iso.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traldf_lap_blp.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traldf_triad.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__tramle.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__tranpc.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__traqsr.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trasbc.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trazdf.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trc_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trd_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trddyn.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trdglo.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trdini.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trdken.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trdmxl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trdmxl_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trdmxl_rst.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trdpen.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trdtra.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trdtrc.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trdvor.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__trdvor_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__usrdef_fmask.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__usrdef_hgr.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__usrdef_istate.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__usrdef_nam.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__usrdef_sbc.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__usrdef_zgr.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__wet_dry.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdf_oce.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfddm.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfdrg.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfevd.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfgls.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfiwm.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfmfc.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfmxl.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfosm.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfphy.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfric.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfsh2.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdfswm.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zdftke.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::nemo__zpshde.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::ppr_1d +SRCPKG::ppr_1d__bfun1d.h90 CPP::INCLUDE +SRCPKG::ppr_1d__ffsl1d.h90 CPP::INCLUDE +SRCPKG::ppr_1d__inv.h90 CPP::INCLUDE +SRCPKG::ppr_1d__oscl1d.h90 CPP::INCLUDE +SRCPKG::ppr_1d__p1e.h90 CPP::INCLUDE +SRCPKG::ppr_1d__p3e.h90 CPP::INCLUDE +SRCPKG::ppr_1d__p5e.h90 CPP::INCLUDE +SRCPKG::ppr_1d__pbc.h90 CPP::INCLUDE +SRCPKG::ppr_1d__pcm.h90 CPP::INCLUDE +SRCPKG::ppr_1d__plm.h90 CPP::INCLUDE +SRCPKG::ppr_1d__ppm.h90 CPP::INCLUDE +SRCPKG::ppr_1d__ppr_1d.F90 FPP::FPP9X::SOURCE::MODULE +SRCPKG::ppr_1d__pqm.h90 CPP::INCLUDE +SRCPKG::ppr_1d__rcon1d.h90 CPP::INCLUDE +SRCPKG::ppr_1d__rmap1d.h90 CPP::INCLUDE +SRCPKG::ppr_1d__root1d.h90 CPP::INCLUDE +SRCPKG::ppr_1d__util1d.h90 CPP::INCLUDE +SRCPKG::ppr_1d__weno1d.h90 CPP::INCLUDE +TARGET nemo.exe +TOOL::AR ar +TOOL::ARFLAGS -r +TOOL::CC cc +TOOL::CC_COMPILE -c +TOOL::CC_DEFINE -D +TOOL::CC_INCLUDE -I +TOOL::CC_OUTPUT -o +TOOL::CFLAGS +TOOL::CPP cpp +TOOL::CPPFLAGS -C +TOOL::CPPKEYS +TOOL::CPP_DEFINE -D +TOOL::CPP_INCLUDE -I +TOOL::DIFF3 diff3 +TOOL::DIFF3FLAGS -E -m +TOOL::FC mpiifort +TOOL::FC_COMPILE -c +TOOL::FC_DEFINE -D +TOOL::FC_INCLUDE -I +TOOL::FC_MODSEARCH +TOOL::FC_OUTPUT -o +TOOL::FFLAGS -r8 -ip -O3 -fp-model strict -extend-source 132 -heap-arrays -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include -I/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/xios_sources/trunk/inc +TOOL::FPP cpp +TOOL::FPPFLAGS -P -traditional +TOOL::FPPFLAGS__ioipsl -P -traditional +TOOL::FPPFLAGS__nemo -P -traditional +TOOL::FPPFLAGS__ppr_1d -P -traditional +TOOL::FPPKEYS key_xios key_qco key_single +TOOL::FPP_DEFINE -D +TOOL::FPP_INCLUDE -I +TOOL::GENINTERFACE none +TOOL::GRAPHIC_DIFF xxdiff +TOOL::GRAPHIC_MERGE xxdiff +TOOL::INTERFACE file +TOOL::LD mpiifort +TOOL::LDFLAGS -lstdc++ -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff -L/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/xios_sources/trunk/lib -lxios -lstdc++ +TOOL::LD_LIBLINK -l +TOOL::LD_LIBSEARCH -L +TOOL::LD_OUTPUT -o +TOOL::MAKE gmake +TOOL::MAKEFLAGS +TOOL::MAKE_FILE -f +TOOL::MAKE_JOB -j +TOOL::MAKE_SILENT -s +TOOL::SHELL /bin/sh diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/.cache/.bld/.config_dep b/cfgs/ORCA2_OCE_MIXED/BLD/.cache/.bld/.config_dep new file mode 100644 index 0000000000000000000000000000000000000000..8278effe9b4ce70308218419fb201fd6a1329c5b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/.cache/.bld/.config_dep @@ -0,0 +1,322 @@ +DEP::ioipsl__calendar.f90 calendar::errioipsl::USE::stringop::USE +DEP::ioipsl__defprec.f90 defprec +DEP::ioipsl__errioipsl.f90 errioipsl +DEP::ioipsl__flincom.f90 flincom::calendar::USE::errioipsl::USE::stringop::USE +DEP::ioipsl__fliocom.f90 fliocom::calendar::USE::defprec::USE::errioipsl::USE::stringop::USE +DEP::ioipsl__getincom.f90 getincom::errioipsl::USE::stringop::USE +DEP::ioipsl__histcom.f90 histcom::calendar::USE::errioipsl::USE::fliocom::USE::mathelp::USE::nc4interface::USE::stringop::USE +DEP::ioipsl__ioipsl.f90 ioipsl::calendar::USE::errioipsl::USE::flincom::USE::fliocom::USE::getincom::USE::histcom::USE::mathelp::USE::restcom::USE::stringop::USE +DEP::ioipsl__mathelp.f90 mathelp::errioipsl::USE::stringop::USE +DEP::ioipsl__nc4interface.F90 nc4interface +DEP::ioipsl__restcom.f90 restcom::calendar::USE::errioipsl::USE::fliocom::USE::mathelp::USE::stringop::USE +DEP::ioipsl__stringop.f90 stringop +DEP::nemo__abl.F90 abl::par_kind::USE +DEP::nemo__asmbkg.F90 asmbkg::asmpar::USE::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::ldfslp::USE::ldftra::USE::oce::USE::sbc_oce::USE::tradmp::USE::zdf_oce::USE::zdfddm::USE::zdfmxl::USE::zdftke::USE +DEP::nemo__asminc.F90 asminc::asmbkg::USE::asmpar::USE::c1d::USE::diaobs::USE::dom_oce::USE::domvvl::USE::eosbn2::USE::in_out_manager::USE::iom::USE::ldfdyn::USE::lib_mpp::USE::oce::USE::par_oce::USE::sbc_oce::USE::zpshde::USE +DEP::nemo__asmpar.F90 asmpar +DEP::nemo__bdy_oce.F90 bdy_oce::lib_mpp::USE::par_oce::USE +DEP::nemo__bdydta.F90 bdydta::bdy_oce::USE::bdytides::USE::dom_oce::USE::fldread::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::oce::USE::phycst::USE::sbcapr::USE::tide_mod::USE::timing::USE +DEP::nemo__bdydyn.F90 bdydyn::bdy_oce::USE::bdydyn2d::USE::bdydyn3d::USE::dom_oce::USE::domvvl::USE::in_out_manager::USE::lbclnk::USE::oce::USE +DEP::nemo__bdydyn2d.F90 bdydyn2d::bdy_oce::USE::bdylib::USE::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::phycst::USE::wet_dry::USE +DEP::nemo__bdydyn3d.F90 bdydyn3d::bdy_oce::USE::bdylib::USE::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::timing::USE +DEP::nemo__bdyice.F90 bdyice +DEP::nemo__bdyini.F90 bdyini::bdy_oce::USE::bdydta::USE::bdytides::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::tide_mod::USE +DEP::nemo__bdylib.F90 bdylib::bdy_oce::USE::bdyini::USE::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE +DEP::nemo__bdytides.F90 bdytides::bdy_oce::USE::daymod::USE::dom_oce::USE::fldread::USE::in_out_manager::USE::iom::USE::lbclnk::USE::oce::USE::phycst::USE::tide_mod::USE +DEP::nemo__bdytra.F90 bdytra::bdy_oce::USE::bdylib::USE::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::timing::USE +DEP::nemo__bdyvol.F90 bdyvol::bdy_oce::USE::dom_oce::USE::in_out_manager::USE::isf_oce::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE +DEP::nemo__c1d.F90 c1d::in_out_manager::USE::lib_mpp::USE::par_kind::USE +DEP::nemo__closea.F90 closea::diu_bulk::USE::in_out_manager::USE::iom::USE::lib_fortran::USE::lib_mpp::USE +DEP::nemo__cpl_oasis3.F90 cpl_oasis3::dom_oce::USE::in_out_manager::USE::lbclnk::USE::par_oce::USE +DEP::nemo__crs.F90 crs::dom_oce::USE::in_out_manager::USE::par_oce::USE +DEP::nemo__crsdom.F90 crsdom::crs::USE::crslbclnk::USE::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::par_kind::USE +DEP::nemo__crsdomwri.F90 crsdomwri::crs::USE::crsdom::USE::crslbclnk::USE::dom_oce::USE::in_out_manager::USE::iom::USE::iom_def::USE::lib_mpp::USE::par_kind::USE::timing::USE +DEP::nemo__crsfld.F90 crsfld::crs::USE::crsdom::USE::crslbclnk::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::ldftra::USE::oce::USE::sbc_oce::USE::timing::USE::zdf_oce::USE::zdfddm::USE +DEP::nemo__crsini.F90 crsini::crs::USE::crsdom::USE::crsdomwri::USE::crslbclnk::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::par_kind::USE::par_oce::USE::phycst::USE +DEP::nemo__crslbclnk.F90 crslbclnk::crs::USE::dom_oce::USE::in_out_manager::USE::lbclnk::USE::par_kind::USE +DEP::nemo__cyclone.F90 cyclone +DEP::nemo__daymod.F90 daymod::dom_oce::USE::in_out_manager::USE::ioipsl::USE::iom::USE::phycst::USE::prtctl::USE::restart::USE::timing::USE::trc_oce::USE +DEP::nemo__ddatetoymdhms.h90 +DEP::nemo__depth_e3.F90 depth_e3::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::timing::USE +DEP::nemo__dia25h.F90 dia25h::dom_oce::USE::in_out_manager::USE::iom::USE::oce::USE::wet_dry::USE::zdf_oce::USE::zdfgls::USE +DEP::nemo__diaar5.F90 diaar5::dom_oce::USE::eosbn2::USE::fldread::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::oce::USE::phycst::USE::timing::USE::zdf_oce::USE::zdfddm::USE +DEP::nemo__diacfl.F90 diacfl::dom_oce::USE::domvvl::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::timing::USE +DEP::nemo__diadct.F90 diadct::daymod::USE::dianam::USE::dom_oce::USE::domvvl::USE::in_out_manager::USE::lib_mpp::USE::oce::USE::phycst::USE::timing::USE +DEP::nemo__diadetide.F90 diadetide::dom_oce::USE::in_out_manager::USE::iom::USE::par_kind::USE::par_oce::USE::phycst::USE::tide_mod::USE +DEP::nemo__diahsb.F90 diahsb::bdy_oce::USE::dom_oce::USE::domvvl::USE::in_out_manager::USE::iom::USE::isf_oce::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::restart::USE::sbc_oce::USE::sbcrnf::USE::timing::USE::trabbc::USE::traqsr::USE +DEP::nemo__diahth.F90 diahth::dom_oce::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::oce::USE::phycst::USE::timing::USE +DEP::nemo__diamlr.F90 diamlr::dom_oce::USE::in_out_manager::USE::iom::USE::par_kind::USE::par_oce::USE::phycst::USE::tide_mod::USE::timing::USE +DEP::nemo__dianam.F90 dianam::dom_oce::USE::in_out_manager::USE::ioipsl::USE::phycst::USE +DEP::nemo__diaobs.F90 diaobs::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::mpp_map::USE::obs_grid::USE::obs_oper::USE::obs_prep::USE::obs_profiles_def::USE::obs_read_altbias::USE::obs_read_prof::USE::obs_read_surf::USE::obs_readmdt::USE::obs_rot_vel::USE::obs_sstbias::USE::obs_surf_def::USE::obs_types::USE::obs_write::USE::oce::USE::par_kind::USE::par_oce::USE::phycst::USE::sbc_oce::USE +DEP::nemo__diaptr.F90 diaptr::dom_oce::USE::domtile::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::oce::USE::phycst::USE::timing::USE +DEP::nemo__diawri.F90 diawri::abl::USE::dia25h::USE::diahth::USE::dianam::USE::diu_bulk::USE::diu_coolskin::USE::dom_oce::USE::dynadv::USE::icb_oce::USE::icbdia::USE::in_out_manager::USE::ioipsl::USE::iom::USE::isf_oce::USE::isfcpl::USE::lbclnk::USE::ldfdyn::USE::ldftra::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_ice::USE::sbc_oce::USE::sbcssr::USE::sbcwave::USE::timing::USE::wet_dry::USE::zdf_oce::USE::zdfdrg::USE::zdfmxl::USE::zdfosm::USE +DEP::nemo__diu_bulk.F90 diu_bulk::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::par_kind::USE::phycst::USE::solfrac_mod::USE +DEP::nemo__diu_coolskin.F90 diu_coolskin::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::par_kind::USE::phycst::USE::sbc_oce::USE +DEP::nemo__diu_layers.F90 diu_layers::diu_bulk::USE::diu_coolskin::USE::iom::USE::oce::USE::sbc_oce::USE::sbcmod::USE +DEP::nemo__divhor.F90 divhor::dom_oce::USE::in_out_manager::USE::isf_oce::USE::isfhdiv::USE::lbclnk::USE::lib_mpp::USE::oce::USE::sbc_oce::USE::sbcrnf::USE::timing::USE +DEP::nemo__do_loop_substitute.h90 +DEP::nemo__dom_oce.F90 dom_oce::par_oce::USE +DEP::nemo__domain.F90 domain::c1d::USE::closea::USE::dom_oce::USE::domhgr::USE::dommsk::USE::domqco::USE::domtile::USE::domwri::USE::domzgr::USE::in_out_manager::USE::ioipsl::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::restart::USE::sbc_oce::USE::trc_oce::USE::wet_dry::USE +DEP::nemo__domhgr.F90 domhgr::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::par_oce::USE::phycst::USE::timing::USE::usrdef_hgr::USE +DEP::nemo__dommsk.F90 dommsk::bdy_oce::USE::dom_oce::USE::domutl::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::usrdef_fmask::USE +DEP::nemo__domqco.F90 domqco::dom_oce::USE::dynadv::USE::in_out_manager::USE::iom::USE::isf_oce::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::restart::USE::sbc_oce::USE::timing::USE::usrdef_istate::USE::wet_dry::USE +DEP::nemo__domtile.F90 domtile::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::prtctl::USE +DEP::nemo__domutl.F90 domutl::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE +DEP::nemo__domvvl.F90 domvvl::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::restart::USE::sbc_oce::USE::timing::USE::usrdef_istate::USE::wet_dry::USE +DEP::nemo__domwri.F90 domwri::dom_oce::USE::domutl::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::phycst::USE::wet_dry::USE +DEP::nemo__domzgr.F90 domzgr::closea::USE::depth_e3::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::usrdef_zgr::USE::wet_dry::USE +DEP::nemo__domzgr_substitute.h90 +DEP::nemo__dtatsd.F90 dtatsd::dom_oce::USE::domtile::USE::fldread::USE::in_out_manager::USE::lib_mpp::USE::oce::USE::phycst::USE +DEP::nemo__dtauvd.F90 dtauvd::dom_oce::USE::fldread::USE::in_out_manager::USE::lib_mpp::USE::oce::USE::phycst::USE::timing::USE +DEP::nemo__dynadv.F90 dynadv::dom_oce::USE::dynadv_cen2::USE::dynadv_ubs::USE::dynkeg::USE::dynzad::USE::in_out_manager::USE::lib_mpp::USE::timing::USE +DEP::nemo__dynadv_cen2.F90 dynadv_cen2::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::oce::USE::prtctl::USE::trd_oce::USE::trddyn::USE +DEP::nemo__dynadv_ubs.F90 dynadv_ubs::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::prtctl::USE::trd_oce::USE::trddyn::USE +DEP::nemo__dynatf.F90 dynatf::bdy_oce::USE::bdydta::USE::bdydyn::USE::bdyvol::USE::dom_oce::USE::domvvl::USE::dynadv::USE::dynspg_ts::USE::in_out_manager::USE::iom::USE::isf_oce::USE::isfdynatf::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::sbcrnf::USE::timing::USE::trd_oce::USE::trddyn::USE::trdken::USE::zdfdrg::USE +DEP::nemo__dynatf_qco.F90 dynatf_qco::bdy_oce::USE::bdydta::USE::bdydyn::USE::bdyvol::USE::dom_oce::USE::domvvl::USE::dynadv::USE::dynspg_ts::USE::in_out_manager::USE::iom::USE::isf_oce::USE::isfdynatf::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::sbcrnf::USE::timing::USE::trd_oce::USE::trddyn::USE::trdken::USE::zdfdrg::USE +DEP::nemo__dyndmp.F90 dyndmp::c1d::USE::dom_oce::USE::dtauvd::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::timing::USE::tradmp::USE::zdf_oce::USE::zdfmxl::USE +DEP::nemo__dynhpg.F90 dynhpg::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::isf_oce::USE::isfload::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::timing::USE::trd_oce::USE::trddyn::USE::wet_dry::USE::zpshde::USE +DEP::nemo__dynkeg.F90 dynkeg::bdy_oce::USE::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::prtctl::USE::timing::USE::trd_oce::USE::trddyn::USE +DEP::nemo__dynldf.F90 dynldf::dom_oce::USE::dynldf_iso::USE::dynldf_lap_blp::USE::in_out_manager::USE::lbclnk::USE::ldfdyn::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::timing::USE::trd_oce::USE::trddyn::USE +DEP::nemo__dynldf_iso.F90 dynldf_iso::dom_oce::USE::in_out_manager::USE::lbclnk::USE::ldfdyn::USE::ldfslp::USE::ldftra::USE::lib_mpp::USE::oce::USE::prtctl::USE::zdf_oce::USE +DEP::nemo__dynldf_iso_lf.F90 dynldf_iso_lf::dom_oce::USE::in_out_manager::USE::lbclnk::USE::ldfdyn::USE::ldfslp::USE::ldftra::USE::lib_mpp::USE::oce::USE::prtctl::USE::zdf_oce::USE +DEP::nemo__dynldf_lap_blp.F90 dynldf_lap_blp::dom_oce::USE::domutl::USE::in_out_manager::USE::lbclnk::USE::ldfdyn::USE::ldfslp::USE::lib_mpp::USE::oce::USE::zdf_oce::USE +DEP::nemo__dynldf_lap_blp_lf.F90 dynldf_lap_blp_lf::dom_oce::USE::domutl::USE::in_out_manager::USE::ldfdyn::USE::ldfslp::USE::lib_mpp::USE::oce::USE::zdf_oce::USE +DEP::nemo__dynspg.F90 dynspg::c1d::USE::dom_oce::USE::dynspg_exp::USE::dynspg_ts::USE::in_out_manager::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_ice::USE::sbc_oce::USE::sbcapr::USE::sbcwave::USE::tide_mod::USE::timing::USE::trd_oce::USE::trddyn::USE +DEP::nemo__dynspg_exp.F90 dynspg_exp::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE +DEP::nemo__dynspg_ts.F90 dynspg_ts::bdy_oce::USE::bdydyn2d::USE::bdytides::USE::bdyvol::USE::dom_oce::USE::dynadv::USE::dynvor::USE::in_out_manager::USE::iom::USE::isf_oce::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::restart::USE::sbc_oce::USE::sbcapr::USE::sbcwave::USE::tide_mod::USE::wet_dry::USE::zdf_oce::USE::zdfdrg::USE +DEP::nemo__dynvor.F90 dynvor::dom_oce::USE::dommsk::USE::dynadv::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::prtctl::USE::sbc_oce::USE::sbcwave::USE::timing::USE::trd_oce::USE::trddyn::USE +DEP::nemo__dynzad.F90 dynzad::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::oce::USE::prtctl::USE::sbc_oce::USE::sbcwave::USE::timing::USE::trd_oce::USE::trddyn::USE +DEP::nemo__dynzdf.F90 dynzdf::dom_oce::USE::dynadv::USE::dynldf_iso::USE::in_out_manager::USE::ldfdyn::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::timing::USE::trd_oce::USE::trddyn::USE::zdf_oce::USE::zdfdrg::USE +DEP::nemo__eosbn2.F90 eosbn2::dom_oce::USE::domutl::USE::in_out_manager::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::phycst::USE::prtctl::USE::stopar::USE::stopts::USE::timing::USE +DEP::nemo__find_obs_proc.h90 +DEP::nemo__fldread.F90 fldread::bdy_oce::USE::dom_oce::USE::geo2ocean::USE::in_out_manager::USE::ioipsl::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE +DEP::nemo__flo4rk.F90 flo4rk::dom_oce::USE::flo_oce::USE::in_out_manager::USE::oce::USE +DEP::nemo__flo_oce.F90 flo_oce::in_out_manager::USE::lib_mpp::USE::par_oce::USE +DEP::nemo__floats.F90 floats::flo4rk::USE::flo_oce::USE::floblk::USE::flodom::USE::florst::USE::flowri::USE::in_out_manager::USE::lib_mpp::USE::oce::USE::timing::USE +DEP::nemo__floblk.F90 floblk::dom_oce::USE::flo_oce::USE::in_out_manager::USE::lib_mpp::USE::oce::USE::phycst::USE +DEP::nemo__flodom.F90 flodom::dom_oce::USE::flo_oce::USE::in_out_manager::USE::lib_mpp::USE::oce::USE +DEP::nemo__florst.F90 florst::dom_oce::USE::flo_oce::USE::in_out_manager::USE::lib_mpp::USE +DEP::nemo__flowri.F90 flowri::dianam::USE::dom_oce::USE::flo_oce::USE::in_out_manager::USE::ioipsl::USE::iom::USE::lib_mpp::USE::oce::USE::phycst::USE +DEP::nemo__geo2ocean.F90 geo2ocean::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::phycst::USE +DEP::nemo__greg2jul.h90 +DEP::nemo__grt_cir_dis.h90 +DEP::nemo__grt_cir_dis_saa.h90 +DEP::nemo__halo_mng.F90 halo_mng::dom_oce::USE::lbclnk::USE +DEP::nemo__icb_oce.F90 icb_oce::lib_mpp::USE::par_oce::USE +DEP::nemo__icbclv.F90 icbclv::dom_oce::USE::icb_oce::USE::icbdia::USE::icbutl::USE::lbclnk::USE::lib_mpp::USE::par_oce::USE::phycst::USE +DEP::nemo__icbdia.F90 icbdia::dom_oce::USE::icb_oce::USE::icbutl::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::par_oce::USE +DEP::nemo__icbdyn.F90 icbdyn::dom_oce::USE::icb_oce::USE::icbdia::USE::icbutl::USE::in_out_manager::USE::par_oce::USE::phycst::USE +DEP::nemo__icbini.F90 icbini::dom_oce::USE::fldread::USE::icb_oce::USE::icbdia::USE::icbrst::USE::icbtrj::USE::icbutl::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::sbc_ice::USE::sbc_oce::USE +DEP::nemo__icblbc.F90 icblbc::dom_oce::USE::icb_oce::USE::icbutl::USE::in_out_manager::USE::lib_mpp::USE::par_oce::USE +DEP::nemo__icbrst.F90 icbrst::dom_oce::USE::icb_oce::USE::icbutl::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::par_oce::USE +DEP::nemo__icbstp.F90 icbstp::dom_oce::USE::fldread::USE::icb_oce::USE::icbclv::USE::icbdia::USE::icbdyn::USE::icbini::USE::icblbc::USE::icbrst::USE::icbthm::USE::icbtrj::USE::icbutl::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::par_oce::USE::phycst::USE::sbc_oce::USE::timing::USE +DEP::nemo__icbthm.F90 icbthm::dom_oce::USE::eosbn2::USE::icb_oce::USE::icbdia::USE::icbutl::USE::in_out_manager::USE::lib_fortran::USE::lib_mpp::USE::par_oce::USE::phycst::USE::sbc_oce::USE +DEP::nemo__icbtrj.F90 icbtrj::dom_oce::USE::icb_oce::USE::icbutl::USE::in_out_manager::USE::ioipsl::USE::lib_mpp::USE::par_oce::USE::phycst::USE +DEP::nemo__icbutl.F90 icbutl::dom_oce::USE::icb_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::par_oce::USE::sbc_oce::USE +DEP::nemo__in_out_manager.F90 in_out_manager::nc4interface::USE::par_oce::USE +DEP::nemo__iom.F90 iom::crs::USE::dianam::USE::diu_bulk::USE::dom_oce::USE::domutl::USE::flo_oce::USE::icb_oce::USE::in_out_manager::USE::ioipsl::USE::iom_def::USE::iom_nf90::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::phycst::USE::sbc_oce::USE +DEP::nemo__iom_def.F90 iom_def::par_kind::USE +DEP::nemo__iom_nf90.F90 iom_nf90::dom_oce::USE::in_out_manager::USE::iom_def::USE::lbclnk::USE::lib_mpp::USE::sbc_oce::USE +DEP::nemo__isf_oce.F90 isf_oce::fldread::USE::in_out_manager::USE::lib_mpp::USE::par_kind::USE::par_oce::USE +DEP::nemo__isfcav.F90 isfcav::dom_oce::USE::eosbn2::USE::fldread::USE::in_out_manager::USE::iom::USE::isf_oce::USE::isfcavgam::USE::isfcavmlt::USE::isfdiags::USE::isfrst::USE::isftbl::USE::isfutils::USE::lbclnk::USE::lib_mpp::USE::oce::USE::par_oce::USE::phycst::USE +DEP::nemo__isfcavgam.F90 isfcavgam::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::isf_oce::USE::isftbl::USE::isfutils::USE::lib_mpp::USE::oce::USE::phycst::USE::zdfdrg::USE +DEP::nemo__isfcavmlt.F90 isfcavmlt::dom_oce::USE::eosbn2::USE::fldread::USE::in_out_manager::USE::iom::USE::isf_oce::USE::isftbl::USE::isfutils::USE::lib_fortran::USE::lib_mpp::USE::phycst::USE +DEP::nemo__isfcpl.F90 isfcpl::domqco::USE::domutl::USE::in_out_manager::USE::iom::USE::isf_oce::USE::isfutils::USE::lib_mpp::USE::oce::USE +DEP::nemo__isfdiags.F90 isfdiags::dom_oce::USE::in_out_manager::USE::iom::USE::isf_oce::USE +DEP::nemo__isfdynatf.F90 isfdynatf::dom_oce::USE::in_out_manager::USE::isf_oce::USE::oce::USE::phycst::USE +DEP::nemo__isfhdiv.F90 isfhdiv::dom_oce::USE::in_out_manager::USE::isf_oce::USE::phycst::USE +DEP::nemo__isfload.F90 isfload::dom_oce::USE::eosbn2::USE::in_out_manager::USE::isf_oce::USE::lib_mpp::USE +DEP::nemo__isfpar.F90 isfpar::dom_oce::USE::fldread::USE::in_out_manager::USE::iom::USE::isf_oce::USE::isfdiags::USE::isfparmlt::USE::isfrst::USE::isftbl::USE::isfutils::USE::par_oce::USE::phycst::USE +DEP::nemo__isfparmlt.F90 isfparmlt::dom_oce::USE::eosbn2::USE::fldread::USE::in_out_manager::USE::iom::USE::isf_oce::USE::isftbl::USE::isfutils::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE +DEP::nemo__isfrst.F90 isfrst::in_out_manager::USE::iom::USE::par_oce::USE +DEP::nemo__isfstp.F90 isfstp::dom_oce::USE::domvvl::USE::fldread::USE::in_out_manager::USE::isf_oce::USE::isfcav::USE::isfcpl::USE::isfload::USE::isfpar::USE::isftbl::USE::lib_mpp::USE::oce::USE::timing::USE::zdfdrg::USE +DEP::nemo__isftbl.F90 isftbl::dom_oce::USE::isf_oce::USE +DEP::nemo__isfutils.F90 isfutils::dom_oce::USE::in_out_manager::USE::iom::USE::lib_fortran::USE::lib_mpp::USE::par_kind::USE::par_oce::USE +DEP::nemo__istate.F90 istate::daymod::USE::dom_oce::USE::domvvl::USE::dtatsd::USE::dtauvd::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::restart::USE::usrdef_istate::USE::wet_dry::USE +DEP::nemo__jul2greg.h90 +DEP::nemo__julian.F90 julian::lib_mpp::USE::par_kind::USE +DEP::nemo__lbc_lnk_call_generic.h90 +DEP::nemo__lbc_lnk_neicoll_generic.h90 +DEP::nemo__lbc_lnk_pt2pt_generic.h90 ::lbc_lnk_pt2pt_generic.h90::H +DEP::nemo__lbc_nfd_ext_generic.h90 +DEP::nemo__lbc_nfd_generic.h90 +DEP::nemo__lbclnk.F90 lbclnk::dom_oce::USE::in_out_manager::USE::lbcnfd::USE::lib_mpp::USE +DEP::nemo__lbcnfd.F90 lbcnfd::dom_oce::USE::in_out_manager::USE::lib_mpp::USE +DEP::nemo__ldfc1d_c2d.F90 ldfc1d_c2d::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE +DEP::nemo__ldfdyn.F90 ldfdyn::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::ldfc1d_c2d::USE::ldfslp::USE::lib_mpp::USE::oce::USE::phycst::USE::timing::USE +DEP::nemo__ldfslp.F90 ldfslp::dom_oce::USE::eosbn2::USE::in_out_manager::USE::isf_oce::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::timing::USE::zdfmxl::USE +DEP::nemo__ldftra.F90 ldftra::diaptr::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::ldfc1d_c2d::USE::ldfslp::USE::lib_mpp::USE::oce::USE::phycst::USE +DEP::nemo__lib_cray.f90 lib_cray +DEP::nemo__lib_fortran.F90 lib_fortran::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::par_oce::USE +DEP::nemo__lib_fortran_generic.h90 +DEP::nemo__lib_mpp.F90 lib_mpp::dom_oce::USE::in_out_manager::USE +DEP::nemo__linquad.h90 +DEP::nemo__maxdist.h90 +DEP::nemo__module_example.F90 exampl +DEP::nemo__mpp_allreduce_generic.h90 +DEP::nemo__mpp_lbc_north_icb_generic.h90 +DEP::nemo__mpp_lnk_icb_generic.h90 +DEP::nemo__mpp_loc_generic.h90 +DEP::nemo__mpp_map.F90 mpp_map::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::par_kind::USE::par_oce::USE +DEP::nemo__mpp_nfd_generic.h90 +DEP::nemo__mppini.F90 mppini::bdy_oce::USE::dom_oce::USE::in_out_manager::USE::ioipsl::USE::iom::USE::lbcnfd::USE::lib_mpp::USE +DEP::nemo__nemo.f90 nemo::nemogcm::USE +DEP::nemo__nemogcm.F90 nemogcm::bdy_oce::USE::bdyini::USE::c1d::USE::cpl_oasis3::USE::crsini::USE::dia25h::USE::diawri::USE::dom_oce::USE::domain::USE::dyndmp::USE::halo_mng::USE::icbini::USE::icbstp::USE::istate::USE::lib_fortran::USE::lib_mpp::USE::mppini::USE::phycst::USE::step_diu::USE::step_oce::USE::stpmlf::USE::tide_mod::USE::trc_oce::USE::trdini::USE::usrdef_nam::USE::wet_dry::USE +DEP::nemo__obs_averg_h2d.F90 obs_averg_h2d::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::obs_const::USE::obs_utils::USE::par_kind::USE::par_oce::USE::phycst::USE +DEP::nemo__obs_const.F90 obs_const::par_kind::USE +DEP::nemo__obs_conv.F90 obs_conv::par_kind::USE +DEP::nemo__obs_conv_functions.h90 +DEP::nemo__obs_fbm.F90 obs_fbm::obs_utils::USE +DEP::nemo__obs_grd_bruteforce.h90 +DEP::nemo__obs_grid.F90 obs_grid::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::obs_const::USE::obs_mpp::USE::obs_utils::USE::par_kind::USE::par_oce::USE::phycst::USE +DEP::nemo__obs_inter_h2d.F90 obs_inter_h2d::in_out_manager::USE::lib_mpp::USE::obs_const::USE::obs_utils::USE::par_kind::USE::phycst::USE +DEP::nemo__obs_inter_sup.F90 obs_inter_sup::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::mpp_map::USE::obs_grid::USE::obs_mpp::USE::par_kind::USE +DEP::nemo__obs_inter_z1d.F90 obs_inter_z1d::par_kind::USE +DEP::nemo__obs_level_search.h90 +DEP::nemo__obs_mpp.F90 obs_mpp::in_out_manager::USE::lib_mpp::USE::mpp_map::USE +DEP::nemo__obs_oper.F90 obs_oper::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::obs_averg_h2d::USE::obs_const::USE::obs_grid::USE::obs_inter_h2d::USE::obs_inter_sup::USE::obs_inter_z1d::USE::obs_profiles_def::USE::obs_surf_def::USE::par_kind::USE::sbcdcy::USE +DEP::nemo__obs_prep.F90 obs_prep::bdy_oce::USE::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::obs_inter_sup::USE::obs_mpp::USE::obs_oper::USE::obs_profiles_def::USE::obs_surf_def::USE::par_kind::USE::par_oce::USE::phycst::USE +DEP::nemo__obs_profiles.F90 obs_profiles::obs_profiles_def::USE +DEP::nemo__obs_profiles_def.F90 obs_profiles_def::in_out_manager::USE::lib_mpp::USE::obs_fbm::USE::obs_mpp::USE::par_kind::USE +DEP::nemo__obs_read_altbias.F90 obs_read_altbias::dom_oce::USE::in_out_manager::USE::iom::USE::obs_inter_h2d::USE::obs_inter_sup::USE::obs_surf_def::USE::obs_utils::USE::oce::USE::par_kind::USE::par_oce::USE +DEP::nemo__obs_read_prof.F90 obs_read_prof::dom_oce::USE::in_out_manager::USE::julian::USE::lib_mpp::USE::obs_conv::USE::obs_fbm::USE::obs_grid::USE::obs_mpp::USE::obs_oper::USE::obs_prep::USE::obs_profiles_def::USE::obs_sort::USE::obs_types::USE::obs_utils::USE::par_kind::USE::par_oce::USE +DEP::nemo__obs_read_surf.F90 obs_read_surf::dom_oce::USE::in_out_manager::USE::julian::USE::obs_fbm::USE::obs_grid::USE::obs_mpp::USE::obs_sort::USE::obs_surf_def::USE::obs_types::USE::obs_utils::USE::par_kind::USE +DEP::nemo__obs_readmdt.F90 obs_readmdt::dom_oce::USE::in_out_manager::USE::iom::USE::iom_nf90::USE::lib_mpp::USE::obs_const::USE::obs_inter_h2d::USE::obs_inter_sup::USE::obs_surf_def::USE::obs_utils::USE::oce::USE::par_kind::USE::par_oce::USE +DEP::nemo__obs_rot_vel.F90 obs_rot_vel::dom_oce::USE::geo2ocean::USE::in_out_manager::USE::obs_fbm::USE::obs_grid::USE::obs_inter_h2d::USE::obs_inter_sup::USE::obs_profiles_def::USE::obs_utils::USE::par_kind::USE::par_oce::USE +DEP::nemo__obs_sort.F90 obs_sort::par_kind::USE +DEP::nemo__obs_sstbias.F90 obs_sstbias::dom_oce::USE::in_out_manager::USE::iom::USE::obs_inter_h2d::USE::obs_inter_sup::USE::obs_surf_def::USE::obs_utils::USE::oce::USE::par_kind::USE::par_oce::USE +DEP::nemo__obs_surf_def.F90 obs_surf_def::obs_mpp::USE::par_kind::USE +DEP::nemo__obs_types.F90 obs_types +DEP::nemo__obs_utils.F90 obs_utils::in_out_manager::USE::lib_mpp::USE::par_oce::USE +DEP::nemo__obs_write.F90 obs_write::dom_oce::USE::in_out_manager::USE::julian::USE::lib_mpp::USE::obs_const::USE::obs_conv::USE::obs_fbm::USE::obs_grid::USE::obs_mpp::USE::obs_profiles_def::USE::obs_surf_def::USE::obs_types::USE::obs_utils::USE::par_kind::USE +DEP::nemo__obsinter_h2d.h90 +DEP::nemo__obsinter_z1d.h90 +DEP::nemo__oce.F90 oce::lib_mpp::USE::par_oce::USE +DEP::nemo__ocealb.F90 ocealb::in_out_manager::USE::lib_fortran::USE::lib_mpp::USE::phycst::USE +DEP::nemo__par_kind.F90 par_kind +DEP::nemo__par_oce.F90 par_oce::par_kind::USE +DEP::nemo__phycst.F90 phycst::in_out_manager::USE::par_oce::USE +DEP::nemo__prtctl.F90 prtctl::dom_oce::USE::domutl::USE::in_out_manager::USE::lib_mpp::USE::mppini::USE +DEP::nemo__restart.F90 restart::diu_bulk::USE::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_ice::USE::trdmxl_oce::USE::usrdef_istate::USE::wet_dry::USE +DEP::nemo__sbc_ice.F90 sbc_ice::in_out_manager::USE::lib_mpp::USE +DEP::nemo__sbc_oce.F90 sbc_oce::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::par_oce::USE +DEP::nemo__sbc_phy.F90 sbc_phy::dom_oce::USE::phycst::USE +DEP::nemo__sbcabl.F90 sbcabl::lib_mpp::USE::sbc_oce::USE +DEP::nemo__sbcapr.F90 sbcapr::dom_oce::USE::fldread::USE::in_out_manager::USE::iom::USE::lib_fortran::USE::lib_mpp::USE::phycst::USE::sbc_oce::USE +DEP::nemo__sbcblk.F90 sbcblk::cyclone::USE::dom_oce::USE::fldread::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::sbc_phy::USE::sbcblk_algo_andreas::USE::sbcblk_algo_coare3p0::USE::sbcblk_algo_coare3p6::USE::sbcblk_algo_ecmwf::USE::sbcblk_algo_ncar::USE::sbcdcy::USE::sbcwave::USE::trc_oce::USE +DEP::nemo__sbcblk_algo_andreas.F90 sbcblk_algo_andreas::dom_oce::USE::phycst::USE::sbc_phy::USE +DEP::nemo__sbcblk_algo_coare3p0.F90 sbcblk_algo_coare3p0::dom_oce::USE::in_out_manager::USE::iom::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::sbc_phy::USE::sbcblk_skin_coare::USE::sbcwave::USE +DEP::nemo__sbcblk_algo_coare3p6.F90 sbcblk_algo_coare3p6::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::phycst::USE::sbc_phy::USE::sbcblk_skin_coare::USE +DEP::nemo__sbcblk_algo_ecmwf.F90 sbcblk_algo_ecmwf::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::phycst::USE::sbc_oce::USE::sbc_phy::USE::sbcblk_skin_ecmwf::USE::sbcwave::USE +DEP::nemo__sbcblk_algo_ice_an05.F90 sbcblk_algo_ice_an05::lib_mpp::USE::par_kind::USE::par_oce::USE::phycst::USE::sbc_phy::USE +DEP::nemo__sbcblk_algo_ice_cdn.F90 sbcblk_algo_ice_cdn::par_kind::USE::par_oce::USE::phycst::USE::sbc_phy::USE +DEP::nemo__sbcblk_algo_ice_lg15.F90 sbcblk_algo_ice_lg15::par_kind::USE::par_oce::USE::phycst::USE::sbc_phy::USE::sbcblk_algo_ice_cdn::USE +DEP::nemo__sbcblk_algo_ice_lu12.F90 sbcblk_algo_ice_lu12::par_kind::USE::par_oce::USE::phycst::USE::sbc_phy::USE::sbcblk_algo_ice_cdn::USE +DEP::nemo__sbcblk_algo_ncar.F90 sbcblk_algo_ncar::dom_oce::USE::phycst::USE::sbc_oce::USE::sbc_phy::USE::sbcwave::USE +DEP::nemo__sbcblk_skin_coare.F90 sbcblk_skin_coare::dom_oce::USE::in_out_manager::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::sbc_phy::USE::sbcdcy::USE +DEP::nemo__sbcblk_skin_ecmwf.F90 sbcblk_skin_ecmwf::dom_oce::USE::in_out_manager::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::sbc_phy::USE +DEP::nemo__sbcclo.F90 sbcclo::closea::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lib_fortran::USE::lib_mpp::USE::phycst::USE::sbc_oce::USE +DEP::nemo__sbccpl.F90 sbccpl::cpl_oasis3::USE::dom_oce::USE::eosbn2::USE::geo2ocean::USE::in_out_manager::USE::iom::USE::isf_oce::USE::lbclnk::USE::lib_mpp::USE::oce::USE::ocealb::USE::phycst::USE::sbc_ice::USE::sbc_oce::USE::sbc_phy::USE::sbcapr::USE::sbcdcy::USE::sbcrnf::USE::sbcwave::USE::trc_oce::USE::zdf_oce::USE +DEP::nemo__sbcdcy.F90 sbcdcy::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE +DEP::nemo__sbcflx.F90 sbcflx::dom_oce::USE::fldread::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::sbcdcy::USE::trc_oce::USE +DEP::nemo__sbcfwb.F90 sbcfwb::dom_oce::USE::in_out_manager::USE::iom::USE::isf_oce::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_ice::USE::sbc_oce::USE::sbcrnf::USE::sbcssr::USE::timing::USE +DEP::nemo__sbcice_cice.F90 sbcice_cice +DEP::nemo__sbcice_if.F90 sbcice_if::dom_oce::USE::eosbn2::USE::fldread::USE::in_out_manager::USE::iom::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_ice::USE::sbc_oce::USE +DEP::nemo__sbcmod.F90 sbcmod::bdy_oce::USE::closea::USE::cpl_oasis3::USE::diu_bulk::USE::dom_oce::USE::icb_oce::USE::icbstp::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_ice::USE::sbc_oce::USE::sbc_phy::USE::sbcabl::USE::sbcapr::USE::sbcblk::USE::sbcclo::USE::sbccpl::USE::sbcdcy::USE::sbcflx::USE::sbcfwb::USE::sbcice_cice::USE::sbcice_if::USE::sbcrnf::USE::sbcssm::USE::sbcssr::USE::sbcwave::USE::timing::USE::traqsr::USE::trc_oce::USE::usrdef_sbc::USE::wet_dry::USE +DEP::nemo__sbcrnf.F90 sbcrnf::closea::USE::dom_oce::USE::eosbn2::USE::fldread::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::phycst::USE::sbc_oce::USE +DEP::nemo__sbcssm.F90 sbcssm::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::oce::USE::prtctl::USE::sbc_oce::USE::sbcapr::USE::traqsr::USE +DEP::nemo__sbcssr.F90 sbcssr::dom_oce::USE::fldread::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::sbcrnf::USE +DEP::nemo__sbcwave.F90 sbcwave::bdy_oce::USE::dom_oce::USE::domvvl::USE::fldread::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::zdf_oce::USE +DEP::nemo__single_precision_substitute.h90 +DEP::nemo__solfrac_mod.F90 solfrac_mod::par_kind::USE +DEP::nemo__sshwzv.F90 sshwzv::bdy_oce::USE::bdydyn2d::USE::divhor::USE::dom_oce::USE::domvvl::USE::in_out_manager::USE::iom::USE::isf_oce::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::restart::USE::sbc_oce::USE::timing::USE::wet_dry::USE +DEP::nemo__step.F90 step +DEP::nemo__step_diu.F90 step_diu::daymod::USE::diaobs::USE::diu_layers::USE::iom::USE::oce::USE::restart::USE::sbc_oce::USE::sbcmod::USE::timing::USE +DEP::nemo__step_oce.F90 step_oce::asmbkg::USE::asminc::USE::bdy_oce::USE::bdydta::USE::bdydyn3d::USE::bdytra::USE::crsfld::USE::daymod::USE::diaar5::USE::diacfl::USE::diadct::USE::diadetide::USE::diahsb::USE::diahth::USE::diamlr::USE::diaobs::USE::diaptr::USE::diawri::USE::diu_layers::USE::divhor::USE::dom_oce::USE::domtile::USE::domvvl::USE::dynadv::USE::dynatf::USE::dyndmp::USE::dynhpg::USE::dynldf::USE::dynspg::USE::dynvor::USE::dynzdf::USE::eosbn2::USE::flo_oce::USE::floats::USE::in_out_manager::USE::iom::USE::isf_oce::USE::isfstp::USE::lbclnk::USE::ldfdyn::USE::ldfslp::USE::ldftra::USE::oce::USE::prtctl::USE::restart::USE::sbc_oce::USE::sbcapr::USE::sbccpl::USE::sbcmod::USE::sbcrnf::USE::sbcwave::USE::sshwzv::USE::stopar::USE::stopts::USE::stpctl::USE::tide_mod::USE::timing::USE::traadv::USE::traatf::USE::trabbc::USE::trabbl::USE::tradmp::USE::traisf::USE::traldf::USE::tranpc::USE::traqsr::USE::trasbc::USE::trazdf::USE::zdf_oce::USE::zdfdrg::USE::zdfmfc::USE::zdfosm::USE::zdfphy::USE::zpshde::USE +DEP::nemo__stopar.F90 stopar::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::par_oce::USE::storng::USE +DEP::nemo__stopts.F90 stopts::dom_oce::USE::lbclnk::USE::phycst::USE::stopar::USE +DEP::nemo__storng.F90 storng::lib_mpp::USE::par_kind::USE +DEP::nemo__stpctl.F90 stpctl::diawri::USE::dom_oce::USE::eosbn2::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::wet_dry::USE::zdf_oce::USE +DEP::nemo__stpmlf.F90 stpmlf::bdydyn::USE::domqco::USE::dynatf_qco::USE::dynspg_ts::USE::step_oce::USE::traatf_qco::USE +DEP::nemo__str_c_to_for.h90 +DEP::nemo__tide.h90 +DEP::nemo__tide_mod.F90 tide_mod::daymod::USE::in_out_manager::USE::iom::USE::oce::USE::par_oce::USE::phycst::USE +DEP::nemo__timing.F90 timing::dom_oce::USE::in_out_manager::USE::lib_mpp::USE +DEP::nemo__traadv.F90 traadv::diaptr::USE::dom_oce::USE::domtile::USE::domvvl::USE::in_out_manager::USE::iom::USE::ldfslp::USE::ldftra::USE::lib_mpp::USE::oce::USE::prtctl::USE::sbc_oce::USE::sbcwave::USE::timing::USE::traadv_cen::USE::traadv_fct::USE::traadv_mus::USE::traadv_qck::USE::traadv_ubs::USE::tramle::USE::trd_oce::USE::trdtra::USE +DEP::nemo__traadv_cen.F90 traadv_cen::diaar5::USE::diaptr::USE::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::traadv_fct::USE::trc_oce::USE::trd_oce::USE::trdtra::USE +DEP::nemo__traadv_cen_lf.F90 traadv_cen_lf::diaar5::USE::diaptr::USE::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::traadv_fct::USE::trc_oce::USE::trd_oce::USE::trdtra::USE +DEP::nemo__traadv_fct.F90 traadv_fct::diaar5::USE::diaptr::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::trc_oce::USE::trd_oce::USE::trdtra::USE::zdf_oce::USE +DEP::nemo__traadv_mus.F90 traadv_mus::diaar5::USE::diaptr::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::sbcrnf::USE::trc_oce::USE::trd_oce::USE::trdtra::USE +DEP::nemo__traadv_qck.F90 traadv_qck::diaptr::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::trc_oce::USE::trd_oce::USE::trdtra::USE +DEP::nemo__traadv_qck_lf.F90 traadv_qck_lf::diaptr::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::trc_oce::USE::trd_oce::USE::trdtra::USE +DEP::nemo__traadv_ubs.F90 traadv_ubs::diaar5::USE::diaptr::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::traadv_fct::USE::trc_oce::USE::trd_oce::USE::trdtra::USE +DEP::nemo__traadv_ubs_lf.F90 traadv_ubs_lf::diaar5::USE::diaptr::USE::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::traadv_fct::USE::trc_oce::USE::trd_oce::USE::trdtra::USE +DEP::nemo__traatf.F90 traatf::bdy_oce::USE::bdytra::USE::dom_oce::USE::domvvl::USE::in_out_manager::USE::isf_oce::USE::lbclnk::USE::ldfslp::USE::ldftra::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::sbcrnf::USE::timing::USE::traqsr::USE::trd_oce::USE::trdtra::USE::zdf_oce::USE +DEP::nemo__traatf_qco.F90 traatf_qco::bdy_oce::USE::bdytra::USE::dom_oce::USE::domvvl::USE::in_out_manager::USE::isf_oce::USE::lbclnk::USE::ldfslp::USE::ldftra::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::sbcrnf::USE::timing::USE::traqsr::USE::trd_oce::USE::trdtra::USE::zdf_oce::USE +DEP::nemo__trabbc.F90 trabbc::dom_oce::USE::fldread::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::timing::USE::trd_oce::USE::trdtra::USE +DEP::nemo__trabbl.F90 trabbl::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::oce::USE::phycst::USE::prtctl::USE::timing::USE::trd_oce::USE::trdtra::USE +DEP::nemo__tradmp.F90 tradmp::dom_oce::USE::dtatsd::USE::in_out_manager::USE::iom::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::timing::USE::trd_oce::USE::trdtra::USE::zdf_oce::USE::zdfmxl::USE +DEP::nemo__traisf.F90 traisf::dom_oce::USE::in_out_manager::USE::isf_oce::USE::isfutils::USE::par_oce::USE::timing::USE +DEP::nemo__traldf.F90 traldf::dom_oce::USE::in_out_manager::USE::lbclnk::USE::ldfslp::USE::ldftra::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::timing::USE::traldf_iso::USE::traldf_lap_blp::USE::traldf_triad::USE::trd_oce::USE::trdtra::USE +DEP::nemo__traldf_iso.F90 traldf_iso::diaar5::USE::diaptr::USE::dom_oce::USE::domutl::USE::in_out_manager::USE::iom::USE::lbclnk::USE::ldfslp::USE::ldftra::USE::oce::USE::phycst::USE::trc_oce::USE::zdf_oce::USE +DEP::nemo__traldf_lap_blp.F90 traldf_lap_blp::diaar5::USE::diaptr::USE::dom_oce::USE::domutl::USE::in_out_manager::USE::iom::USE::lbclnk::USE::ldftra::USE::lib_mpp::USE::oce::USE::timing::USE::traldf_iso::USE::traldf_triad::USE::trc_oce::USE::zpshde::USE +DEP::nemo__traldf_triad.F90 traldf_triad::diaar5::USE::diaptr::USE::dom_oce::USE::domutl::USE::in_out_manager::USE::iom::USE::lbclnk::USE::ldfslp::USE::ldftra::USE::lib_mpp::USE::oce::USE::phycst::USE::traldf_iso::USE::trc_oce::USE::zdf_oce::USE::zpshde::USE +DEP::nemo__tramle.F90 tramle::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::zdf_oce::USE::zdfmxl::USE::zdfosm::USE +DEP::nemo__tranpc.F90 tranpc::dom_oce::USE::eosbn2::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::timing::USE::trd_oce::USE::trdtra::USE::zdf_oce::USE +DEP::nemo__traqsr.F90 traqsr::dom_oce::USE::domtile::USE::fldread::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::restart::USE::sbc_oce::USE::timing::USE::trc_oce::USE::trd_oce::USE::trdtra::USE +DEP::nemo__trasbc.F90 trasbc::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::lbclnk::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::sbcmod::USE::sbcrnf::USE::timing::USE::traqsr::USE::trd_oce::USE::trdtra::USE +DEP::nemo__trazdf.F90 trazdf::dom_oce::USE::domvvl::USE::eosbn2::USE::in_out_manager::USE::lbclnk::USE::ldfslp::USE::ldftra::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::timing::USE::trd_oce::USE::trdtra::USE::zdf_oce::USE::zdfmfc::USE +DEP::nemo__trc_oce.F90 trc_oce::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::par_oce::USE +DEP::nemo__trd_oce.F90 trd_oce::par_oce::USE::trdmxl_oce::USE::trdvor_oce::USE +DEP::nemo__trddyn.F90 trddyn::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::trd_oce::USE::trdglo::USE::trdken::USE::trdmxl::USE::trdvor::USE::zdf_oce::USE +DEP::nemo__trdglo.F90 trdglo::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::ldfdyn::USE::ldftra::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::trd_oce::USE::zdf_oce::USE::zdfddm::USE +DEP::nemo__trdini.F90 trdini::dom_oce::USE::domtile::USE::in_out_manager::USE::lib_mpp::USE::trd_oce::USE::trdglo::USE::trdken::USE::trdmxl::USE::trdpen::USE::trdvor::USE +DEP::nemo__trdken.F90 trdken::dom_oce::USE::in_out_manager::USE::iom::USE::ldfslp::USE::ldftra::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::trd_oce::USE::trdglo::USE::trdmxl::USE::trdvor::USE::zdf_oce::USE +DEP::nemo__trdmxl.F90 trdmxl::dianam::USE::dom_oce::USE::in_out_manager::USE::ioipsl::USE::iom::USE::lbclnk::USE::ldfslp::USE::ldftra::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::restart::USE::trd_oce::USE::trdmxl_oce::USE::trdmxl_rst::USE::zdf_oce::USE::zdfddm::USE::zdfmxl::USE +DEP::nemo__trdmxl_oce.F90 trdmxl_oce::lib_mpp::USE::par_oce::USE +DEP::nemo__trdmxl_rst.F90 trdmxl_rst::dom_oce::USE::in_out_manager::USE::iom::USE::restart::USE::trd_oce::USE +DEP::nemo__trdpen.F90 trdpen::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::ldftra::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::trd_oce::USE::zdf_oce::USE::zdfddm::USE +DEP::nemo__trdtra.F90 trdtra::dom_oce::USE::in_out_manager::USE::iom::USE::ldfslp::USE::ldftra::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::trd_oce::USE::trdglo::USE::trdmxl::USE::trdpen::USE::trdtrc::USE::zdf_oce::USE::zdfddm::USE +DEP::nemo__trdtrc.F90 trdtrc::par_kind::USE +DEP::nemo__trdvor.F90 trdvor::dianam::USE::dom_oce::USE::in_out_manager::USE::ioipsl::USE::lbclnk::USE::ldfdyn::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE::trd_oce::USE::zdf_oce::USE::zdfmxl::USE +DEP::nemo__trdvor_oce.F90 trdvor_oce::par_oce::USE +DEP::nemo__usrdef_fmask.F90 usrdef_fmask::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE +DEP::nemo__usrdef_hgr.F90 usrdef_hgr::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::par_oce::USE::phycst::USE::usrdef_nam::USE +DEP::nemo__usrdef_istate.F90 usrdef_istate::in_out_manager::USE::lib_mpp::USE::par_oce::USE::phycst::USE +DEP::nemo__usrdef_nam.F90 usrdef_nam::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::par_oce::USE::phycst::USE +DEP::nemo__usrdef_sbc.F90 usrdef_sbc::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::sbc_oce::USE +DEP::nemo__usrdef_zgr.F90 usrdef_zgr::depth_e3::USE::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE +DEP::nemo__wet_dry.F90 wet_dry::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::sbc_oce::USE::sbcrnf::USE::timing::USE +DEP::nemo__zdf_oce.F90 zdf_oce::in_out_manager::USE::lib_mpp::USE::par_oce::USE +DEP::nemo__zdfddm.F90 zdfddm::dom_oce::USE::eosbn2::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::prtctl::USE::zdf_oce::USE +DEP::nemo__zdfdrg.F90 zdfdrg::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::trd_oce::USE::trddyn::USE::zdf_oce::USE +DEP::nemo__zdfevd.F90 zdfevd::dom_oce::USE::in_out_manager::USE::iom::USE::lbclnk::USE::oce::USE::timing::USE::trd_oce::USE::trdtra::USE::zdf_oce::USE +DEP::nemo__zdfgls.F90 zdfgls::dom_oce::USE::domvvl::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::sbcwave::USE::zdf_oce::USE::zdfdrg::USE::zdfmxl::USE +DEP::nemo__zdfiwm.F90 zdfiwm::dom_oce::USE::eosbn2::USE::fldread::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::zdf_oce::USE::zdfddm::USE +DEP::nemo__zdfmfc.F90 zdfmfc::dom_oce::USE::domvvl::USE::domzgr::USE::eosbn2::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::timing::USE::zdf_oce::USE::zdfmxl::USE +DEP::nemo__zdfmxl.F90 zdfmxl::dom_oce::USE::in_out_manager::USE::iom::USE::isf_oce::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::trc_oce::USE::zdf_oce::USE +DEP::nemo__zdfosm.F90 zdfosm::dom_oce::USE::eosbn2::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::sbcwave::USE::traqsr::USE::trd_oce::USE::trdtra::USE::zdf_oce::USE::zdfddm::USE::zdfdrg::USE +DEP::nemo__zdfphy.F90 zdfphy::domtile::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_mpp::USE::oce::USE::sbc_ice::USE::sbc_oce::USE::sbcrnf::USE::timing::USE::tranpc::USE::trc_oce::USE::zdf_oce::USE::zdfddm::USE::zdfdrg::USE::zdfevd::USE::zdfgls::USE::zdfiwm::USE::zdfmfc::USE::zdfmxl::USE::zdfosm::USE::zdfric::USE::zdfsh2::USE::zdfswm::USE::zdftke::USE +DEP::nemo__zdfric.F90 zdfric::dom_oce::USE::in_out_manager::USE::iom::USE::lib_fortran::USE::oce::USE::phycst::USE::sbc_oce::USE::zdf_oce::USE +DEP::nemo__zdfsh2.F90 zdfsh2::dom_oce::USE::in_out_manager::USE::lib_mpp::USE::oce::USE::sbc_oce::USE::sbcwave::USE +DEP::nemo__zdfswm.F90 zdfswm::dom_oce::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::sbc_oce::USE::sbcwave::USE::zdf_oce::USE +DEP::nemo__zdftke.F90 zdftke::dom_oce::USE::domvvl::USE::in_out_manager::USE::iom::USE::lbclnk::USE::lib_fortran::USE::lib_mpp::USE::oce::USE::phycst::USE::prtctl::USE::sbc_oce::USE::sbcwave::USE::zdf_oce::USE::zdfdrg::USE::zdfmxl::USE +DEP::nemo__zpshde.F90 zpshde::dom_oce::USE::domutl::USE::eosbn2::USE::in_out_manager::USE::lbclnk::USE::lib_mpp::USE::oce::USE::phycst::USE::timing::USE +DEP::ppr_1d__bfun1d.h90 +DEP::ppr_1d__ffsl1d.h90 +DEP::ppr_1d__inv.h90 +DEP::ppr_1d__oscl1d.h90 +DEP::ppr_1d__p1e.h90 +DEP::ppr_1d__p3e.h90 +DEP::ppr_1d__p5e.h90 +DEP::ppr_1d__pbc.h90 +DEP::ppr_1d__pcm.h90 +DEP::ppr_1d__plm.h90 +DEP::ppr_1d__ppm.h90 +DEP::ppr_1d__ppr_1d.F90 ppr_1d +DEP::ppr_1d__pqm.h90 +DEP::ppr_1d__rcon1d.h90 +DEP::ppr_1d__rmap1d.h90 +DEP::ppr_1d__root1d.h90 +DEP::ppr_1d__util1d.h90 +DEP::ppr_1d__weno1d.h90 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/.cache/.bld/.config_dep_pp b/cfgs/ORCA2_OCE_MIXED/BLD/.cache/.bld/.config_dep_pp new file mode 100644 index 0000000000000000000000000000000000000000..a85681d33d9e2cfc66f7b03ea56444c0648c0d1b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/.cache/.bld/.config_dep_pp @@ -0,0 +1,322 @@ +DEP_PP::ioipsl__calendar.f90 +DEP_PP::ioipsl__defprec.f90 +DEP_PP::ioipsl__errioipsl.f90 +DEP_PP::ioipsl__flincom.f90 +DEP_PP::ioipsl__fliocom.f90 +DEP_PP::ioipsl__getincom.f90 +DEP_PP::ioipsl__histcom.f90 +DEP_PP::ioipsl__ioipsl.f90 +DEP_PP::ioipsl__mathelp.f90 +DEP_PP::ioipsl__nc4interface.F90 +DEP_PP::ioipsl__restcom.f90 +DEP_PP::ioipsl__stringop.f90 +DEP_PP::nemo__abl.F90 +DEP_PP::nemo__asmbkg.F90 +DEP_PP::nemo__asminc.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__asmpar.F90 +DEP_PP::nemo__bdy_oce.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__bdydta.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__bdydyn.F90 ::domzgr_substitute.h90::H +DEP_PP::nemo__bdydyn2d.F90 +DEP_PP::nemo__bdydyn3d.F90 +DEP_PP::nemo__bdyice.F90 +DEP_PP::nemo__bdyini.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__bdylib.F90 +DEP_PP::nemo__bdytides.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__bdytra.F90 +DEP_PP::nemo__bdyvol.F90 +DEP_PP::nemo__c1d.F90 +DEP_PP::nemo__closea.F90 +DEP_PP::nemo__cpl_oasis3.F90 +DEP_PP::nemo__crs.F90 +DEP_PP::nemo__crsdom.F90 +DEP_PP::nemo__crsdomwri.F90 +DEP_PP::nemo__crsfld.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__crsini.F90 ::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__crslbclnk.F90 +DEP_PP::nemo__cyclone.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__daymod.F90 +DEP_PP::nemo__ddatetoymdhms.h90 +DEP_PP::nemo__depth_e3.F90 +DEP_PP::nemo__dia25h.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__diaar5.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__diacfl.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__diadct.F90 ::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__diadetide.F90 +DEP_PP::nemo__diahsb.F90 ::domzgr_substitute.h90::H +DEP_PP::nemo__diahth.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__diamlr.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__dianam.F90 +DEP_PP::nemo__diaobs.F90 ::domzgr_substitute.h90::H +DEP_PP::nemo__diaptr.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__diawri.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__diu_bulk.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__diu_coolskin.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__diu_layers.F90 +DEP_PP::nemo__divhor.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__do_loop_substitute.h90 +DEP_PP::nemo__dom_oce.F90 +DEP_PP::nemo__domain.F90 ::do_loop_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__domhgr.F90 +DEP_PP::nemo__dommsk.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__domqco.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__domtile.F90 +DEP_PP::nemo__domutl.F90 +DEP_PP::nemo__domvvl.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__domwri.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__domzgr.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__domzgr_substitute.h90 +DEP_PP::nemo__dtatsd.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__dtauvd.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dynadv.F90 +DEP_PP::nemo__dynadv_cen2.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dynadv_ubs.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dynatf.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__dynatf_qco.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dyndmp.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dynhpg.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dynkeg.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__dynldf.F90 +DEP_PP::nemo__dynldf_iso.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dynldf_iso_lf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dynldf_lap_blp.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dynldf_lap_blp_lf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dynspg.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__dynspg_exp.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__dynspg_ts.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__dynvor.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dynzad.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__dynzdf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__eosbn2.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__find_obs_proc.h90 +DEP_PP::nemo__fldread.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__flo4rk.F90 ::domzgr_substitute.h90::H +DEP_PP::nemo__flo_oce.F90 +DEP_PP::nemo__floats.F90 +DEP_PP::nemo__floblk.F90 ::domzgr_substitute.h90::H +DEP_PP::nemo__flodom.F90 ::domzgr_substitute.h90::H +DEP_PP::nemo__florst.F90 +DEP_PP::nemo__flowri.F90 ::domzgr_substitute.h90::H +DEP_PP::nemo__geo2ocean.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__greg2jul.h90 +DEP_PP::nemo__grt_cir_dis.h90 +DEP_PP::nemo__grt_cir_dis_saa.h90 +DEP_PP::nemo__halo_mng.F90 +DEP_PP::nemo__icb_oce.F90 +DEP_PP::nemo__icbclv.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__icbdia.F90 +DEP_PP::nemo__icbdyn.F90 +DEP_PP::nemo__icbini.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__icblbc.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__icbrst.F90 +DEP_PP::nemo__icbstp.F90 +DEP_PP::nemo__icbthm.F90 +DEP_PP::nemo__icbtrj.F90 +DEP_PP::nemo__icbutl.F90 ::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__in_out_manager.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__iom.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__iom_def.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__iom_nf90.F90 +DEP_PP::nemo__isf_oce.F90 +DEP_PP::nemo__isfcav.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__isfcavgam.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__isfcavmlt.F90 ::do_loop_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__isfcpl.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__isfdiags.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__isfdynatf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__isfhdiv.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__isfload.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__isfpar.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__isfparmlt.F90 ::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__isfrst.F90 +DEP_PP::nemo__isfstp.F90 ::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__isftbl.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__isfutils.F90 ::single_precision_substitute.h90::H +DEP_PP::nemo__istate.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__jul2greg.h90 +DEP_PP::nemo__julian.F90 ::greg2jul.h90::H::jul2greg.h90::H +DEP_PP::nemo__lbc_lnk_call_generic.h90 +DEP_PP::nemo__lbc_lnk_neicoll_generic.h90 +DEP_PP::nemo__lbc_lnk_pt2pt_generic.h90 ::lbc_lnk_pt2pt_generic.h90::H +DEP_PP::nemo__lbc_nfd_ext_generic.h90 +DEP_PP::nemo__lbc_nfd_generic.h90 +DEP_PP::nemo__lbclnk.F90 ::lbc_lnk_call_generic.h90::H::lbc_lnk_neicoll_generic.h90::H::lbc_lnk_pt2pt_generic.h90::H::mpp_lbc_north_icb_generic.h90::H::mpp_lnk_icb_generic.h90::H +DEP_PP::nemo__lbcnfd.F90 ::lbc_nfd_ext_generic.h90::H::lbc_nfd_generic.h90::H::mpp_nfd_generic.h90::H +DEP_PP::nemo__ldfc1d_c2d.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__ldfdyn.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__ldfslp.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__ldftra.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__lib_cray.f90 +DEP_PP::nemo__lib_fortran.F90 ::do_loop_substitute.h90::H::lib_fortran_generic.h90::H +DEP_PP::nemo__lib_fortran_generic.h90 +DEP_PP::nemo__lib_mpp.F90 ::do_loop_substitute.h90::H::mpp_allreduce_generic.h90::H::mpp_loc_generic.h90::H +DEP_PP::nemo__linquad.h90 +DEP_PP::nemo__maxdist.h90 +DEP_PP::nemo__module_example.F90 ::do_loop_substitute.h90::H::exampl_substitute.h90::H +DEP_PP::nemo__mpp_allreduce_generic.h90 +DEP_PP::nemo__mpp_lbc_north_icb_generic.h90 +DEP_PP::nemo__mpp_lnk_icb_generic.h90 +DEP_PP::nemo__mpp_loc_generic.h90 +DEP_PP::nemo__mpp_map.F90 +DEP_PP::nemo__mpp_nfd_generic.h90 +DEP_PP::nemo__mppini.F90 +DEP_PP::nemo__nemo.f90 +DEP_PP::nemo__nemogcm.F90 +DEP_PP::nemo__obs_averg_h2d.F90 +DEP_PP::nemo__obs_const.F90 +DEP_PP::nemo__obs_conv.F90 ::obs_conv_functions.h90::H +DEP_PP::nemo__obs_conv_functions.h90 +DEP_PP::nemo__obs_fbm.F90 +DEP_PP::nemo__obs_grd_bruteforce.h90 +DEP_PP::nemo__obs_grid.F90 ::find_obs_proc.h90::H::linquad.h90::H::maxdist.h90::H::obs_grd_bruteforce.h90::H::obs_level_search.h90::H +DEP_PP::nemo__obs_inter_h2d.F90 ::obsinter_h2d.h90::H +DEP_PP::nemo__obs_inter_sup.F90 +DEP_PP::nemo__obs_inter_z1d.F90 ::obsinter_z1d.h90::H +DEP_PP::nemo__obs_level_search.h90 +DEP_PP::nemo__obs_mpp.F90 +DEP_PP::nemo__obs_oper.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__obs_prep.F90 ::domzgr_substitute.h90::H +DEP_PP::nemo__obs_profiles.F90 +DEP_PP::nemo__obs_profiles_def.F90 +DEP_PP::nemo__obs_read_altbias.F90 +DEP_PP::nemo__obs_read_prof.F90 +DEP_PP::nemo__obs_read_surf.F90 +DEP_PP::nemo__obs_readmdt.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__obs_rot_vel.F90 +DEP_PP::nemo__obs_sort.F90 +DEP_PP::nemo__obs_sstbias.F90 +DEP_PP::nemo__obs_surf_def.F90 +DEP_PP::nemo__obs_types.F90 +DEP_PP::nemo__obs_utils.F90 ::ddatetoymdhms.h90::H::grt_cir_dis.h90::H::grt_cir_dis_saa.h90::H::str_c_to_for.h90::H +DEP_PP::nemo__obs_write.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__obsinter_h2d.h90 +DEP_PP::nemo__obsinter_z1d.h90 +DEP_PP::nemo__oce.F90 +DEP_PP::nemo__ocealb.F90 +DEP_PP::nemo__par_kind.F90 +DEP_PP::nemo__par_oce.F90 +DEP_PP::nemo__phycst.F90 +DEP_PP::nemo__prtctl.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__restart.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__sbc_ice.F90 +DEP_PP::nemo__sbc_oce.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbc_phy.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcabl.F90 +DEP_PP::nemo__sbcapr.F90 +DEP_PP::nemo__sbcblk.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcblk_algo_andreas.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcblk_algo_coare3p0.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcblk_algo_coare3p6.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcblk_algo_ecmwf.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcblk_algo_ice_an05.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcblk_algo_ice_cdn.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcblk_algo_ice_lg15.F90 +DEP_PP::nemo__sbcblk_algo_ice_lu12.F90 +DEP_PP::nemo__sbcblk_algo_ncar.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcblk_skin_coare.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcblk_skin_ecmwf.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcclo.F90 +DEP_PP::nemo__sbccpl.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__sbcdcy.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcflx.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcfwb.F90 +DEP_PP::nemo__sbcice_cice.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcice_if.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcmod.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcrnf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__sbcssm.F90 ::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__sbcssr.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__sbcwave.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__single_precision_substitute.h90 +DEP_PP::nemo__solfrac_mod.F90 +DEP_PP::nemo__sshwzv.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__step.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__step_diu.F90 +DEP_PP::nemo__step_oce.F90 +DEP_PP::nemo__stopar.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__stopts.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__storng.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__stpctl.F90 ::single_precision_substitute.h90::H +DEP_PP::nemo__stpmlf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__str_c_to_for.h90 +DEP_PP::nemo__tide.h90 +DEP_PP::nemo__tide_mod.F90 ::tide.h90::H +DEP_PP::nemo__timing.F90 +DEP_PP::nemo__traadv.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traadv_cen.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traadv_cen_lf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__traadv_fct.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traadv_mus.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traadv_qck.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traadv_qck_lf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__traadv_ubs.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traadv_ubs_lf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__traatf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traatf_qco.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__trabbc.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__trabbl.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__tradmp.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traisf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traldf.F90 +DEP_PP::nemo__traldf_iso.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traldf_lap_blp.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traldf_triad.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__tramle.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__tranpc.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__traqsr.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__trasbc.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__trazdf.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__trc_oce.F90 +DEP_PP::nemo__trd_oce.F90 +DEP_PP::nemo__trddyn.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__trdglo.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__trdini.F90 +DEP_PP::nemo__trdken.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__trdmxl.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__trdmxl_oce.F90 +DEP_PP::nemo__trdmxl_rst.F90 +DEP_PP::nemo__trdpen.F90 ::domzgr_substitute.h90::H +DEP_PP::nemo__trdtra.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__trdtrc.F90 +DEP_PP::nemo__trdvor.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__trdvor_oce.F90 +DEP_PP::nemo__usrdef_fmask.F90 +DEP_PP::nemo__usrdef_hgr.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__usrdef_istate.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__usrdef_nam.F90 +DEP_PP::nemo__usrdef_sbc.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__usrdef_zgr.F90 +DEP_PP::nemo__wet_dry.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__zdf_oce.F90 +DEP_PP::nemo__zdfddm.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__zdfdrg.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__zdfevd.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__zdfgls.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__zdfiwm.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__zdfmfc.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H::single_precision_substitute.h90::H +DEP_PP::nemo__zdfmxl.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__zdfosm.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__zdfphy.F90 ::do_loop_substitute.h90::H +DEP_PP::nemo__zdfric.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__zdfsh2.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__zdfswm.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__zdftke.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::nemo__zpshde.F90 ::do_loop_substitute.h90::H::domzgr_substitute.h90::H +DEP_PP::ppr_1d__bfun1d.h90 +DEP_PP::ppr_1d__ffsl1d.h90 +DEP_PP::ppr_1d__inv.h90 +DEP_PP::ppr_1d__oscl1d.h90 +DEP_PP::ppr_1d__p1e.h90 +DEP_PP::ppr_1d__p3e.h90 +DEP_PP::ppr_1d__p5e.h90 +DEP_PP::ppr_1d__pbc.h90 +DEP_PP::ppr_1d__pcm.h90 +DEP_PP::ppr_1d__plm.h90 +DEP_PP::ppr_1d__ppm.h90 +DEP_PP::ppr_1d__ppr_1d.F90 ::bfun1d.h90::H::ffsl1d.h90::H::inv.h90::H::oscl1d.h90::H::p1e.h90::H::p3e.h90::H::p5e.h90::H::pbc.h90::H::pcm.h90::H::plm.h90::H::ppm.h90::H::pqm.h90::H::rcon1d.h90::H::rmap1d.h90::H::root1d.h90::H::util1d.h90::H::weno1d.h90::H +DEP_PP::ppr_1d__pqm.h90 +DEP_PP::ppr_1d__rcon1d.h90 +DEP_PP::ppr_1d__rmap1d.h90 +DEP_PP::ppr_1d__root1d.h90 +DEP_PP::ppr_1d__util1d.h90 +DEP_PP::ppr_1d__weno1d.h90 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/Makefile b/cfgs/ORCA2_OCE_MIXED/BLD/Makefile new file mode 100644 index 0000000000000000000000000000000000000000..5a3b5070332a12e8dddcf60d4dd19133e5e3d2e7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/Makefile @@ -0,0 +1,2988 @@ +# Automatic Makefile + +FCM_BLD_CFG = /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/mk/bldxag.cfg +export FCM_VERBOSE ?= 1 + +export FCM_ROOTDIR := /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/BLD +export FCM_CACHEDIR := $(FCM_ROOTDIR)/.cache/.bld +export FCM_CFGDIR := $(FCM_ROOTDIR)/cfg +export FCM_SRCDIR := $(FCM_ROOTDIR)/src +export FCM_BINDIR := $(FCM_ROOTDIR)/bin +export FCM_ETCDIR := $(FCM_ROOTDIR)/etc +export FCM_LIBDIR := $(FCM_ROOTDIR)/lib +export FCM_TMPDIR := $(FCM_ROOTDIR)/tmp +export FCM_DONEDIR := $(FCM_ROOTDIR)/done +export FCM_FLAGSDIR := $(FCM_ROOTDIR)/flags +export FCM_INCDIR := $(FCM_ROOTDIR)/inc +export FCM_PPSRCDIR := $(FCM_ROOTDIR)/ppsrc +export FCM_OBJDIR := $(FCM_ROOTDIR)/obj +export FCM_ROOTPATH := $(FCM_ROOTDIR) +export FCM_CACHEPATH := $(FCM_CACHEDIR) +export FCM_CFGPATH := $(FCM_CFGDIR) +export FCM_SRCPATH := $(FCM_SRCDIR) +export FCM_BINPATH := $(FCM_BINDIR) +export FCM_ETCPATH := $(FCM_ETCDIR) +export FCM_LIBPATH := $(FCM_LIBDIR) +export FCM_TMPPATH := $(FCM_TMPDIR) +export FCM_DONEPATH := $(FCM_DONEDIR) +export FCM_FLAGSPATH := $(FCM_FLAGSDIR) +export FCM_INCPATH := $(FCM_INCDIR) +export FCM_PPSRCPATH := $(FCM_PPSRCDIR) +export FCM_OBJPATH := $(FCM_OBJDIR) + +export PERL5LIB := /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/FCM/bin/../lib:$(PERL5LIB) + +export AR = ar +export ARFLAGS = -r +export CC = cc +export CC_COMPILE = -c +export CC_DEFINE = -D +export CC_INCLUDE = -I +export CC_OUTPUT = -o +export CFLAGS = +export CPPKEYS = +export DIFF3FLAGS = -E -m +export FC = mpiifort +export FC_COMPILE = -c +export FC_DEFINE = -D +export FC_INCLUDE = -I +export FC_MODSEARCH = +export FC_OUTPUT = -o +export FFLAGS = -r8 -ip -O3 -fp-model strict -extend-source 132 -heap-arrays -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include -I/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/xios_sources/trunk/inc +export FPPKEYS = key_xios key_qco key_single +export LD = mpiifort +export LDFLAGS = -lstdc++ -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff -L/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/xios_sources/trunk/lib -lxios -lstdc++ +export LD_LIBLINK = -l +export LD_LIBSEARCH = -L +export LD_OUTPUT = -o +export SHELL = /bin/sh + +vpath % $(FCM_BINPATH) +vpath %.done $(FCM_DONEPATH) +vpath %.idone $(FCM_DONEPATH) +vpath %.etc $(FCM_ETCPATH) +vpath %.flags $(FCM_FLAGSPATH) +vpath % $(FCM_INCPATH) +vpath %.a $(FCM_LIBPATH) +vpath %.o $(FCM_OBJPATH) + +FCM_BLD_TARGETS = nemo.exe + +.PHONY : all + +all : $(FCM_BLD_TARGETS) + +$(FCM_DONEDIR)/FCM_CP.dummy: + touch $@ + +CFLAGS__ppr_1d.flags: CFLAGS.flags + touch $(FCM_FLAGSDIR)/$@ + +CPPKEYS__ppr_1d.flags: CPPKEYS.flags + touch $(FCM_FLAGSDIR)/$@ + +FFLAGS__ppr_1d.flags: FFLAGS.flags + touch $(FCM_FLAGSDIR)/$@ + +FPPKEYS__ppr_1d.flags: FPPKEYS.flags + touch $(FCM_FLAGSDIR)/$@ + +LDFLAGS__ppr_1d.flags: LDFLAGS.flags + touch $(FCM_FLAGSDIR)/$@ + +LD__ppr_1d.flags: LD.flags + touch $(FCM_FLAGSDIR)/$@ + +OBJECTS__ppr_1d = ppr_1d.o + +libppr_1d.a: $(OBJECTS__ppr_1d) + fcm_internal archive $@ $^ + +CFLAGS__nemo.flags: CFLAGS.flags + touch $(FCM_FLAGSDIR)/$@ + +CPPKEYS__nemo.flags: CPPKEYS.flags + touch $(FCM_FLAGSDIR)/$@ + +FFLAGS__nemo.flags: FFLAGS.flags + touch $(FCM_FLAGSDIR)/$@ + +FPPKEYS__nemo.flags: FPPKEYS.flags + touch $(FCM_FLAGSDIR)/$@ + +LDFLAGS__nemo.flags: LDFLAGS.flags + touch $(FCM_FLAGSDIR)/$@ + +LD__nemo.flags: LD.flags + touch $(FCM_FLAGSDIR)/$@ + +OBJECTS__nemo = abl.o asmbkg.o asminc.o asmpar.o bdy_oce.o bdydta.o bdydyn.o bdydyn2d.o bdydyn3d.o bdyice.o bdyini.o bdylib.o bdytides.o bdytra.o bdyvol.o c1d.o closea.o cpl_oasis3.o crs.o crsdom.o crsdomwri.o crsfld.o crsini.o crslbclnk.o cyclone.o daymod.o depth_e3.o dia25h.o diaar5.o diacfl.o diadct.o diadetide.o diahsb.o diahth.o diamlr.o dianam.o diaobs.o diaptr.o diawri.o diu_bulk.o diu_coolskin.o diu_layers.o divhor.o dom_oce.o domain.o domhgr.o dommsk.o domqco.o domtile.o domutl.o domvvl.o domwri.o domzgr.o dtatsd.o dtauvd.o dynadv.o dynadv_cen2.o dynadv_ubs.o dynatf.o dynatf_qco.o dyndmp.o dynhpg.o dynkeg.o dynldf.o dynldf_iso.o dynldf_iso_lf.o dynldf_lap_blp.o dynldf_lap_blp_lf.o dynspg.o dynspg_exp.o dynspg_ts.o dynvor.o dynzad.o dynzdf.o eosbn2.o fldread.o flo4rk.o flo_oce.o floats.o floblk.o flodom.o florst.o flowri.o geo2ocean.o halo_mng.o icb_oce.o icbclv.o icbdia.o icbdyn.o icbini.o icblbc.o icbrst.o icbstp.o icbthm.o icbtrj.o icbutl.o in_out_manager.o iom.o iom_def.o iom_nf90.o isf_oce.o isfcav.o isfcavgam.o isfcavmlt.o isfcpl.o isfdiags.o isfdynatf.o isfhdiv.o isfload.o isfpar.o isfparmlt.o isfrst.o isfstp.o isftbl.o isfutils.o istate.o julian.o lbclnk.o lbcnfd.o ldfc1d_c2d.o ldfdyn.o ldfslp.o ldftra.o lib_cray.o lib_fortran.o lib_mpp.o exampl.o mpp_map.o mppini.o nemogcm.o obs_averg_h2d.o obs_const.o obs_conv.o obs_fbm.o obs_grid.o obs_inter_h2d.o obs_inter_sup.o obs_inter_z1d.o obs_mpp.o obs_oper.o obs_prep.o obs_profiles.o obs_profiles_def.o obs_read_altbias.o obs_read_prof.o obs_read_surf.o obs_readmdt.o obs_rot_vel.o obs_sort.o obs_sstbias.o obs_surf_def.o obs_types.o obs_utils.o obs_write.o oce.o ocealb.o par_kind.o par_oce.o phycst.o prtctl.o restart.o sbc_ice.o sbc_oce.o sbc_phy.o sbcabl.o sbcapr.o sbcblk.o sbcblk_algo_andreas.o sbcblk_algo_coare3p0.o sbcblk_algo_coare3p6.o sbcblk_algo_ecmwf.o sbcblk_algo_ice_an05.o sbcblk_algo_ice_cdn.o sbcblk_algo_ice_lg15.o sbcblk_algo_ice_lu12.o sbcblk_algo_ncar.o sbcblk_skin_coare.o sbcblk_skin_ecmwf.o sbcclo.o sbccpl.o sbcdcy.o sbcflx.o sbcfwb.o sbcice_cice.o sbcice_if.o sbcmod.o sbcrnf.o sbcssm.o sbcssr.o sbcwave.o solfrac_mod.o sshwzv.o step.o step_diu.o step_oce.o stopar.o stopts.o storng.o stpctl.o stpmlf.o tide_mod.o timing.o traadv.o traadv_cen.o traadv_cen_lf.o traadv_fct.o traadv_mus.o traadv_qck.o traadv_qck_lf.o traadv_ubs.o traadv_ubs_lf.o traatf.o traatf_qco.o trabbc.o trabbl.o tradmp.o traisf.o traldf.o traldf_iso.o traldf_lap_blp.o traldf_triad.o tramle.o tranpc.o traqsr.o trasbc.o trazdf.o trc_oce.o trd_oce.o trddyn.o trdglo.o trdini.o trdken.o trdmxl.o trdmxl_oce.o trdmxl_rst.o trdpen.o trdtra.o trdtrc.o trdvor.o trdvor_oce.o usrdef_fmask.o usrdef_hgr.o usrdef_istate.o usrdef_nam.o usrdef_sbc.o usrdef_zgr.o wet_dry.o zdf_oce.o zdfddm.o zdfdrg.o zdfevd.o zdfgls.o zdfiwm.o zdfmfc.o zdfmxl.o zdfosm.o zdfphy.o zdfric.o zdfsh2.o zdfswm.o zdftke.o zpshde.o + +libnemo.a: $(OBJECTS__nemo) + fcm_internal archive $@ $^ + +CFLAGS__ioipsl.flags: CFLAGS.flags + touch $(FCM_FLAGSDIR)/$@ + +CPPKEYS__ioipsl.flags: CPPKEYS.flags + touch $(FCM_FLAGSDIR)/$@ + +FFLAGS__ioipsl.flags: FFLAGS.flags + touch $(FCM_FLAGSDIR)/$@ + +FPPKEYS__ioipsl.flags: FPPKEYS.flags + touch $(FCM_FLAGSDIR)/$@ + +LDFLAGS__ioipsl.flags: LDFLAGS.flags + touch $(FCM_FLAGSDIR)/$@ + +LD__ioipsl.flags: LD.flags + touch $(FCM_FLAGSDIR)/$@ + +OBJECTS__ioipsl = calendar.o defprec.o errioipsl.o flincom.o fliocom.o getincom.o histcom.o ioipsl.o mathelp.o nc4interface.o restcom.o stringop.o + +libioipsl.a: $(OBJECTS__ioipsl) + fcm_internal archive $@ $^ + +CC.flags: + touch $(FCM_FLAGSDIR)/$@ + +CFLAGS.flags: CC.flags + touch $(FCM_FLAGSDIR)/$@ + +CPPKEYS.flags: + touch $(FCM_FLAGSDIR)/$@ + +FC.flags: + touch $(FCM_FLAGSDIR)/$@ + +FFLAGS.flags: FC.flags + touch $(FCM_FLAGSDIR)/$@ + +FPPKEYS.flags: + touch $(FCM_FLAGSDIR)/$@ + +LD.flags: + touch $(FCM_FLAGSDIR)/$@ + +LDFLAGS.flags: + touch $(FCM_FLAGSDIR)/$@ + +export OBJECTS = $(OBJECTS__ioipsl) $(OBJECTS__nemo) $(OBJECTS__ppr_1d) + +libfcm_default.a: $(OBJECTS) + fcm_internal archive $@ $^ + +FFLAGS__ioipsl__calendar.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +calendar.done: calendar.o errioipsl.done stringop.done + touch $(FCM_DONEDIR)/$@ + +calendar.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src/calendar.f90 FFLAGS__ioipsl__calendar.flags errioipsl.o stringop.o + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__ioipsl__defprec.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +defprec.done: defprec.o + touch $(FCM_DONEDIR)/$@ + +defprec.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src/defprec.f90 FFLAGS__ioipsl__defprec.flags + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__ioipsl__errioipsl.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +errioipsl.done: errioipsl.o + touch $(FCM_DONEDIR)/$@ + +errioipsl.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src/errioipsl.f90 FFLAGS__ioipsl__errioipsl.flags + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__ioipsl__flincom.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +flincom.done: flincom.o calendar.done errioipsl.done stringop.done + touch $(FCM_DONEDIR)/$@ + +flincom.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src/flincom.f90 FFLAGS__ioipsl__flincom.flags calendar.o errioipsl.o stringop.o + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__ioipsl__fliocom.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +fliocom.done: fliocom.o calendar.done defprec.done errioipsl.done stringop.done + touch $(FCM_DONEDIR)/$@ + +fliocom.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src/fliocom.f90 FFLAGS__ioipsl__fliocom.flags calendar.o defprec.o errioipsl.o stringop.o + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__ioipsl__getincom.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +getincom.done: getincom.o errioipsl.done stringop.done + touch $(FCM_DONEDIR)/$@ + +getincom.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src/getincom.f90 FFLAGS__ioipsl__getincom.flags errioipsl.o stringop.o + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__ioipsl__histcom.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +histcom.done: histcom.o calendar.done errioipsl.done fliocom.done mathelp.done nc4interface.done stringop.done + touch $(FCM_DONEDIR)/$@ + +histcom.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src/histcom.f90 FFLAGS__ioipsl__histcom.flags calendar.o errioipsl.o fliocom.o mathelp.o nc4interface.o stringop.o + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__ioipsl__ioipsl.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +ioipsl.done: ioipsl.o calendar.done errioipsl.done flincom.done fliocom.done getincom.done histcom.done mathelp.done restcom.done stringop.done + touch $(FCM_DONEDIR)/$@ + +ioipsl.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src/ioipsl.f90 FFLAGS__ioipsl__ioipsl.flags calendar.o errioipsl.o flincom.o fliocom.o getincom.o histcom.o mathelp.o restcom.o stringop.o + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__ioipsl__mathelp.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +mathelp.done: mathelp.o errioipsl.done stringop.done + touch $(FCM_DONEDIR)/$@ + +mathelp.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src/mathelp.f90 FFLAGS__ioipsl__mathelp.flags errioipsl.o stringop.o + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__ioipsl__nc4interface.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +nc4interface.done: nc4interface.o + touch $(FCM_DONEDIR)/$@ + +nc4interface.o: $(FCM_PPSRCDIR)/ioipsl/nc4interface.f90 FFLAGS__ioipsl__nc4interface.flags + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__ioipsl__restcom.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +restcom.done: restcom.o calendar.done errioipsl.done fliocom.done mathelp.done stringop.done + touch $(FCM_DONEDIR)/$@ + +restcom.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src/restcom.f90 FFLAGS__ioipsl__restcom.flags calendar.o errioipsl.o fliocom.o mathelp.o stringop.o + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__ioipsl__stringop.flags: FFLAGS__ioipsl.flags + touch $(FCM_FLAGSDIR)/$@ + +stringop.done: stringop.o + touch $(FCM_DONEDIR)/$@ + +stringop.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src/stringop.f90 FFLAGS__ioipsl__stringop.flags + fcm_internal compile:F ioipsl $< $@ + +FFLAGS__nemo__abl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +abl.done: abl.o par_kind.done + touch $(FCM_DONEDIR)/$@ + +abl.o: $(FCM_PPSRCDIR)/nemo/abl.f90 FFLAGS__nemo__abl.flags par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__asmbkg.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +asmbkg.done: asmbkg.o asmpar.done dom_oce.done eosbn2.done in_out_manager.done iom.done ldfslp.done ldftra.done oce.done sbc_oce.done tradmp.done zdf_oce.done zdfddm.done zdfmxl.done zdftke.done + touch $(FCM_DONEDIR)/$@ + +asmbkg.o: $(FCM_PPSRCDIR)/nemo/asmbkg.f90 FFLAGS__nemo__asmbkg.flags asmpar.o dom_oce.o eosbn2.o in_out_manager.o iom.o ldfslp.o ldftra.o oce.o sbc_oce.o tradmp.o zdf_oce.o zdfddm.o zdfmxl.o zdftke.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__asminc.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +asminc.done: asminc.o asmbkg.done asmpar.done c1d.done diaobs.done dom_oce.done domvvl.done eosbn2.done in_out_manager.done iom.done ldfdyn.done lib_mpp.done oce.done par_oce.done sbc_oce.done zpshde.done + touch $(FCM_DONEDIR)/$@ + +asminc.o: $(FCM_PPSRCDIR)/nemo/asminc.f90 FFLAGS__nemo__asminc.flags asmbkg.o asmpar.o c1d.o diaobs.o dom_oce.o domvvl.o eosbn2.o in_out_manager.o iom.o ldfdyn.o lib_mpp.o oce.o par_oce.o sbc_oce.o zpshde.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__asmpar.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +asmpar.done: asmpar.o + touch $(FCM_DONEDIR)/$@ + +asmpar.o: $(FCM_PPSRCDIR)/nemo/asmpar.f90 FFLAGS__nemo__asmpar.flags + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__bdy_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +bdy_oce.done: bdy_oce.o lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +bdy_oce.o: $(FCM_PPSRCDIR)/nemo/bdy_oce.f90 FFLAGS__nemo__bdy_oce.flags lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__bdydta.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +bdydta.done: bdydta.o bdy_oce.done bdytides.done dom_oce.done fldread.done in_out_manager.done iom.done lib_mpp.done oce.done phycst.done sbcapr.done tide_mod.done timing.done + touch $(FCM_DONEDIR)/$@ + +bdydta.o: $(FCM_PPSRCDIR)/nemo/bdydta.f90 FFLAGS__nemo__bdydta.flags bdy_oce.o bdytides.o dom_oce.o fldread.o in_out_manager.o iom.o lib_mpp.o oce.o phycst.o sbcapr.o tide_mod.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__bdydyn.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +bdydyn.done: bdydyn.o bdy_oce.done bdydyn2d.done bdydyn3d.done dom_oce.done domvvl.done in_out_manager.done lbclnk.done oce.done + touch $(FCM_DONEDIR)/$@ + +bdydyn.o: $(FCM_PPSRCDIR)/nemo/bdydyn.f90 FFLAGS__nemo__bdydyn.flags bdy_oce.o bdydyn2d.o bdydyn3d.o dom_oce.o domvvl.o in_out_manager.o lbclnk.o oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__bdydyn2d.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +bdydyn2d.done: bdydyn2d.o bdy_oce.done bdylib.done dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done phycst.done wet_dry.done + touch $(FCM_DONEDIR)/$@ + +bdydyn2d.o: $(FCM_PPSRCDIR)/nemo/bdydyn2d.f90 FFLAGS__nemo__bdydyn2d.flags bdy_oce.o bdylib.o dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o phycst.o wet_dry.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__bdydyn3d.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +bdydyn3d.done: bdydyn3d.o bdy_oce.done bdylib.done dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done oce.done phycst.done timing.done + touch $(FCM_DONEDIR)/$@ + +bdydyn3d.o: $(FCM_PPSRCDIR)/nemo/bdydyn3d.f90 FFLAGS__nemo__bdydyn3d.flags bdy_oce.o bdylib.o dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o oce.o phycst.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__bdyice.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +bdyice.done: bdyice.o + touch $(FCM_DONEDIR)/$@ + +bdyice.o: $(FCM_PPSRCDIR)/nemo/bdyice.f90 FFLAGS__nemo__bdyice.flags + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__bdyini.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +bdyini.done: bdyini.o bdy_oce.done bdydta.done bdytides.done dom_oce.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done sbc_oce.done tide_mod.done + touch $(FCM_DONEDIR)/$@ + +bdyini.o: $(FCM_PPSRCDIR)/nemo/bdyini.f90 FFLAGS__nemo__bdyini.flags bdy_oce.o bdydta.o bdytides.o dom_oce.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o sbc_oce.o tide_mod.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__bdylib.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +bdylib.done: bdylib.o bdy_oce.done bdyini.done dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +bdylib.o: $(FCM_PPSRCDIR)/nemo/bdylib.f90 FFLAGS__nemo__bdylib.flags bdy_oce.o bdyini.o dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__bdytides.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +bdytides.done: bdytides.o bdy_oce.done daymod.done dom_oce.done fldread.done in_out_manager.done iom.done lbclnk.done oce.done phycst.done tide_mod.done + touch $(FCM_DONEDIR)/$@ + +bdytides.o: $(FCM_PPSRCDIR)/nemo/bdytides.f90 FFLAGS__nemo__bdytides.flags bdy_oce.o daymod.o dom_oce.o fldread.o in_out_manager.o iom.o lbclnk.o oce.o phycst.o tide_mod.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__bdytra.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +bdytra.done: bdytra.o bdy_oce.done bdylib.done dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done oce.done timing.done + touch $(FCM_DONEDIR)/$@ + +bdytra.o: $(FCM_PPSRCDIR)/nemo/bdytra.f90 FFLAGS__nemo__bdytra.flags bdy_oce.o bdylib.o dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o oce.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__bdyvol.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +bdyvol.done: bdyvol.o bdy_oce.done dom_oce.done in_out_manager.done isf_oce.done lib_fortran.done lib_mpp.done oce.done phycst.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +bdyvol.o: $(FCM_PPSRCDIR)/nemo/bdyvol.f90 FFLAGS__nemo__bdyvol.flags bdy_oce.o dom_oce.o in_out_manager.o isf_oce.o lib_fortran.o lib_mpp.o oce.o phycst.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__c1d.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +c1d.done: c1d.o in_out_manager.done lib_mpp.done par_kind.done + touch $(FCM_DONEDIR)/$@ + +c1d.o: $(FCM_PPSRCDIR)/nemo/c1d.f90 FFLAGS__nemo__c1d.flags in_out_manager.o lib_mpp.o par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__closea.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +closea.done: closea.o diu_bulk.done in_out_manager.done iom.done lib_fortran.done lib_mpp.done + touch $(FCM_DONEDIR)/$@ + +closea.o: $(FCM_PPSRCDIR)/nemo/closea.f90 FFLAGS__nemo__closea.flags diu_bulk.o in_out_manager.o iom.o lib_fortran.o lib_mpp.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__cpl_oasis3.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +cpl_oasis3.done: cpl_oasis3.o dom_oce.done in_out_manager.done lbclnk.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +cpl_oasis3.o: $(FCM_PPSRCDIR)/nemo/cpl_oasis3.f90 FFLAGS__nemo__cpl_oasis3.flags dom_oce.o in_out_manager.o lbclnk.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__crs.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +crs.done: crs.o dom_oce.done in_out_manager.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +crs.o: $(FCM_PPSRCDIR)/nemo/crs.f90 FFLAGS__nemo__crs.flags dom_oce.o in_out_manager.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__crsdom.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +crsdom.done: crsdom.o crs.done crslbclnk.done dom_oce.done in_out_manager.done lib_mpp.done par_kind.done + touch $(FCM_DONEDIR)/$@ + +crsdom.o: $(FCM_PPSRCDIR)/nemo/crsdom.f90 FFLAGS__nemo__crsdom.flags crs.o crslbclnk.o dom_oce.o in_out_manager.o lib_mpp.o par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__crsdomwri.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +crsdomwri.done: crsdomwri.o crs.done crsdom.done crslbclnk.done dom_oce.done in_out_manager.done iom.done iom_def.done lib_mpp.done par_kind.done timing.done + touch $(FCM_DONEDIR)/$@ + +crsdomwri.o: $(FCM_PPSRCDIR)/nemo/crsdomwri.f90 FFLAGS__nemo__crsdomwri.flags crs.o crsdom.o crslbclnk.o dom_oce.o in_out_manager.o iom.o iom_def.o lib_mpp.o par_kind.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__crsfld.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +crsfld.done: crsfld.o crs.done crsdom.done crslbclnk.done dom_oce.done in_out_manager.done iom.done lbclnk.done ldftra.done oce.done sbc_oce.done timing.done zdf_oce.done zdfddm.done + touch $(FCM_DONEDIR)/$@ + +crsfld.o: $(FCM_PPSRCDIR)/nemo/crsfld.f90 FFLAGS__nemo__crsfld.flags crs.o crsdom.o crslbclnk.o dom_oce.o in_out_manager.o iom.o lbclnk.o ldftra.o oce.o sbc_oce.o timing.o zdf_oce.o zdfddm.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__crsini.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +crsini.done: crsini.o crs.done crsdom.done crsdomwri.done crslbclnk.done dom_oce.done in_out_manager.done iom.done lib_mpp.done par_kind.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +crsini.o: $(FCM_PPSRCDIR)/nemo/crsini.f90 FFLAGS__nemo__crsini.flags crs.o crsdom.o crsdomwri.o crslbclnk.o dom_oce.o in_out_manager.o iom.o lib_mpp.o par_kind.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__crslbclnk.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +crslbclnk.done: crslbclnk.o crs.done dom_oce.done in_out_manager.done lbclnk.done par_kind.done + touch $(FCM_DONEDIR)/$@ + +crslbclnk.o: $(FCM_PPSRCDIR)/nemo/crslbclnk.f90 FFLAGS__nemo__crslbclnk.flags crs.o dom_oce.o in_out_manager.o lbclnk.o par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__cyclone.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +cyclone.done: cyclone.o + touch $(FCM_DONEDIR)/$@ + +cyclone.o: $(FCM_PPSRCDIR)/nemo/cyclone.f90 FFLAGS__nemo__cyclone.flags + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__daymod.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +daymod.done: daymod.o dom_oce.done in_out_manager.done ioipsl.done iom.done phycst.done prtctl.done restart.done timing.done trc_oce.done + touch $(FCM_DONEDIR)/$@ + +daymod.o: $(FCM_PPSRCDIR)/nemo/daymod.f90 FFLAGS__nemo__daymod.flags dom_oce.o in_out_manager.o ioipsl.o iom.o phycst.o prtctl.o restart.o timing.o trc_oce.o + fcm_internal compile:F nemo $< $@ + +ddatetoymdhms.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/ddatetoymdhms.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +ddatetoymdhms.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/ddatetoymdhms.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__depth_e3.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +depth_e3.done: depth_e3.o dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done oce.done timing.done + touch $(FCM_DONEDIR)/$@ + +depth_e3.o: $(FCM_PPSRCDIR)/nemo/depth_e3.f90 FFLAGS__nemo__depth_e3.flags dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o oce.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dia25h.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dia25h.done: dia25h.o dom_oce.done in_out_manager.done iom.done oce.done wet_dry.done zdf_oce.done zdfgls.done + touch $(FCM_DONEDIR)/$@ + +dia25h.o: $(FCM_PPSRCDIR)/nemo/dia25h.f90 FFLAGS__nemo__dia25h.flags dom_oce.o in_out_manager.o iom.o oce.o wet_dry.o zdf_oce.o zdfgls.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diaar5.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diaar5.done: diaar5.o dom_oce.done eosbn2.done fldread.done in_out_manager.done iom.done lib_mpp.done oce.done phycst.done timing.done zdf_oce.done zdfddm.done + touch $(FCM_DONEDIR)/$@ + +diaar5.o: $(FCM_PPSRCDIR)/nemo/diaar5.f90 FFLAGS__nemo__diaar5.flags dom_oce.o eosbn2.o fldread.o in_out_manager.o iom.o lib_mpp.o oce.o phycst.o timing.o zdf_oce.o zdfddm.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diacfl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diacfl.done: diacfl.o dom_oce.done domvvl.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done timing.done + touch $(FCM_DONEDIR)/$@ + +diacfl.o: $(FCM_PPSRCDIR)/nemo/diacfl.f90 FFLAGS__nemo__diacfl.flags dom_oce.o domvvl.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diadct.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diadct.done: diadct.o daymod.done dianam.done dom_oce.done domvvl.done in_out_manager.done lib_mpp.done oce.done phycst.done timing.done + touch $(FCM_DONEDIR)/$@ + +diadct.o: $(FCM_PPSRCDIR)/nemo/diadct.f90 FFLAGS__nemo__diadct.flags daymod.o dianam.o dom_oce.o domvvl.o in_out_manager.o lib_mpp.o oce.o phycst.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diadetide.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diadetide.done: diadetide.o dom_oce.done in_out_manager.done iom.done par_kind.done par_oce.done phycst.done tide_mod.done + touch $(FCM_DONEDIR)/$@ + +diadetide.o: $(FCM_PPSRCDIR)/nemo/diadetide.f90 FFLAGS__nemo__diadetide.flags dom_oce.o in_out_manager.o iom.o par_kind.o par_oce.o phycst.o tide_mod.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diahsb.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diahsb.done: diahsb.o bdy_oce.done dom_oce.done domvvl.done in_out_manager.done iom.done isf_oce.done lib_fortran.done lib_mpp.done oce.done phycst.done restart.done sbc_oce.done sbcrnf.done timing.done trabbc.done traqsr.done + touch $(FCM_DONEDIR)/$@ + +diahsb.o: $(FCM_PPSRCDIR)/nemo/diahsb.f90 FFLAGS__nemo__diahsb.flags bdy_oce.o dom_oce.o domvvl.o in_out_manager.o iom.o isf_oce.o lib_fortran.o lib_mpp.o oce.o phycst.o restart.o sbc_oce.o sbcrnf.o timing.o trabbc.o traqsr.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diahth.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diahth.done: diahth.o dom_oce.done in_out_manager.done iom.done lib_mpp.done oce.done phycst.done timing.done + touch $(FCM_DONEDIR)/$@ + +diahth.o: $(FCM_PPSRCDIR)/nemo/diahth.f90 FFLAGS__nemo__diahth.flags dom_oce.o in_out_manager.o iom.o lib_mpp.o oce.o phycst.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diamlr.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diamlr.done: diamlr.o dom_oce.done in_out_manager.done iom.done par_kind.done par_oce.done phycst.done tide_mod.done timing.done + touch $(FCM_DONEDIR)/$@ + +diamlr.o: $(FCM_PPSRCDIR)/nemo/diamlr.f90 FFLAGS__nemo__diamlr.flags dom_oce.o in_out_manager.o iom.o par_kind.o par_oce.o phycst.o tide_mod.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dianam.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dianam.done: dianam.o dom_oce.done in_out_manager.done ioipsl.done phycst.done + touch $(FCM_DONEDIR)/$@ + +dianam.o: $(FCM_PPSRCDIR)/nemo/dianam.f90 FFLAGS__nemo__dianam.flags dom_oce.o in_out_manager.o ioipsl.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diaobs.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diaobs.done: diaobs.o dom_oce.done in_out_manager.done lib_mpp.done mpp_map.done obs_grid.done obs_oper.done obs_prep.done obs_profiles_def.done obs_read_altbias.done obs_read_prof.done obs_read_surf.done obs_readmdt.done obs_rot_vel.done obs_sstbias.done obs_surf_def.done obs_types.done obs_write.done oce.done par_kind.done par_oce.done phycst.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +diaobs.o: $(FCM_PPSRCDIR)/nemo/diaobs.f90 FFLAGS__nemo__diaobs.flags dom_oce.o in_out_manager.o lib_mpp.o mpp_map.o obs_grid.o obs_oper.o obs_prep.o obs_profiles_def.o obs_read_altbias.o obs_read_prof.o obs_read_surf.o obs_readmdt.o obs_rot_vel.o obs_sstbias.o obs_surf_def.o obs_types.o obs_write.o oce.o par_kind.o par_oce.o phycst.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diaptr.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diaptr.done: diaptr.o dom_oce.done domtile.done in_out_manager.done iom.done lib_mpp.done oce.done phycst.done timing.done + touch $(FCM_DONEDIR)/$@ + +diaptr.o: $(FCM_PPSRCDIR)/nemo/diaptr.f90 FFLAGS__nemo__diaptr.flags dom_oce.o domtile.o in_out_manager.o iom.o lib_mpp.o oce.o phycst.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diawri.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diawri.done: diawri.o abl.done dia25h.done diahth.done dianam.done diu_bulk.done diu_coolskin.done dom_oce.done dynadv.done icb_oce.done icbdia.done in_out_manager.done ioipsl.done iom.done isf_oce.done isfcpl.done lbclnk.done ldfdyn.done ldftra.done lib_mpp.done oce.done phycst.done sbc_ice.done sbc_oce.done sbcssr.done sbcwave.done timing.done wet_dry.done zdf_oce.done zdfdrg.done zdfmxl.done zdfosm.done + touch $(FCM_DONEDIR)/$@ + +diawri.o: $(FCM_PPSRCDIR)/nemo/diawri.f90 FFLAGS__nemo__diawri.flags abl.o dia25h.o diahth.o dianam.o diu_bulk.o diu_coolskin.o dom_oce.o dynadv.o icb_oce.o icbdia.o in_out_manager.o ioipsl.o iom.o isf_oce.o isfcpl.o lbclnk.o ldfdyn.o ldftra.o lib_mpp.o oce.o phycst.o sbc_ice.o sbc_oce.o sbcssr.o sbcwave.o timing.o wet_dry.o zdf_oce.o zdfdrg.o zdfmxl.o zdfosm.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diu_bulk.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diu_bulk.done: diu_bulk.o dom_oce.done in_out_manager.done lib_mpp.done par_kind.done phycst.done solfrac_mod.done + touch $(FCM_DONEDIR)/$@ + +diu_bulk.o: $(FCM_PPSRCDIR)/nemo/diu_bulk.f90 FFLAGS__nemo__diu_bulk.flags dom_oce.o in_out_manager.o lib_mpp.o par_kind.o phycst.o solfrac_mod.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diu_coolskin.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diu_coolskin.done: diu_coolskin.o dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done par_kind.done phycst.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +diu_coolskin.o: $(FCM_PPSRCDIR)/nemo/diu_coolskin.f90 FFLAGS__nemo__diu_coolskin.flags dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o par_kind.o phycst.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__diu_layers.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +diu_layers.done: diu_layers.o diu_bulk.done diu_coolskin.done iom.done oce.done sbc_oce.done sbcmod.done + touch $(FCM_DONEDIR)/$@ + +diu_layers.o: $(FCM_PPSRCDIR)/nemo/diu_layers.f90 FFLAGS__nemo__diu_layers.flags diu_bulk.o diu_coolskin.o iom.o oce.o sbc_oce.o sbcmod.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__divhor.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +divhor.done: divhor.o dom_oce.done in_out_manager.done isf_oce.done isfhdiv.done lbclnk.done lib_mpp.done oce.done sbc_oce.done sbcrnf.done timing.done + touch $(FCM_DONEDIR)/$@ + +divhor.o: $(FCM_PPSRCDIR)/nemo/divhor.f90 FFLAGS__nemo__divhor.flags dom_oce.o in_out_manager.o isf_oce.o isfhdiv.o lbclnk.o lib_mpp.o oce.o sbc_oce.o sbcrnf.o timing.o + fcm_internal compile:F nemo $< $@ + +do_loop_substitute.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/do_loop_substitute.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +do_loop_substitute.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/do_loop_substitute.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__dom_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dom_oce.done: dom_oce.o par_oce.done + touch $(FCM_DONEDIR)/$@ + +dom_oce.o: $(FCM_PPSRCDIR)/nemo/dom_oce.f90 FFLAGS__nemo__dom_oce.flags par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__domain.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +domain.done: domain.o c1d.done closea.done dom_oce.done domhgr.done dommsk.done domqco.done domtile.done domwri.done domzgr.done in_out_manager.done ioipsl.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done restart.done sbc_oce.done trc_oce.done wet_dry.done + touch $(FCM_DONEDIR)/$@ + +domain.o: $(FCM_PPSRCDIR)/nemo/domain.f90 FFLAGS__nemo__domain.flags c1d.o closea.o dom_oce.o domhgr.o dommsk.o domqco.o domtile.o domwri.o domzgr.o in_out_manager.o ioipsl.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o restart.o sbc_oce.o trc_oce.o wet_dry.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__domhgr.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +domhgr.done: domhgr.o dom_oce.done in_out_manager.done iom.done lbclnk.done lib_mpp.done par_oce.done phycst.done timing.done usrdef_hgr.done + touch $(FCM_DONEDIR)/$@ + +domhgr.o: $(FCM_PPSRCDIR)/nemo/domhgr.f90 FFLAGS__nemo__domhgr.flags dom_oce.o in_out_manager.o iom.o lbclnk.o lib_mpp.o par_oce.o phycst.o timing.o usrdef_hgr.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dommsk.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dommsk.done: dommsk.o bdy_oce.done dom_oce.done domutl.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done usrdef_fmask.done + touch $(FCM_DONEDIR)/$@ + +dommsk.o: $(FCM_PPSRCDIR)/nemo/dommsk.f90 FFLAGS__nemo__dommsk.flags bdy_oce.o dom_oce.o domutl.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o usrdef_fmask.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__domqco.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +domqco.done: domqco.o dom_oce.done dynadv.done in_out_manager.done iom.done isf_oce.done lbclnk.done lib_mpp.done oce.done phycst.done restart.done sbc_oce.done timing.done usrdef_istate.done wet_dry.done + touch $(FCM_DONEDIR)/$@ + +domqco.o: $(FCM_PPSRCDIR)/nemo/domqco.f90 FFLAGS__nemo__domqco.flags dom_oce.o dynadv.o in_out_manager.o iom.o isf_oce.o lbclnk.o lib_mpp.o oce.o phycst.o restart.o sbc_oce.o timing.o usrdef_istate.o wet_dry.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__domtile.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +domtile.done: domtile.o dom_oce.done in_out_manager.done lib_mpp.done prtctl.done + touch $(FCM_DONEDIR)/$@ + +domtile.o: $(FCM_PPSRCDIR)/nemo/domtile.f90 FFLAGS__nemo__domtile.flags dom_oce.o in_out_manager.o lib_mpp.o prtctl.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__domutl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +domutl.done: domutl.o dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done + touch $(FCM_DONEDIR)/$@ + +domutl.o: $(FCM_PPSRCDIR)/nemo/domutl.f90 FFLAGS__nemo__domutl.flags dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__domvvl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +domvvl.done: domvvl.o dom_oce.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done restart.done sbc_oce.done timing.done usrdef_istate.done wet_dry.done + touch $(FCM_DONEDIR)/$@ + +domvvl.o: $(FCM_PPSRCDIR)/nemo/domvvl.f90 FFLAGS__nemo__domvvl.flags dom_oce.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o restart.o sbc_oce.o timing.o usrdef_istate.o wet_dry.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__domwri.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +domwri.done: domwri.o dom_oce.done domutl.done in_out_manager.done iom.done lbclnk.done lib_mpp.done phycst.done wet_dry.done + touch $(FCM_DONEDIR)/$@ + +domwri.o: $(FCM_PPSRCDIR)/nemo/domwri.f90 FFLAGS__nemo__domwri.flags dom_oce.o domutl.o in_out_manager.o iom.o lbclnk.o lib_mpp.o phycst.o wet_dry.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__domzgr.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +domzgr.done: domzgr.o closea.done depth_e3.done dom_oce.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done usrdef_zgr.done wet_dry.done + touch $(FCM_DONEDIR)/$@ + +domzgr.o: $(FCM_PPSRCDIR)/nemo/domzgr.f90 FFLAGS__nemo__domzgr.flags closea.o depth_e3.o dom_oce.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o usrdef_zgr.o wet_dry.o + fcm_internal compile:F nemo $< $@ + +domzgr_substitute.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/domzgr_substitute.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +domzgr_substitute.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/domzgr_substitute.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__dtatsd.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dtatsd.done: dtatsd.o dom_oce.done domtile.done fldread.done in_out_manager.done lib_mpp.done oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +dtatsd.o: $(FCM_PPSRCDIR)/nemo/dtatsd.f90 FFLAGS__nemo__dtatsd.flags dom_oce.o domtile.o fldread.o in_out_manager.o lib_mpp.o oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dtauvd.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dtauvd.done: dtauvd.o dom_oce.done fldread.done in_out_manager.done lib_mpp.done oce.done phycst.done timing.done + touch $(FCM_DONEDIR)/$@ + +dtauvd.o: $(FCM_PPSRCDIR)/nemo/dtauvd.f90 FFLAGS__nemo__dtauvd.flags dom_oce.o fldread.o in_out_manager.o lib_mpp.o oce.o phycst.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynadv.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynadv.done: dynadv.o dom_oce.done dynadv_cen2.done dynadv_ubs.done dynkeg.done dynzad.done in_out_manager.done lib_mpp.done timing.done + touch $(FCM_DONEDIR)/$@ + +dynadv.o: $(FCM_PPSRCDIR)/nemo/dynadv.f90 FFLAGS__nemo__dynadv.flags dom_oce.o dynadv_cen2.o dynadv_ubs.o dynkeg.o dynzad.o in_out_manager.o lib_mpp.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynadv_cen2.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynadv_cen2.done: dynadv_cen2.o dom_oce.done in_out_manager.done lib_mpp.done oce.done prtctl.done trd_oce.done trddyn.done + touch $(FCM_DONEDIR)/$@ + +dynadv_cen2.o: $(FCM_PPSRCDIR)/nemo/dynadv_cen2.f90 FFLAGS__nemo__dynadv_cen2.flags dom_oce.o in_out_manager.o lib_mpp.o oce.o prtctl.o trd_oce.o trddyn.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynadv_ubs.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynadv_ubs.done: dynadv_ubs.o dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done oce.done prtctl.done trd_oce.done trddyn.done + touch $(FCM_DONEDIR)/$@ + +dynadv_ubs.o: $(FCM_PPSRCDIR)/nemo/dynadv_ubs.f90 FFLAGS__nemo__dynadv_ubs.flags dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o oce.o prtctl.o trd_oce.o trddyn.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynatf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynatf.done: dynatf.o bdy_oce.done bdydta.done bdydyn.done bdyvol.done dom_oce.done domvvl.done dynadv.done dynspg_ts.done in_out_manager.done iom.done isf_oce.done isfdynatf.done lbclnk.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done sbcrnf.done timing.done trd_oce.done trddyn.done trdken.done zdfdrg.done + touch $(FCM_DONEDIR)/$@ + +dynatf.o: $(FCM_PPSRCDIR)/nemo/dynatf.f90 FFLAGS__nemo__dynatf.flags bdy_oce.o bdydta.o bdydyn.o bdyvol.o dom_oce.o domvvl.o dynadv.o dynspg_ts.o in_out_manager.o iom.o isf_oce.o isfdynatf.o lbclnk.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o sbcrnf.o timing.o trd_oce.o trddyn.o trdken.o zdfdrg.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynatf_qco.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynatf_qco.done: dynatf_qco.o bdy_oce.done bdydta.done bdydyn.done bdyvol.done dom_oce.done domvvl.done dynadv.done dynspg_ts.done in_out_manager.done iom.done isf_oce.done isfdynatf.done lbclnk.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done sbcrnf.done timing.done trd_oce.done trddyn.done trdken.done zdfdrg.done + touch $(FCM_DONEDIR)/$@ + +dynatf_qco.o: $(FCM_PPSRCDIR)/nemo/dynatf_qco.f90 FFLAGS__nemo__dynatf_qco.flags bdy_oce.o bdydta.o bdydyn.o bdyvol.o dom_oce.o domvvl.o dynadv.o dynspg_ts.o in_out_manager.o iom.o isf_oce.o isfdynatf.o lbclnk.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o sbcrnf.o timing.o trd_oce.o trddyn.o trdken.o zdfdrg.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dyndmp.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dyndmp.done: dyndmp.o c1d.done dom_oce.done dtauvd.done in_out_manager.done iom.done lib_mpp.done oce.done phycst.done prtctl.done timing.done tradmp.done zdf_oce.done zdfmxl.done + touch $(FCM_DONEDIR)/$@ + +dyndmp.o: $(FCM_PPSRCDIR)/nemo/dyndmp.f90 FFLAGS__nemo__dyndmp.flags c1d.o dom_oce.o dtauvd.o in_out_manager.o iom.o lib_mpp.o oce.o phycst.o prtctl.o timing.o tradmp.o zdf_oce.o zdfmxl.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynhpg.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynhpg.done: dynhpg.o dom_oce.done eosbn2.done in_out_manager.done iom.done isf_oce.done isfload.done lbclnk.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done timing.done trd_oce.done trddyn.done wet_dry.done zpshde.done + touch $(FCM_DONEDIR)/$@ + +dynhpg.o: $(FCM_PPSRCDIR)/nemo/dynhpg.f90 FFLAGS__nemo__dynhpg.flags dom_oce.o eosbn2.o in_out_manager.o iom.o isf_oce.o isfload.o lbclnk.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o timing.o trd_oce.o trddyn.o wet_dry.o zpshde.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynkeg.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynkeg.done: dynkeg.o bdy_oce.done dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done oce.done prtctl.done timing.done trd_oce.done trddyn.done + touch $(FCM_DONEDIR)/$@ + +dynkeg.o: $(FCM_PPSRCDIR)/nemo/dynkeg.f90 FFLAGS__nemo__dynkeg.flags bdy_oce.o dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o oce.o prtctl.o timing.o trd_oce.o trddyn.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynldf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynldf.done: dynldf.o dom_oce.done dynldf_iso.done dynldf_lap_blp.done in_out_manager.done lbclnk.done ldfdyn.done lib_mpp.done oce.done phycst.done prtctl.done timing.done trd_oce.done trddyn.done + touch $(FCM_DONEDIR)/$@ + +dynldf.o: $(FCM_PPSRCDIR)/nemo/dynldf.f90 FFLAGS__nemo__dynldf.flags dom_oce.o dynldf_iso.o dynldf_lap_blp.o in_out_manager.o lbclnk.o ldfdyn.o lib_mpp.o oce.o phycst.o prtctl.o timing.o trd_oce.o trddyn.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynldf_iso.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynldf_iso.done: dynldf_iso.o dom_oce.done in_out_manager.done lbclnk.done ldfdyn.done ldfslp.done ldftra.done lib_mpp.done oce.done prtctl.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +dynldf_iso.o: $(FCM_PPSRCDIR)/nemo/dynldf_iso.f90 FFLAGS__nemo__dynldf_iso.flags dom_oce.o in_out_manager.o lbclnk.o ldfdyn.o ldfslp.o ldftra.o lib_mpp.o oce.o prtctl.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynldf_iso_lf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynldf_iso_lf.done: dynldf_iso_lf.o dom_oce.done in_out_manager.done lbclnk.done ldfdyn.done ldfslp.done ldftra.done lib_mpp.done oce.done prtctl.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +dynldf_iso_lf.o: $(FCM_PPSRCDIR)/nemo/dynldf_iso_lf.f90 FFLAGS__nemo__dynldf_iso_lf.flags dom_oce.o in_out_manager.o lbclnk.o ldfdyn.o ldfslp.o ldftra.o lib_mpp.o oce.o prtctl.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynldf_lap_blp.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynldf_lap_blp.done: dynldf_lap_blp.o dom_oce.done domutl.done in_out_manager.done lbclnk.done ldfdyn.done ldfslp.done lib_mpp.done oce.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +dynldf_lap_blp.o: $(FCM_PPSRCDIR)/nemo/dynldf_lap_blp.f90 FFLAGS__nemo__dynldf_lap_blp.flags dom_oce.o domutl.o in_out_manager.o lbclnk.o ldfdyn.o ldfslp.o lib_mpp.o oce.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynldf_lap_blp_lf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynldf_lap_blp_lf.done: dynldf_lap_blp_lf.o dom_oce.done domutl.done in_out_manager.done ldfdyn.done ldfslp.done lib_mpp.done oce.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +dynldf_lap_blp_lf.o: $(FCM_PPSRCDIR)/nemo/dynldf_lap_blp_lf.f90 FFLAGS__nemo__dynldf_lap_blp_lf.flags dom_oce.o domutl.o in_out_manager.o ldfdyn.o ldfslp.o lib_mpp.o oce.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynspg.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynspg.done: dynspg.o c1d.done dom_oce.done dynspg_exp.done dynspg_ts.done in_out_manager.done lib_mpp.done oce.done phycst.done prtctl.done sbc_ice.done sbc_oce.done sbcapr.done sbcwave.done tide_mod.done timing.done trd_oce.done trddyn.done + touch $(FCM_DONEDIR)/$@ + +dynspg.o: $(FCM_PPSRCDIR)/nemo/dynspg.f90 FFLAGS__nemo__dynspg.flags c1d.o dom_oce.o dynspg_exp.o dynspg_ts.o in_out_manager.o lib_mpp.o oce.o phycst.o prtctl.o sbc_ice.o sbc_oce.o sbcapr.o sbcwave.o tide_mod.o timing.o trd_oce.o trddyn.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynspg_exp.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynspg_exp.done: dynspg_exp.o dom_oce.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +dynspg_exp.o: $(FCM_PPSRCDIR)/nemo/dynspg_exp.f90 FFLAGS__nemo__dynspg_exp.flags dom_oce.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynspg_ts.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynspg_ts.done: dynspg_ts.o bdy_oce.done bdydyn2d.done bdytides.done bdyvol.done dom_oce.done dynadv.done dynvor.done in_out_manager.done iom.done isf_oce.done lbclnk.done lib_mpp.done oce.done phycst.done prtctl.done restart.done sbc_oce.done sbcapr.done sbcwave.done tide_mod.done wet_dry.done zdf_oce.done zdfdrg.done + touch $(FCM_DONEDIR)/$@ + +dynspg_ts.o: $(FCM_PPSRCDIR)/nemo/dynspg_ts.f90 FFLAGS__nemo__dynspg_ts.flags bdy_oce.o bdydyn2d.o bdytides.o bdyvol.o dom_oce.o dynadv.o dynvor.o in_out_manager.o iom.o isf_oce.o lbclnk.o lib_mpp.o oce.o phycst.o prtctl.o restart.o sbc_oce.o sbcapr.o sbcwave.o tide_mod.o wet_dry.o zdf_oce.o zdfdrg.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynvor.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynvor.done: dynvor.o dom_oce.done dommsk.done dynadv.done in_out_manager.done lbclnk.done lib_mpp.done oce.done prtctl.done sbc_oce.done sbcwave.done timing.done trd_oce.done trddyn.done + touch $(FCM_DONEDIR)/$@ + +dynvor.o: $(FCM_PPSRCDIR)/nemo/dynvor.f90 FFLAGS__nemo__dynvor.flags dom_oce.o dommsk.o dynadv.o in_out_manager.o lbclnk.o lib_mpp.o oce.o prtctl.o sbc_oce.o sbcwave.o timing.o trd_oce.o trddyn.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynzad.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynzad.done: dynzad.o dom_oce.done in_out_manager.done lib_mpp.done oce.done prtctl.done sbc_oce.done sbcwave.done timing.done trd_oce.done trddyn.done + touch $(FCM_DONEDIR)/$@ + +dynzad.o: $(FCM_PPSRCDIR)/nemo/dynzad.f90 FFLAGS__nemo__dynzad.flags dom_oce.o in_out_manager.o lib_mpp.o oce.o prtctl.o sbc_oce.o sbcwave.o timing.o trd_oce.o trddyn.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__dynzdf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +dynzdf.done: dynzdf.o dom_oce.done dynadv.done dynldf_iso.done in_out_manager.done ldfdyn.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done timing.done trd_oce.done trddyn.done zdf_oce.done zdfdrg.done + touch $(FCM_DONEDIR)/$@ + +dynzdf.o: $(FCM_PPSRCDIR)/nemo/dynzdf.f90 FFLAGS__nemo__dynzdf.flags dom_oce.o dynadv.o dynldf_iso.o in_out_manager.o ldfdyn.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o timing.o trd_oce.o trddyn.o zdf_oce.o zdfdrg.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__eosbn2.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +eosbn2.done: eosbn2.o dom_oce.done domutl.done in_out_manager.done lbclnk.done lib_fortran.done lib_mpp.done phycst.done prtctl.done stopar.done stopts.done timing.done + touch $(FCM_DONEDIR)/$@ + +eosbn2.o: $(FCM_PPSRCDIR)/nemo/eosbn2.f90 FFLAGS__nemo__eosbn2.flags dom_oce.o domutl.o in_out_manager.o lbclnk.o lib_fortran.o lib_mpp.o phycst.o prtctl.o stopar.o stopts.o timing.o + fcm_internal compile:F nemo $< $@ + +find_obs_proc.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/find_obs_proc.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +find_obs_proc.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/find_obs_proc.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__fldread.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +fldread.done: fldread.o bdy_oce.done dom_oce.done geo2ocean.done in_out_manager.done ioipsl.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +fldread.o: $(FCM_PPSRCDIR)/nemo/fldread.f90 FFLAGS__nemo__fldread.flags bdy_oce.o dom_oce.o geo2ocean.o in_out_manager.o ioipsl.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__flo4rk.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +flo4rk.done: flo4rk.o dom_oce.done flo_oce.done in_out_manager.done oce.done + touch $(FCM_DONEDIR)/$@ + +flo4rk.o: $(FCM_PPSRCDIR)/nemo/flo4rk.f90 FFLAGS__nemo__flo4rk.flags dom_oce.o flo_oce.o in_out_manager.o oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__flo_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +flo_oce.done: flo_oce.o in_out_manager.done lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +flo_oce.o: $(FCM_PPSRCDIR)/nemo/flo_oce.f90 FFLAGS__nemo__flo_oce.flags in_out_manager.o lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__floats.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +floats.done: floats.o flo4rk.done flo_oce.done floblk.done flodom.done florst.done flowri.done in_out_manager.done lib_mpp.done oce.done timing.done + touch $(FCM_DONEDIR)/$@ + +floats.o: $(FCM_PPSRCDIR)/nemo/floats.f90 FFLAGS__nemo__floats.flags flo4rk.o flo_oce.o floblk.o flodom.o florst.o flowri.o in_out_manager.o lib_mpp.o oce.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__floblk.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +floblk.done: floblk.o dom_oce.done flo_oce.done in_out_manager.done lib_mpp.done oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +floblk.o: $(FCM_PPSRCDIR)/nemo/floblk.f90 FFLAGS__nemo__floblk.flags dom_oce.o flo_oce.o in_out_manager.o lib_mpp.o oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__flodom.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +flodom.done: flodom.o dom_oce.done flo_oce.done in_out_manager.done lib_mpp.done oce.done + touch $(FCM_DONEDIR)/$@ + +flodom.o: $(FCM_PPSRCDIR)/nemo/flodom.f90 FFLAGS__nemo__flodom.flags dom_oce.o flo_oce.o in_out_manager.o lib_mpp.o oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__florst.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +florst.done: florst.o dom_oce.done flo_oce.done in_out_manager.done lib_mpp.done + touch $(FCM_DONEDIR)/$@ + +florst.o: $(FCM_PPSRCDIR)/nemo/florst.f90 FFLAGS__nemo__florst.flags dom_oce.o flo_oce.o in_out_manager.o lib_mpp.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__flowri.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +flowri.done: flowri.o dianam.done dom_oce.done flo_oce.done in_out_manager.done ioipsl.done iom.done lib_mpp.done oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +flowri.o: $(FCM_PPSRCDIR)/nemo/flowri.f90 FFLAGS__nemo__flowri.flags dianam.o dom_oce.o flo_oce.o in_out_manager.o ioipsl.o iom.o lib_mpp.o oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__geo2ocean.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +geo2ocean.done: geo2ocean.o dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done phycst.done + touch $(FCM_DONEDIR)/$@ + +geo2ocean.o: $(FCM_PPSRCDIR)/nemo/geo2ocean.f90 FFLAGS__nemo__geo2ocean.flags dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o phycst.o + fcm_internal compile:F nemo $< $@ + +greg2jul.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/greg2jul.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +greg2jul.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/greg2jul.h90 + touch $(FCM_DONEDIR)/$@ + +grt_cir_dis.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/grt_cir_dis.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +grt_cir_dis.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/grt_cir_dis.h90 + touch $(FCM_DONEDIR)/$@ + +grt_cir_dis_saa.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/grt_cir_dis_saa.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +grt_cir_dis_saa.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/grt_cir_dis_saa.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__halo_mng.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +halo_mng.done: halo_mng.o dom_oce.done lbclnk.done + touch $(FCM_DONEDIR)/$@ + +halo_mng.o: $(FCM_PPSRCDIR)/nemo/halo_mng.f90 FFLAGS__nemo__halo_mng.flags dom_oce.o lbclnk.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__icb_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +icb_oce.done: icb_oce.o lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +icb_oce.o: $(FCM_PPSRCDIR)/nemo/icb_oce.f90 FFLAGS__nemo__icb_oce.flags lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__icbclv.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +icbclv.done: icbclv.o dom_oce.done icb_oce.done icbdia.done icbutl.done lbclnk.done lib_mpp.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +icbclv.o: $(FCM_PPSRCDIR)/nemo/icbclv.f90 FFLAGS__nemo__icbclv.flags dom_oce.o icb_oce.o icbdia.o icbutl.o lbclnk.o lib_mpp.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__icbdia.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +icbdia.done: icbdia.o dom_oce.done icb_oce.done icbutl.done in_out_manager.done iom.done lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +icbdia.o: $(FCM_PPSRCDIR)/nemo/icbdia.f90 FFLAGS__nemo__icbdia.flags dom_oce.o icb_oce.o icbutl.o in_out_manager.o iom.o lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__icbdyn.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +icbdyn.done: icbdyn.o dom_oce.done icb_oce.done icbdia.done icbutl.done in_out_manager.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +icbdyn.o: $(FCM_PPSRCDIR)/nemo/icbdyn.f90 FFLAGS__nemo__icbdyn.flags dom_oce.o icb_oce.o icbdia.o icbutl.o in_out_manager.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__icbini.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +icbini.done: icbini.o dom_oce.done fldread.done icb_oce.done icbdia.done icbrst.done icbtrj.done icbutl.done in_out_manager.done iom.done lbclnk.done lib_mpp.done sbc_ice.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +icbini.o: $(FCM_PPSRCDIR)/nemo/icbini.f90 FFLAGS__nemo__icbini.flags dom_oce.o fldread.o icb_oce.o icbdia.o icbrst.o icbtrj.o icbutl.o in_out_manager.o iom.o lbclnk.o lib_mpp.o sbc_ice.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__icblbc.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +icblbc.done: icblbc.o dom_oce.done icb_oce.done icbutl.done in_out_manager.done lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +icblbc.o: $(FCM_PPSRCDIR)/nemo/icblbc.f90 FFLAGS__nemo__icblbc.flags dom_oce.o icb_oce.o icbutl.o in_out_manager.o lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__icbrst.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +icbrst.done: icbrst.o dom_oce.done icb_oce.done icbutl.done in_out_manager.done iom.done lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +icbrst.o: $(FCM_PPSRCDIR)/nemo/icbrst.f90 FFLAGS__nemo__icbrst.flags dom_oce.o icb_oce.o icbutl.o in_out_manager.o iom.o lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__icbstp.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +icbstp.done: icbstp.o dom_oce.done fldread.done icb_oce.done icbclv.done icbdia.done icbdyn.done icbini.done icblbc.done icbrst.done icbthm.done icbtrj.done icbutl.done in_out_manager.done iom.done lib_mpp.done par_oce.done phycst.done sbc_oce.done timing.done + touch $(FCM_DONEDIR)/$@ + +icbstp.o: $(FCM_PPSRCDIR)/nemo/icbstp.f90 FFLAGS__nemo__icbstp.flags dom_oce.o fldread.o icb_oce.o icbclv.o icbdia.o icbdyn.o icbini.o icblbc.o icbrst.o icbthm.o icbtrj.o icbutl.o in_out_manager.o iom.o lib_mpp.o par_oce.o phycst.o sbc_oce.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__icbthm.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +icbthm.done: icbthm.o dom_oce.done eosbn2.done icb_oce.done icbdia.done icbutl.done in_out_manager.done lib_fortran.done lib_mpp.done par_oce.done phycst.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +icbthm.o: $(FCM_PPSRCDIR)/nemo/icbthm.f90 FFLAGS__nemo__icbthm.flags dom_oce.o eosbn2.o icb_oce.o icbdia.o icbutl.o in_out_manager.o lib_fortran.o lib_mpp.o par_oce.o phycst.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__icbtrj.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +icbtrj.done: icbtrj.o dom_oce.done icb_oce.done icbutl.done in_out_manager.done ioipsl.done lib_mpp.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +icbtrj.o: $(FCM_PPSRCDIR)/nemo/icbtrj.f90 FFLAGS__nemo__icbtrj.flags dom_oce.o icb_oce.o icbutl.o in_out_manager.o ioipsl.o lib_mpp.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__icbutl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +icbutl.done: icbutl.o dom_oce.done icb_oce.done in_out_manager.done lbclnk.done lib_mpp.done oce.done par_oce.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +icbutl.o: $(FCM_PPSRCDIR)/nemo/icbutl.f90 FFLAGS__nemo__icbutl.flags dom_oce.o icb_oce.o in_out_manager.o lbclnk.o lib_mpp.o oce.o par_oce.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__in_out_manager.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +in_out_manager.done: in_out_manager.o nc4interface.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +in_out_manager.o: $(FCM_PPSRCDIR)/nemo/in_out_manager.f90 FFLAGS__nemo__in_out_manager.flags nc4interface.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__iom.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +iom.done: iom.o crs.done dianam.done diu_bulk.done dom_oce.done domutl.done flo_oce.done icb_oce.done in_out_manager.done ioipsl.done iom_def.done iom_nf90.done lbclnk.done lib_fortran.done lib_mpp.done phycst.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +iom.o: $(FCM_PPSRCDIR)/nemo/iom.f90 FFLAGS__nemo__iom.flags crs.o dianam.o diu_bulk.o dom_oce.o domutl.o flo_oce.o icb_oce.o in_out_manager.o ioipsl.o iom_def.o iom_nf90.o lbclnk.o lib_fortran.o lib_mpp.o phycst.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__iom_def.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +iom_def.done: iom_def.o par_kind.done + touch $(FCM_DONEDIR)/$@ + +iom_def.o: $(FCM_PPSRCDIR)/nemo/iom_def.f90 FFLAGS__nemo__iom_def.flags par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__iom_nf90.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +iom_nf90.done: iom_nf90.o dom_oce.done in_out_manager.done iom_def.done lbclnk.done lib_mpp.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +iom_nf90.o: $(FCM_PPSRCDIR)/nemo/iom_nf90.f90 FFLAGS__nemo__iom_nf90.flags dom_oce.o in_out_manager.o iom_def.o lbclnk.o lib_mpp.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isf_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isf_oce.done: isf_oce.o fldread.done in_out_manager.done lib_mpp.done par_kind.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +isf_oce.o: $(FCM_PPSRCDIR)/nemo/isf_oce.f90 FFLAGS__nemo__isf_oce.flags fldread.o in_out_manager.o lib_mpp.o par_kind.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfcav.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfcav.done: isfcav.o dom_oce.done eosbn2.done fldread.done in_out_manager.done iom.done isf_oce.done isfcavgam.done isfcavmlt.done isfdiags.done isfrst.done isftbl.done isfutils.done lbclnk.done lib_mpp.done oce.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +isfcav.o: $(FCM_PPSRCDIR)/nemo/isfcav.f90 FFLAGS__nemo__isfcav.flags dom_oce.o eosbn2.o fldread.o in_out_manager.o iom.o isf_oce.o isfcavgam.o isfcavmlt.o isfdiags.o isfrst.o isftbl.o isfutils.o lbclnk.o lib_mpp.o oce.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfcavgam.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfcavgam.done: isfcavgam.o dom_oce.done eosbn2.done in_out_manager.done iom.done isf_oce.done isftbl.done isfutils.done lib_mpp.done oce.done phycst.done zdfdrg.done + touch $(FCM_DONEDIR)/$@ + +isfcavgam.o: $(FCM_PPSRCDIR)/nemo/isfcavgam.f90 FFLAGS__nemo__isfcavgam.flags dom_oce.o eosbn2.o in_out_manager.o iom.o isf_oce.o isftbl.o isfutils.o lib_mpp.o oce.o phycst.o zdfdrg.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfcavmlt.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfcavmlt.done: isfcavmlt.o dom_oce.done eosbn2.done fldread.done in_out_manager.done iom.done isf_oce.done isftbl.done isfutils.done lib_fortran.done lib_mpp.done phycst.done + touch $(FCM_DONEDIR)/$@ + +isfcavmlt.o: $(FCM_PPSRCDIR)/nemo/isfcavmlt.f90 FFLAGS__nemo__isfcavmlt.flags dom_oce.o eosbn2.o fldread.o in_out_manager.o iom.o isf_oce.o isftbl.o isfutils.o lib_fortran.o lib_mpp.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfcpl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfcpl.done: isfcpl.o domqco.done domutl.done in_out_manager.done iom.done isf_oce.done isfutils.done lib_mpp.done oce.done + touch $(FCM_DONEDIR)/$@ + +isfcpl.o: $(FCM_PPSRCDIR)/nemo/isfcpl.f90 FFLAGS__nemo__isfcpl.flags domqco.o domutl.o in_out_manager.o iom.o isf_oce.o isfutils.o lib_mpp.o oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfdiags.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfdiags.done: isfdiags.o dom_oce.done in_out_manager.done iom.done isf_oce.done + touch $(FCM_DONEDIR)/$@ + +isfdiags.o: $(FCM_PPSRCDIR)/nemo/isfdiags.f90 FFLAGS__nemo__isfdiags.flags dom_oce.o in_out_manager.o iom.o isf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfdynatf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfdynatf.done: isfdynatf.o dom_oce.done in_out_manager.done isf_oce.done oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +isfdynatf.o: $(FCM_PPSRCDIR)/nemo/isfdynatf.f90 FFLAGS__nemo__isfdynatf.flags dom_oce.o in_out_manager.o isf_oce.o oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfhdiv.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfhdiv.done: isfhdiv.o dom_oce.done in_out_manager.done isf_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +isfhdiv.o: $(FCM_PPSRCDIR)/nemo/isfhdiv.f90 FFLAGS__nemo__isfhdiv.flags dom_oce.o in_out_manager.o isf_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfload.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfload.done: isfload.o dom_oce.done eosbn2.done in_out_manager.done isf_oce.done lib_mpp.done + touch $(FCM_DONEDIR)/$@ + +isfload.o: $(FCM_PPSRCDIR)/nemo/isfload.f90 FFLAGS__nemo__isfload.flags dom_oce.o eosbn2.o in_out_manager.o isf_oce.o lib_mpp.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfpar.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfpar.done: isfpar.o dom_oce.done fldread.done in_out_manager.done iom.done isf_oce.done isfdiags.done isfparmlt.done isfrst.done isftbl.done isfutils.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +isfpar.o: $(FCM_PPSRCDIR)/nemo/isfpar.f90 FFLAGS__nemo__isfpar.flags dom_oce.o fldread.o in_out_manager.o iom.o isf_oce.o isfdiags.o isfparmlt.o isfrst.o isftbl.o isfutils.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfparmlt.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfparmlt.done: isfparmlt.o dom_oce.done eosbn2.done fldread.done in_out_manager.done iom.done isf_oce.done isftbl.done isfutils.done lib_fortran.done lib_mpp.done oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +isfparmlt.o: $(FCM_PPSRCDIR)/nemo/isfparmlt.f90 FFLAGS__nemo__isfparmlt.flags dom_oce.o eosbn2.o fldread.o in_out_manager.o iom.o isf_oce.o isftbl.o isfutils.o lib_fortran.o lib_mpp.o oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfrst.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfrst.done: isfrst.o in_out_manager.done iom.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +isfrst.o: $(FCM_PPSRCDIR)/nemo/isfrst.f90 FFLAGS__nemo__isfrst.flags in_out_manager.o iom.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfstp.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfstp.done: isfstp.o dom_oce.done domvvl.done fldread.done in_out_manager.done isf_oce.done isfcav.done isfcpl.done isfload.done isfpar.done isftbl.done lib_mpp.done oce.done timing.done zdfdrg.done + touch $(FCM_DONEDIR)/$@ + +isfstp.o: $(FCM_PPSRCDIR)/nemo/isfstp.f90 FFLAGS__nemo__isfstp.flags dom_oce.o domvvl.o fldread.o in_out_manager.o isf_oce.o isfcav.o isfcpl.o isfload.o isfpar.o isftbl.o lib_mpp.o oce.o timing.o zdfdrg.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isftbl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isftbl.done: isftbl.o dom_oce.done isf_oce.done + touch $(FCM_DONEDIR)/$@ + +isftbl.o: $(FCM_PPSRCDIR)/nemo/isftbl.f90 FFLAGS__nemo__isftbl.flags dom_oce.o isf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__isfutils.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +isfutils.done: isfutils.o dom_oce.done in_out_manager.done iom.done lib_fortran.done lib_mpp.done par_kind.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +isfutils.o: $(FCM_PPSRCDIR)/nemo/isfutils.f90 FFLAGS__nemo__isfutils.flags dom_oce.o in_out_manager.o iom.o lib_fortran.o lib_mpp.o par_kind.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__istate.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +istate.done: istate.o daymod.done dom_oce.done domvvl.done dtatsd.done dtauvd.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done restart.done usrdef_istate.done wet_dry.done + touch $(FCM_DONEDIR)/$@ + +istate.o: $(FCM_PPSRCDIR)/nemo/istate.f90 FFLAGS__nemo__istate.flags daymod.o dom_oce.o domvvl.o dtatsd.o dtauvd.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o restart.o usrdef_istate.o wet_dry.o + fcm_internal compile:F nemo $< $@ + +jul2greg.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/jul2greg.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +jul2greg.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/jul2greg.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__julian.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +julian.done: julian.o lib_mpp.done par_kind.done + touch $(FCM_DONEDIR)/$@ + +julian.o: $(FCM_PPSRCDIR)/nemo/julian.f90 FFLAGS__nemo__julian.flags lib_mpp.o par_kind.o + fcm_internal compile:F nemo $< $@ + +lbc_lnk_call_generic.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lbc_lnk_call_generic.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +lbc_lnk_call_generic.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lbc_lnk_call_generic.h90 + touch $(FCM_DONEDIR)/$@ + +lbc_lnk_neicoll_generic.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lbc_lnk_neicoll_generic.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +lbc_lnk_neicoll_generic.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lbc_lnk_neicoll_generic.h90 + touch $(FCM_DONEDIR)/$@ + +lbc_lnk_pt2pt_generic.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lbc_lnk_pt2pt_generic.h90 lbc_lnk_pt2pt_generic.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +lbc_lnk_pt2pt_generic.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lbc_lnk_pt2pt_generic.h90 lbc_lnk_pt2pt_generic.h90.idone + touch $(FCM_DONEDIR)/$@ + +lbc_nfd_ext_generic.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lbc_nfd_ext_generic.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +lbc_nfd_ext_generic.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lbc_nfd_ext_generic.h90 + touch $(FCM_DONEDIR)/$@ + +lbc_nfd_generic.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lbc_nfd_generic.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +lbc_nfd_generic.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lbc_nfd_generic.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__lbclnk.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +lbclnk.done: lbclnk.o dom_oce.done in_out_manager.done lbcnfd.done lib_mpp.done + touch $(FCM_DONEDIR)/$@ + +lbclnk.o: $(FCM_PPSRCDIR)/nemo/lbclnk.f90 FFLAGS__nemo__lbclnk.flags dom_oce.o in_out_manager.o lbcnfd.o lib_mpp.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__lbcnfd.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +lbcnfd.done: lbcnfd.o dom_oce.done in_out_manager.done lib_mpp.done + touch $(FCM_DONEDIR)/$@ + +lbcnfd.o: $(FCM_PPSRCDIR)/nemo/lbcnfd.f90 FFLAGS__nemo__lbcnfd.flags dom_oce.o in_out_manager.o lib_mpp.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__ldfc1d_c2d.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +ldfc1d_c2d.done: ldfc1d_c2d.o dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +ldfc1d_c2d.o: $(FCM_PPSRCDIR)/nemo/ldfc1d_c2d.f90 FFLAGS__nemo__ldfc1d_c2d.flags dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__ldfdyn.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +ldfdyn.done: ldfdyn.o dom_oce.done in_out_manager.done iom.done lbclnk.done ldfc1d_c2d.done ldfslp.done lib_mpp.done oce.done phycst.done timing.done + touch $(FCM_DONEDIR)/$@ + +ldfdyn.o: $(FCM_PPSRCDIR)/nemo/ldfdyn.f90 FFLAGS__nemo__ldfdyn.flags dom_oce.o in_out_manager.o iom.o lbclnk.o ldfc1d_c2d.o ldfslp.o lib_mpp.o oce.o phycst.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__ldfslp.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +ldfslp.done: ldfslp.o dom_oce.done eosbn2.done in_out_manager.done isf_oce.done lbclnk.done lib_fortran.done lib_mpp.done oce.done phycst.done prtctl.done timing.done zdfmxl.done + touch $(FCM_DONEDIR)/$@ + +ldfslp.o: $(FCM_PPSRCDIR)/nemo/ldfslp.f90 FFLAGS__nemo__ldfslp.flags dom_oce.o eosbn2.o in_out_manager.o isf_oce.o lbclnk.o lib_fortran.o lib_mpp.o oce.o phycst.o prtctl.o timing.o zdfmxl.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__ldftra.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +ldftra.done: ldftra.o diaptr.done dom_oce.done in_out_manager.done iom.done lbclnk.done ldfc1d_c2d.done ldfslp.done lib_mpp.done oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +ldftra.o: $(FCM_PPSRCDIR)/nemo/ldftra.f90 FFLAGS__nemo__ldftra.flags diaptr.o dom_oce.o in_out_manager.o iom.o lbclnk.o ldfc1d_c2d.o ldfslp.o lib_mpp.o oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__lib_cray.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +lib_cray.done: lib_cray.o + touch $(FCM_DONEDIR)/$@ + +lib_cray.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lib_cray.f90 FFLAGS__nemo__lib_cray.flags + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__lib_fortran.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +lib_fortran.done: lib_fortran.o dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +lib_fortran.o: $(FCM_PPSRCDIR)/nemo/lib_fortran.f90 FFLAGS__nemo__lib_fortran.flags dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +lib_fortran_generic.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lib_fortran_generic.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +lib_fortran_generic.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/lib_fortran_generic.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__lib_mpp.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +lib_mpp.done: lib_mpp.o dom_oce.done in_out_manager.done + touch $(FCM_DONEDIR)/$@ + +lib_mpp.o: $(FCM_PPSRCDIR)/nemo/lib_mpp.f90 FFLAGS__nemo__lib_mpp.flags dom_oce.o in_out_manager.o + fcm_internal compile:F nemo $< $@ + +linquad.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/linquad.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +linquad.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/linquad.h90 + touch $(FCM_DONEDIR)/$@ + +maxdist.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/maxdist.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +maxdist.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/maxdist.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__module_example.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +exampl.done: exampl.o + touch $(FCM_DONEDIR)/$@ + +exampl.o: $(FCM_PPSRCDIR)/nemo/module_example.f90 FFLAGS__nemo__module_example.flags + fcm_internal compile:F nemo $< $@ + +mpp_allreduce_generic.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/mpp_allreduce_generic.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +mpp_allreduce_generic.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/mpp_allreduce_generic.h90 + touch $(FCM_DONEDIR)/$@ + +mpp_lbc_north_icb_generic.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/mpp_lbc_north_icb_generic.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +mpp_lbc_north_icb_generic.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/mpp_lbc_north_icb_generic.h90 + touch $(FCM_DONEDIR)/$@ + +mpp_lnk_icb_generic.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/mpp_lnk_icb_generic.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +mpp_lnk_icb_generic.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/mpp_lnk_icb_generic.h90 + touch $(FCM_DONEDIR)/$@ + +mpp_loc_generic.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/mpp_loc_generic.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +mpp_loc_generic.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/mpp_loc_generic.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__mpp_map.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +mpp_map.done: mpp_map.o dom_oce.done in_out_manager.done lib_mpp.done par_kind.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +mpp_map.o: $(FCM_PPSRCDIR)/nemo/mpp_map.f90 FFLAGS__nemo__mpp_map.flags dom_oce.o in_out_manager.o lib_mpp.o par_kind.o par_oce.o + fcm_internal compile:F nemo $< $@ + +mpp_nfd_generic.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/mpp_nfd_generic.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +mpp_nfd_generic.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/mpp_nfd_generic.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__mppini.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +mppini.done: mppini.o bdy_oce.done dom_oce.done in_out_manager.done ioipsl.done iom.done lbcnfd.done lib_mpp.done + touch $(FCM_DONEDIR)/$@ + +mppini.o: $(FCM_PPSRCDIR)/nemo/mppini.f90 FFLAGS__nemo__mppini.flags bdy_oce.o dom_oce.o in_out_manager.o ioipsl.o iom.o lbcnfd.o lib_mpp.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__nemo.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +LDFLAGS__nemo__nemo.flags: LDFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +LD__nemo__nemo.flags: LD__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +nemo.exe: nemo.o LD__nemo__nemo.flags LDFLAGS__nemo__nemo.flags $(OBJECTS) nemogcm.done + fcm_internal load:F nemo $< $@ + +nemo.o: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/nemo.f90 FFLAGS__nemo__nemo.flags nemogcm.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__nemogcm.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +nemogcm.done: nemogcm.o bdy_oce.done bdyini.done c1d.done cpl_oasis3.done crsini.done dia25h.done diawri.done dom_oce.done domain.done dyndmp.done halo_mng.done icbini.done icbstp.done istate.done lib_fortran.done lib_mpp.done mppini.done phycst.done step_diu.done step_oce.done stpmlf.done tide_mod.done trc_oce.done trdini.done usrdef_nam.done wet_dry.done + touch $(FCM_DONEDIR)/$@ + +nemogcm.o: $(FCM_PPSRCDIR)/nemo/nemogcm.f90 FFLAGS__nemo__nemogcm.flags bdy_oce.o bdyini.o c1d.o cpl_oasis3.o crsini.o dia25h.o diawri.o dom_oce.o domain.o dyndmp.o halo_mng.o icbini.o icbstp.o istate.o lib_fortran.o lib_mpp.o mppini.o phycst.o step_diu.o step_oce.o stpmlf.o tide_mod.o trc_oce.o trdini.o usrdef_nam.o wet_dry.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_averg_h2d.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_averg_h2d.done: obs_averg_h2d.o dom_oce.done in_out_manager.done lib_mpp.done obs_const.done obs_utils.done par_kind.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +obs_averg_h2d.o: $(FCM_PPSRCDIR)/nemo/obs_averg_h2d.f90 FFLAGS__nemo__obs_averg_h2d.flags dom_oce.o in_out_manager.o lib_mpp.o obs_const.o obs_utils.o par_kind.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_const.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_const.done: obs_const.o par_kind.done + touch $(FCM_DONEDIR)/$@ + +obs_const.o: $(FCM_PPSRCDIR)/nemo/obs_const.f90 FFLAGS__nemo__obs_const.flags par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_conv.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_conv.done: obs_conv.o par_kind.done + touch $(FCM_DONEDIR)/$@ + +obs_conv.o: $(FCM_PPSRCDIR)/nemo/obs_conv.f90 FFLAGS__nemo__obs_conv.flags par_kind.o + fcm_internal compile:F nemo $< $@ + +obs_conv_functions.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/obs_conv_functions.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +obs_conv_functions.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/obs_conv_functions.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__obs_fbm.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_fbm.done: obs_fbm.o obs_utils.done + touch $(FCM_DONEDIR)/$@ + +obs_fbm.o: $(FCM_PPSRCDIR)/nemo/obs_fbm.f90 FFLAGS__nemo__obs_fbm.flags obs_utils.o + fcm_internal compile:F nemo $< $@ + +obs_grd_bruteforce.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/obs_grd_bruteforce.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +obs_grd_bruteforce.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/obs_grd_bruteforce.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__obs_grid.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_grid.done: obs_grid.o dom_oce.done in_out_manager.done lib_mpp.done obs_const.done obs_mpp.done obs_utils.done par_kind.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +obs_grid.o: $(FCM_PPSRCDIR)/nemo/obs_grid.f90 FFLAGS__nemo__obs_grid.flags dom_oce.o in_out_manager.o lib_mpp.o obs_const.o obs_mpp.o obs_utils.o par_kind.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_inter_h2d.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_inter_h2d.done: obs_inter_h2d.o in_out_manager.done lib_mpp.done obs_const.done obs_utils.done par_kind.done phycst.done + touch $(FCM_DONEDIR)/$@ + +obs_inter_h2d.o: $(FCM_PPSRCDIR)/nemo/obs_inter_h2d.f90 FFLAGS__nemo__obs_inter_h2d.flags in_out_manager.o lib_mpp.o obs_const.o obs_utils.o par_kind.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_inter_sup.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_inter_sup.done: obs_inter_sup.o dom_oce.done in_out_manager.done lib_mpp.done mpp_map.done obs_grid.done obs_mpp.done par_kind.done + touch $(FCM_DONEDIR)/$@ + +obs_inter_sup.o: $(FCM_PPSRCDIR)/nemo/obs_inter_sup.f90 FFLAGS__nemo__obs_inter_sup.flags dom_oce.o in_out_manager.o lib_mpp.o mpp_map.o obs_grid.o obs_mpp.o par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_inter_z1d.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_inter_z1d.done: obs_inter_z1d.o par_kind.done + touch $(FCM_DONEDIR)/$@ + +obs_inter_z1d.o: $(FCM_PPSRCDIR)/nemo/obs_inter_z1d.f90 FFLAGS__nemo__obs_inter_z1d.flags par_kind.o + fcm_internal compile:F nemo $< $@ + +obs_level_search.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/obs_level_search.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +obs_level_search.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/obs_level_search.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__obs_mpp.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_mpp.done: obs_mpp.o in_out_manager.done lib_mpp.done mpp_map.done + touch $(FCM_DONEDIR)/$@ + +obs_mpp.o: $(FCM_PPSRCDIR)/nemo/obs_mpp.f90 FFLAGS__nemo__obs_mpp.flags in_out_manager.o lib_mpp.o mpp_map.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_oper.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_oper.done: obs_oper.o dom_oce.done in_out_manager.done lib_mpp.done obs_averg_h2d.done obs_const.done obs_grid.done obs_inter_h2d.done obs_inter_sup.done obs_inter_z1d.done obs_profiles_def.done obs_surf_def.done par_kind.done sbcdcy.done + touch $(FCM_DONEDIR)/$@ + +obs_oper.o: $(FCM_PPSRCDIR)/nemo/obs_oper.f90 FFLAGS__nemo__obs_oper.flags dom_oce.o in_out_manager.o lib_mpp.o obs_averg_h2d.o obs_const.o obs_grid.o obs_inter_h2d.o obs_inter_sup.o obs_inter_z1d.o obs_profiles_def.o obs_surf_def.o par_kind.o sbcdcy.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_prep.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_prep.done: obs_prep.o bdy_oce.done dom_oce.done in_out_manager.done lib_mpp.done obs_inter_sup.done obs_mpp.done obs_oper.done obs_profiles_def.done obs_surf_def.done par_kind.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +obs_prep.o: $(FCM_PPSRCDIR)/nemo/obs_prep.f90 FFLAGS__nemo__obs_prep.flags bdy_oce.o dom_oce.o in_out_manager.o lib_mpp.o obs_inter_sup.o obs_mpp.o obs_oper.o obs_profiles_def.o obs_surf_def.o par_kind.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_profiles.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_profiles.done: obs_profiles.o obs_profiles_def.done + touch $(FCM_DONEDIR)/$@ + +obs_profiles.o: $(FCM_PPSRCDIR)/nemo/obs_profiles.f90 FFLAGS__nemo__obs_profiles.flags obs_profiles_def.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_profiles_def.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_profiles_def.done: obs_profiles_def.o in_out_manager.done lib_mpp.done obs_fbm.done obs_mpp.done par_kind.done + touch $(FCM_DONEDIR)/$@ + +obs_profiles_def.o: $(FCM_PPSRCDIR)/nemo/obs_profiles_def.f90 FFLAGS__nemo__obs_profiles_def.flags in_out_manager.o lib_mpp.o obs_fbm.o obs_mpp.o par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_read_altbias.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_read_altbias.done: obs_read_altbias.o dom_oce.done in_out_manager.done iom.done obs_inter_h2d.done obs_inter_sup.done obs_surf_def.done obs_utils.done oce.done par_kind.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +obs_read_altbias.o: $(FCM_PPSRCDIR)/nemo/obs_read_altbias.f90 FFLAGS__nemo__obs_read_altbias.flags dom_oce.o in_out_manager.o iom.o obs_inter_h2d.o obs_inter_sup.o obs_surf_def.o obs_utils.o oce.o par_kind.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_read_prof.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_read_prof.done: obs_read_prof.o dom_oce.done in_out_manager.done julian.done lib_mpp.done obs_conv.done obs_fbm.done obs_grid.done obs_mpp.done obs_oper.done obs_prep.done obs_profiles_def.done obs_sort.done obs_types.done obs_utils.done par_kind.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +obs_read_prof.o: $(FCM_PPSRCDIR)/nemo/obs_read_prof.f90 FFLAGS__nemo__obs_read_prof.flags dom_oce.o in_out_manager.o julian.o lib_mpp.o obs_conv.o obs_fbm.o obs_grid.o obs_mpp.o obs_oper.o obs_prep.o obs_profiles_def.o obs_sort.o obs_types.o obs_utils.o par_kind.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_read_surf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_read_surf.done: obs_read_surf.o dom_oce.done in_out_manager.done julian.done obs_fbm.done obs_grid.done obs_mpp.done obs_sort.done obs_surf_def.done obs_types.done obs_utils.done par_kind.done + touch $(FCM_DONEDIR)/$@ + +obs_read_surf.o: $(FCM_PPSRCDIR)/nemo/obs_read_surf.f90 FFLAGS__nemo__obs_read_surf.flags dom_oce.o in_out_manager.o julian.o obs_fbm.o obs_grid.o obs_mpp.o obs_sort.o obs_surf_def.o obs_types.o obs_utils.o par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_readmdt.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_readmdt.done: obs_readmdt.o dom_oce.done in_out_manager.done iom.done iom_nf90.done lib_mpp.done obs_const.done obs_inter_h2d.done obs_inter_sup.done obs_surf_def.done obs_utils.done oce.done par_kind.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +obs_readmdt.o: $(FCM_PPSRCDIR)/nemo/obs_readmdt.f90 FFLAGS__nemo__obs_readmdt.flags dom_oce.o in_out_manager.o iom.o iom_nf90.o lib_mpp.o obs_const.o obs_inter_h2d.o obs_inter_sup.o obs_surf_def.o obs_utils.o oce.o par_kind.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_rot_vel.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_rot_vel.done: obs_rot_vel.o dom_oce.done geo2ocean.done in_out_manager.done obs_fbm.done obs_grid.done obs_inter_h2d.done obs_inter_sup.done obs_profiles_def.done obs_utils.done par_kind.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +obs_rot_vel.o: $(FCM_PPSRCDIR)/nemo/obs_rot_vel.f90 FFLAGS__nemo__obs_rot_vel.flags dom_oce.o geo2ocean.o in_out_manager.o obs_fbm.o obs_grid.o obs_inter_h2d.o obs_inter_sup.o obs_profiles_def.o obs_utils.o par_kind.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_sort.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_sort.done: obs_sort.o par_kind.done + touch $(FCM_DONEDIR)/$@ + +obs_sort.o: $(FCM_PPSRCDIR)/nemo/obs_sort.f90 FFLAGS__nemo__obs_sort.flags par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_sstbias.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_sstbias.done: obs_sstbias.o dom_oce.done in_out_manager.done iom.done obs_inter_h2d.done obs_inter_sup.done obs_surf_def.done obs_utils.done oce.done par_kind.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +obs_sstbias.o: $(FCM_PPSRCDIR)/nemo/obs_sstbias.f90 FFLAGS__nemo__obs_sstbias.flags dom_oce.o in_out_manager.o iom.o obs_inter_h2d.o obs_inter_sup.o obs_surf_def.o obs_utils.o oce.o par_kind.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_surf_def.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_surf_def.done: obs_surf_def.o obs_mpp.done par_kind.done + touch $(FCM_DONEDIR)/$@ + +obs_surf_def.o: $(FCM_PPSRCDIR)/nemo/obs_surf_def.f90 FFLAGS__nemo__obs_surf_def.flags obs_mpp.o par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_types.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_types.done: obs_types.o + touch $(FCM_DONEDIR)/$@ + +obs_types.o: $(FCM_PPSRCDIR)/nemo/obs_types.f90 FFLAGS__nemo__obs_types.flags + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_utils.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_utils.done: obs_utils.o in_out_manager.done lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +obs_utils.o: $(FCM_PPSRCDIR)/nemo/obs_utils.f90 FFLAGS__nemo__obs_utils.flags in_out_manager.o lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__obs_write.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +obs_write.done: obs_write.o dom_oce.done in_out_manager.done julian.done lib_mpp.done obs_const.done obs_conv.done obs_fbm.done obs_grid.done obs_mpp.done obs_profiles_def.done obs_surf_def.done obs_types.done obs_utils.done par_kind.done + touch $(FCM_DONEDIR)/$@ + +obs_write.o: $(FCM_PPSRCDIR)/nemo/obs_write.f90 FFLAGS__nemo__obs_write.flags dom_oce.o in_out_manager.o julian.o lib_mpp.o obs_const.o obs_conv.o obs_fbm.o obs_grid.o obs_mpp.o obs_profiles_def.o obs_surf_def.o obs_types.o obs_utils.o par_kind.o + fcm_internal compile:F nemo $< $@ + +obsinter_h2d.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/obsinter_h2d.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +obsinter_h2d.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/obsinter_h2d.h90 + touch $(FCM_DONEDIR)/$@ + +obsinter_z1d.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/obsinter_z1d.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +obsinter_z1d.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/obsinter_z1d.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +oce.done: oce.o lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +oce.o: $(FCM_PPSRCDIR)/nemo/oce.f90 FFLAGS__nemo__oce.flags lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__ocealb.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +ocealb.done: ocealb.o in_out_manager.done lib_fortran.done lib_mpp.done phycst.done + touch $(FCM_DONEDIR)/$@ + +ocealb.o: $(FCM_PPSRCDIR)/nemo/ocealb.f90 FFLAGS__nemo__ocealb.flags in_out_manager.o lib_fortran.o lib_mpp.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__par_kind.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +par_kind.done: par_kind.o + touch $(FCM_DONEDIR)/$@ + +par_kind.o: $(FCM_PPSRCDIR)/nemo/par_kind.f90 FFLAGS__nemo__par_kind.flags + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__par_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +par_oce.done: par_oce.o par_kind.done + touch $(FCM_DONEDIR)/$@ + +par_oce.o: $(FCM_PPSRCDIR)/nemo/par_oce.f90 FFLAGS__nemo__par_oce.flags par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__phycst.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +phycst.done: phycst.o in_out_manager.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +phycst.o: $(FCM_PPSRCDIR)/nemo/phycst.f90 FFLAGS__nemo__phycst.flags in_out_manager.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__prtctl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +prtctl.done: prtctl.o dom_oce.done domutl.done in_out_manager.done lib_mpp.done mppini.done + touch $(FCM_DONEDIR)/$@ + +prtctl.o: $(FCM_PPSRCDIR)/nemo/prtctl.f90 FFLAGS__nemo__prtctl.flags dom_oce.o domutl.o in_out_manager.o lib_mpp.o mppini.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__restart.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +restart.done: restart.o diu_bulk.done dom_oce.done eosbn2.done in_out_manager.done iom.done lib_mpp.done oce.done phycst.done sbc_ice.done trdmxl_oce.done usrdef_istate.done wet_dry.done + touch $(FCM_DONEDIR)/$@ + +restart.o: $(FCM_PPSRCDIR)/nemo/restart.f90 FFLAGS__nemo__restart.flags diu_bulk.o dom_oce.o eosbn2.o in_out_manager.o iom.o lib_mpp.o oce.o phycst.o sbc_ice.o trdmxl_oce.o usrdef_istate.o wet_dry.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbc_ice.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbc_ice.done: sbc_ice.o in_out_manager.done lib_mpp.done + touch $(FCM_DONEDIR)/$@ + +sbc_ice.o: $(FCM_PPSRCDIR)/nemo/sbc_ice.f90 FFLAGS__nemo__sbc_ice.flags in_out_manager.o lib_mpp.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbc_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbc_oce.done: sbc_oce.o dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +sbc_oce.o: $(FCM_PPSRCDIR)/nemo/sbc_oce.f90 FFLAGS__nemo__sbc_oce.flags dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbc_phy.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbc_phy.done: sbc_phy.o dom_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +sbc_phy.o: $(FCM_PPSRCDIR)/nemo/sbc_phy.f90 FFLAGS__nemo__sbc_phy.flags dom_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcabl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcabl.done: sbcabl.o lib_mpp.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +sbcabl.o: $(FCM_PPSRCDIR)/nemo/sbcabl.f90 FFLAGS__nemo__sbcabl.flags lib_mpp.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcapr.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcapr.done: sbcapr.o dom_oce.done fldread.done in_out_manager.done iom.done lib_fortran.done lib_mpp.done phycst.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +sbcapr.o: $(FCM_PPSRCDIR)/nemo/sbcapr.f90 FFLAGS__nemo__sbcapr.flags dom_oce.o fldread.o in_out_manager.o iom.o lib_fortran.o lib_mpp.o phycst.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk.done: sbcblk.o cyclone.done dom_oce.done fldread.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done sbc_phy.done sbcblk_algo_andreas.done sbcblk_algo_coare3p0.done sbcblk_algo_coare3p6.done sbcblk_algo_ecmwf.done sbcblk_algo_ncar.done sbcdcy.done sbcwave.done trc_oce.done + touch $(FCM_DONEDIR)/$@ + +sbcblk.o: $(FCM_PPSRCDIR)/nemo/sbcblk.f90 FFLAGS__nemo__sbcblk.flags cyclone.o dom_oce.o fldread.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o sbc_phy.o sbcblk_algo_andreas.o sbcblk_algo_coare3p0.o sbcblk_algo_coare3p6.o sbcblk_algo_ecmwf.o sbcblk_algo_ncar.o sbcdcy.o sbcwave.o trc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk_algo_andreas.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk_algo_andreas.done: sbcblk_algo_andreas.o dom_oce.done phycst.done sbc_phy.done + touch $(FCM_DONEDIR)/$@ + +sbcblk_algo_andreas.o: $(FCM_PPSRCDIR)/nemo/sbcblk_algo_andreas.f90 FFLAGS__nemo__sbcblk_algo_andreas.flags dom_oce.o phycst.o sbc_phy.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk_algo_coare3p0.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk_algo_coare3p0.done: sbcblk_algo_coare3p0.o dom_oce.done in_out_manager.done iom.done lib_fortran.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done sbc_phy.done sbcblk_skin_coare.done sbcwave.done + touch $(FCM_DONEDIR)/$@ + +sbcblk_algo_coare3p0.o: $(FCM_PPSRCDIR)/nemo/sbcblk_algo_coare3p0.f90 FFLAGS__nemo__sbcblk_algo_coare3p0.flags dom_oce.o in_out_manager.o iom.o lib_fortran.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o sbc_phy.o sbcblk_skin_coare.o sbcwave.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk_algo_coare3p6.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk_algo_coare3p6.done: sbcblk_algo_coare3p6.o dom_oce.done in_out_manager.done lib_mpp.done phycst.done sbc_phy.done sbcblk_skin_coare.done + touch $(FCM_DONEDIR)/$@ + +sbcblk_algo_coare3p6.o: $(FCM_PPSRCDIR)/nemo/sbcblk_algo_coare3p6.f90 FFLAGS__nemo__sbcblk_algo_coare3p6.flags dom_oce.o in_out_manager.o lib_mpp.o phycst.o sbc_phy.o sbcblk_skin_coare.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk_algo_ecmwf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk_algo_ecmwf.done: sbcblk_algo_ecmwf.o dom_oce.done in_out_manager.done lib_mpp.done phycst.done sbc_oce.done sbc_phy.done sbcblk_skin_ecmwf.done sbcwave.done + touch $(FCM_DONEDIR)/$@ + +sbcblk_algo_ecmwf.o: $(FCM_PPSRCDIR)/nemo/sbcblk_algo_ecmwf.f90 FFLAGS__nemo__sbcblk_algo_ecmwf.flags dom_oce.o in_out_manager.o lib_mpp.o phycst.o sbc_oce.o sbc_phy.o sbcblk_skin_ecmwf.o sbcwave.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk_algo_ice_an05.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk_algo_ice_an05.done: sbcblk_algo_ice_an05.o lib_mpp.done par_kind.done par_oce.done phycst.done sbc_phy.done + touch $(FCM_DONEDIR)/$@ + +sbcblk_algo_ice_an05.o: $(FCM_PPSRCDIR)/nemo/sbcblk_algo_ice_an05.f90 FFLAGS__nemo__sbcblk_algo_ice_an05.flags lib_mpp.o par_kind.o par_oce.o phycst.o sbc_phy.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk_algo_ice_cdn.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk_algo_ice_cdn.done: sbcblk_algo_ice_cdn.o par_kind.done par_oce.done phycst.done sbc_phy.done + touch $(FCM_DONEDIR)/$@ + +sbcblk_algo_ice_cdn.o: $(FCM_PPSRCDIR)/nemo/sbcblk_algo_ice_cdn.f90 FFLAGS__nemo__sbcblk_algo_ice_cdn.flags par_kind.o par_oce.o phycst.o sbc_phy.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk_algo_ice_lg15.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk_algo_ice_lg15.done: sbcblk_algo_ice_lg15.o par_kind.done par_oce.done phycst.done sbc_phy.done sbcblk_algo_ice_cdn.done + touch $(FCM_DONEDIR)/$@ + +sbcblk_algo_ice_lg15.o: $(FCM_PPSRCDIR)/nemo/sbcblk_algo_ice_lg15.f90 FFLAGS__nemo__sbcblk_algo_ice_lg15.flags par_kind.o par_oce.o phycst.o sbc_phy.o sbcblk_algo_ice_cdn.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk_algo_ice_lu12.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk_algo_ice_lu12.done: sbcblk_algo_ice_lu12.o par_kind.done par_oce.done phycst.done sbc_phy.done sbcblk_algo_ice_cdn.done + touch $(FCM_DONEDIR)/$@ + +sbcblk_algo_ice_lu12.o: $(FCM_PPSRCDIR)/nemo/sbcblk_algo_ice_lu12.f90 FFLAGS__nemo__sbcblk_algo_ice_lu12.flags par_kind.o par_oce.o phycst.o sbc_phy.o sbcblk_algo_ice_cdn.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk_algo_ncar.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk_algo_ncar.done: sbcblk_algo_ncar.o dom_oce.done phycst.done sbc_oce.done sbc_phy.done sbcwave.done + touch $(FCM_DONEDIR)/$@ + +sbcblk_algo_ncar.o: $(FCM_PPSRCDIR)/nemo/sbcblk_algo_ncar.f90 FFLAGS__nemo__sbcblk_algo_ncar.flags dom_oce.o phycst.o sbc_oce.o sbc_phy.o sbcwave.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk_skin_coare.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk_skin_coare.done: sbcblk_skin_coare.o dom_oce.done in_out_manager.done lib_fortran.done lib_mpp.done oce.done phycst.done sbc_oce.done sbc_phy.done sbcdcy.done + touch $(FCM_DONEDIR)/$@ + +sbcblk_skin_coare.o: $(FCM_PPSRCDIR)/nemo/sbcblk_skin_coare.f90 FFLAGS__nemo__sbcblk_skin_coare.flags dom_oce.o in_out_manager.o lib_fortran.o lib_mpp.o oce.o phycst.o sbc_oce.o sbc_phy.o sbcdcy.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcblk_skin_ecmwf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcblk_skin_ecmwf.done: sbcblk_skin_ecmwf.o dom_oce.done in_out_manager.done lib_fortran.done lib_mpp.done oce.done phycst.done sbc_oce.done sbc_phy.done + touch $(FCM_DONEDIR)/$@ + +sbcblk_skin_ecmwf.o: $(FCM_PPSRCDIR)/nemo/sbcblk_skin_ecmwf.f90 FFLAGS__nemo__sbcblk_skin_ecmwf.flags dom_oce.o in_out_manager.o lib_fortran.o lib_mpp.o oce.o phycst.o sbc_oce.o sbc_phy.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcclo.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcclo.done: sbcclo.o closea.done dom_oce.done in_out_manager.done iom.done lib_fortran.done lib_mpp.done phycst.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +sbcclo.o: $(FCM_PPSRCDIR)/nemo/sbcclo.f90 FFLAGS__nemo__sbcclo.flags closea.o dom_oce.o in_out_manager.o iom.o lib_fortran.o lib_mpp.o phycst.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbccpl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbccpl.done: sbccpl.o cpl_oasis3.done dom_oce.done eosbn2.done geo2ocean.done in_out_manager.done iom.done isf_oce.done lbclnk.done lib_mpp.done oce.done ocealb.done phycst.done sbc_ice.done sbc_oce.done sbc_phy.done sbcapr.done sbcdcy.done sbcrnf.done sbcwave.done trc_oce.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +sbccpl.o: $(FCM_PPSRCDIR)/nemo/sbccpl.f90 FFLAGS__nemo__sbccpl.flags cpl_oasis3.o dom_oce.o eosbn2.o geo2ocean.o in_out_manager.o iom.o isf_oce.o lbclnk.o lib_mpp.o oce.o ocealb.o phycst.o sbc_ice.o sbc_oce.o sbc_phy.o sbcapr.o sbcdcy.o sbcrnf.o sbcwave.o trc_oce.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcdcy.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcdcy.done: sbcdcy.o dom_oce.done in_out_manager.done lib_mpp.done oce.done phycst.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +sbcdcy.o: $(FCM_PPSRCDIR)/nemo/sbcdcy.f90 FFLAGS__nemo__sbcdcy.flags dom_oce.o in_out_manager.o lib_mpp.o oce.o phycst.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcflx.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcflx.done: sbcflx.o dom_oce.done fldread.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done sbc_oce.done sbcdcy.done trc_oce.done + touch $(FCM_DONEDIR)/$@ + +sbcflx.o: $(FCM_PPSRCDIR)/nemo/sbcflx.f90 FFLAGS__nemo__sbcflx.flags dom_oce.o fldread.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o sbc_oce.o sbcdcy.o trc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcfwb.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcfwb.done: sbcfwb.o dom_oce.done in_out_manager.done iom.done isf_oce.done lbclnk.done lib_fortran.done lib_mpp.done oce.done phycst.done sbc_ice.done sbc_oce.done sbcrnf.done sbcssr.done timing.done + touch $(FCM_DONEDIR)/$@ + +sbcfwb.o: $(FCM_PPSRCDIR)/nemo/sbcfwb.f90 FFLAGS__nemo__sbcfwb.flags dom_oce.o in_out_manager.o iom.o isf_oce.o lbclnk.o lib_fortran.o lib_mpp.o oce.o phycst.o sbc_ice.o sbc_oce.o sbcrnf.o sbcssr.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcice_cice.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcice_cice.done: sbcice_cice.o + touch $(FCM_DONEDIR)/$@ + +sbcice_cice.o: $(FCM_PPSRCDIR)/nemo/sbcice_cice.f90 FFLAGS__nemo__sbcice_cice.flags + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcice_if.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcice_if.done: sbcice_if.o dom_oce.done eosbn2.done fldread.done in_out_manager.done iom.done lib_fortran.done lib_mpp.done oce.done phycst.done sbc_ice.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +sbcice_if.o: $(FCM_PPSRCDIR)/nemo/sbcice_if.f90 FFLAGS__nemo__sbcice_if.flags dom_oce.o eosbn2.o fldread.o in_out_manager.o iom.o lib_fortran.o lib_mpp.o oce.o phycst.o sbc_ice.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcmod.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcmod.done: sbcmod.o bdy_oce.done closea.done cpl_oasis3.done diu_bulk.done dom_oce.done icb_oce.done icbstp.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done prtctl.done sbc_ice.done sbc_oce.done sbc_phy.done sbcabl.done sbcapr.done sbcblk.done sbcclo.done sbccpl.done sbcdcy.done sbcflx.done sbcfwb.done sbcice_cice.done sbcice_if.done sbcrnf.done sbcssm.done sbcssr.done sbcwave.done timing.done traqsr.done trc_oce.done usrdef_sbc.done wet_dry.done + touch $(FCM_DONEDIR)/$@ + +sbcmod.o: $(FCM_PPSRCDIR)/nemo/sbcmod.f90 FFLAGS__nemo__sbcmod.flags bdy_oce.o closea.o cpl_oasis3.o diu_bulk.o dom_oce.o icb_oce.o icbstp.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o prtctl.o sbc_ice.o sbc_oce.o sbc_phy.o sbcabl.o sbcapr.o sbcblk.o sbcclo.o sbccpl.o sbcdcy.o sbcflx.o sbcfwb.o sbcice_cice.o sbcice_if.o sbcrnf.o sbcssm.o sbcssr.o sbcwave.o timing.o traqsr.o trc_oce.o usrdef_sbc.o wet_dry.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcrnf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcrnf.done: sbcrnf.o closea.done dom_oce.done eosbn2.done fldread.done in_out_manager.done iom.done lib_mpp.done phycst.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +sbcrnf.o: $(FCM_PPSRCDIR)/nemo/sbcrnf.f90 FFLAGS__nemo__sbcrnf.flags closea.o dom_oce.o eosbn2.o fldread.o in_out_manager.o iom.o lib_mpp.o phycst.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcssm.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcssm.done: sbcssm.o dom_oce.done eosbn2.done in_out_manager.done iom.done oce.done prtctl.done sbc_oce.done sbcapr.done traqsr.done + touch $(FCM_DONEDIR)/$@ + +sbcssm.o: $(FCM_PPSRCDIR)/nemo/sbcssm.f90 FFLAGS__nemo__sbcssm.flags dom_oce.o eosbn2.o in_out_manager.o iom.o oce.o prtctl.o sbc_oce.o sbcapr.o traqsr.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcssr.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcssr.done: sbcssr.o dom_oce.done fldread.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done phycst.done sbc_oce.done sbcrnf.done + touch $(FCM_DONEDIR)/$@ + +sbcssr.o: $(FCM_PPSRCDIR)/nemo/sbcssr.f90 FFLAGS__nemo__sbcssr.flags dom_oce.o fldread.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o phycst.o sbc_oce.o sbcrnf.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sbcwave.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sbcwave.done: sbcwave.o bdy_oce.done dom_oce.done domvvl.done fldread.done in_out_manager.done iom.done lib_mpp.done oce.done phycst.done sbc_oce.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +sbcwave.o: $(FCM_PPSRCDIR)/nemo/sbcwave.f90 FFLAGS__nemo__sbcwave.flags bdy_oce.o dom_oce.o domvvl.o fldread.o in_out_manager.o iom.o lib_mpp.o oce.o phycst.o sbc_oce.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +single_precision_substitute.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/single_precision_substitute.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +single_precision_substitute.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/single_precision_substitute.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__solfrac_mod.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +solfrac_mod.done: solfrac_mod.o par_kind.done + touch $(FCM_DONEDIR)/$@ + +solfrac_mod.o: $(FCM_PPSRCDIR)/nemo/solfrac_mod.f90 FFLAGS__nemo__solfrac_mod.flags par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__sshwzv.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +sshwzv.done: sshwzv.o bdy_oce.done bdydyn2d.done divhor.done dom_oce.done domvvl.done in_out_manager.done iom.done isf_oce.done lbclnk.done lib_mpp.done oce.done phycst.done prtctl.done restart.done sbc_oce.done timing.done wet_dry.done + touch $(FCM_DONEDIR)/$@ + +sshwzv.o: $(FCM_PPSRCDIR)/nemo/sshwzv.f90 FFLAGS__nemo__sshwzv.flags bdy_oce.o bdydyn2d.o divhor.o dom_oce.o domvvl.o in_out_manager.o iom.o isf_oce.o lbclnk.o lib_mpp.o oce.o phycst.o prtctl.o restart.o sbc_oce.o timing.o wet_dry.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__step.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +step.done: step.o + touch $(FCM_DONEDIR)/$@ + +step.o: $(FCM_PPSRCDIR)/nemo/step.f90 FFLAGS__nemo__step.flags + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__step_diu.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +step_diu.done: step_diu.o daymod.done diaobs.done diu_layers.done iom.done oce.done restart.done sbc_oce.done sbcmod.done timing.done + touch $(FCM_DONEDIR)/$@ + +step_diu.o: $(FCM_PPSRCDIR)/nemo/step_diu.f90 FFLAGS__nemo__step_diu.flags daymod.o diaobs.o diu_layers.o iom.o oce.o restart.o sbc_oce.o sbcmod.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__step_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +step_oce.done: step_oce.o asmbkg.done asminc.done bdy_oce.done bdydta.done bdydyn3d.done bdytra.done crsfld.done daymod.done diaar5.done diacfl.done diadct.done diadetide.done diahsb.done diahth.done diamlr.done diaobs.done diaptr.done diawri.done diu_layers.done divhor.done dom_oce.done domtile.done domvvl.done dynadv.done dynatf.done dyndmp.done dynhpg.done dynldf.done dynspg.done dynvor.done dynzdf.done eosbn2.done flo_oce.done floats.done in_out_manager.done iom.done isf_oce.done isfstp.done lbclnk.done ldfdyn.done ldfslp.done ldftra.done oce.done prtctl.done restart.done sbc_oce.done sbcapr.done sbccpl.done sbcmod.done sbcrnf.done sbcwave.done sshwzv.done stopar.done stopts.done stpctl.done tide_mod.done timing.done traadv.done traatf.done trabbc.done trabbl.done tradmp.done traisf.done traldf.done tranpc.done traqsr.done trasbc.done trazdf.done zdf_oce.done zdfdrg.done zdfmfc.done zdfosm.done zdfphy.done zpshde.done + touch $(FCM_DONEDIR)/$@ + +step_oce.o: $(FCM_PPSRCDIR)/nemo/step_oce.f90 FFLAGS__nemo__step_oce.flags asmbkg.o asminc.o bdy_oce.o bdydta.o bdydyn3d.o bdytra.o crsfld.o daymod.o diaar5.o diacfl.o diadct.o diadetide.o diahsb.o diahth.o diamlr.o diaobs.o diaptr.o diawri.o diu_layers.o divhor.o dom_oce.o domtile.o domvvl.o dynadv.o dynatf.o dyndmp.o dynhpg.o dynldf.o dynspg.o dynvor.o dynzdf.o eosbn2.o flo_oce.o floats.o in_out_manager.o iom.o isf_oce.o isfstp.o lbclnk.o ldfdyn.o ldfslp.o ldftra.o oce.o prtctl.o restart.o sbc_oce.o sbcapr.o sbccpl.o sbcmod.o sbcrnf.o sbcwave.o sshwzv.o stopar.o stopts.o stpctl.o tide_mod.o timing.o traadv.o traatf.o trabbc.o trabbl.o tradmp.o traisf.o traldf.o tranpc.o traqsr.o trasbc.o trazdf.o zdf_oce.o zdfdrg.o zdfmfc.o zdfosm.o zdfphy.o zpshde.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__stopar.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +stopar.done: stopar.o dom_oce.done in_out_manager.done iom.done lbclnk.done lib_mpp.done par_oce.done storng.done + touch $(FCM_DONEDIR)/$@ + +stopar.o: $(FCM_PPSRCDIR)/nemo/stopar.f90 FFLAGS__nemo__stopar.flags dom_oce.o in_out_manager.o iom.o lbclnk.o lib_mpp.o par_oce.o storng.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__stopts.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +stopts.done: stopts.o dom_oce.done lbclnk.done phycst.done stopar.done + touch $(FCM_DONEDIR)/$@ + +stopts.o: $(FCM_PPSRCDIR)/nemo/stopts.f90 FFLAGS__nemo__stopts.flags dom_oce.o lbclnk.o phycst.o stopar.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__storng.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +storng.done: storng.o lib_mpp.done par_kind.done + touch $(FCM_DONEDIR)/$@ + +storng.o: $(FCM_PPSRCDIR)/nemo/storng.f90 FFLAGS__nemo__storng.flags lib_mpp.o par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__stpctl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +stpctl.done: stpctl.o diawri.done dom_oce.done eosbn2.done in_out_manager.done lbclnk.done lib_mpp.done oce.done wet_dry.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +stpctl.o: $(FCM_PPSRCDIR)/nemo/stpctl.f90 FFLAGS__nemo__stpctl.flags diawri.o dom_oce.o eosbn2.o in_out_manager.o lbclnk.o lib_mpp.o oce.o wet_dry.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__stpmlf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +stpmlf.done: stpmlf.o bdydyn.done domqco.done dynatf_qco.done dynspg_ts.done step_oce.done traatf_qco.done + touch $(FCM_DONEDIR)/$@ + +stpmlf.o: $(FCM_PPSRCDIR)/nemo/stpmlf.f90 FFLAGS__nemo__stpmlf.flags bdydyn.o domqco.o dynatf_qco.o dynspg_ts.o step_oce.o traatf_qco.o + fcm_internal compile:F nemo $< $@ + +str_c_to_for.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/str_c_to_for.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +str_c_to_for.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/str_c_to_for.h90 + touch $(FCM_DONEDIR)/$@ + +tide.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/tide.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +tide.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK/tide.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__nemo__tide_mod.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +tide_mod.done: tide_mod.o daymod.done in_out_manager.done iom.done oce.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +tide_mod.o: $(FCM_PPSRCDIR)/nemo/tide_mod.f90 FFLAGS__nemo__tide_mod.flags daymod.o in_out_manager.o iom.o oce.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__timing.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +timing.done: timing.o dom_oce.done in_out_manager.done lib_mpp.done + touch $(FCM_DONEDIR)/$@ + +timing.o: $(FCM_PPSRCDIR)/nemo/timing.f90 FFLAGS__nemo__timing.flags dom_oce.o in_out_manager.o lib_mpp.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traadv.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traadv.done: traadv.o diaptr.done dom_oce.done domtile.done domvvl.done in_out_manager.done iom.done ldfslp.done ldftra.done lib_mpp.done oce.done prtctl.done sbc_oce.done sbcwave.done timing.done traadv_cen.done traadv_fct.done traadv_mus.done traadv_qck.done traadv_ubs.done tramle.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +traadv.o: $(FCM_PPSRCDIR)/nemo/traadv.f90 FFLAGS__nemo__traadv.flags diaptr.o dom_oce.o domtile.o domvvl.o in_out_manager.o iom.o ldfslp.o ldftra.o lib_mpp.o oce.o prtctl.o sbc_oce.o sbcwave.o timing.o traadv_cen.o traadv_fct.o traadv_mus.o traadv_qck.o traadv_ubs.o tramle.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traadv_cen.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traadv_cen.done: traadv_cen.o diaar5.done diaptr.done dom_oce.done eosbn2.done in_out_manager.done iom.done lib_mpp.done traadv_fct.done trc_oce.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +traadv_cen.o: $(FCM_PPSRCDIR)/nemo/traadv_cen.f90 FFLAGS__nemo__traadv_cen.flags diaar5.o diaptr.o dom_oce.o eosbn2.o in_out_manager.o iom.o lib_mpp.o traadv_fct.o trc_oce.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traadv_cen_lf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traadv_cen_lf.done: traadv_cen_lf.o diaar5.done diaptr.done dom_oce.done eosbn2.done in_out_manager.done iom.done lib_mpp.done traadv_fct.done trc_oce.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +traadv_cen_lf.o: $(FCM_PPSRCDIR)/nemo/traadv_cen_lf.f90 FFLAGS__nemo__traadv_cen_lf.flags diaar5.o diaptr.o dom_oce.o eosbn2.o in_out_manager.o iom.o lib_mpp.o traadv_fct.o trc_oce.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traadv_fct.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traadv_fct.done: traadv_fct.o diaar5.done diaptr.done dom_oce.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done phycst.done trc_oce.done trd_oce.done trdtra.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +traadv_fct.o: $(FCM_PPSRCDIR)/nemo/traadv_fct.f90 FFLAGS__nemo__traadv_fct.flags diaar5.o diaptr.o dom_oce.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o phycst.o trc_oce.o trd_oce.o trdtra.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traadv_mus.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traadv_mus.done: traadv_mus.o diaar5.done diaptr.done dom_oce.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done sbcrnf.done trc_oce.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +traadv_mus.o: $(FCM_PPSRCDIR)/nemo/traadv_mus.f90 FFLAGS__nemo__traadv_mus.flags diaar5.o diaptr.o dom_oce.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o sbcrnf.o trc_oce.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traadv_qck.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traadv_qck.done: traadv_qck.o diaptr.done dom_oce.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done trc_oce.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +traadv_qck.o: $(FCM_PPSRCDIR)/nemo/traadv_qck.f90 FFLAGS__nemo__traadv_qck.flags diaptr.o dom_oce.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o trc_oce.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traadv_qck_lf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traadv_qck_lf.done: traadv_qck_lf.o diaptr.done dom_oce.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done trc_oce.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +traadv_qck_lf.o: $(FCM_PPSRCDIR)/nemo/traadv_qck_lf.f90 FFLAGS__nemo__traadv_qck_lf.flags diaptr.o dom_oce.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o trc_oce.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traadv_ubs.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traadv_ubs.done: traadv_ubs.o diaar5.done diaptr.done dom_oce.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done traadv_fct.done trc_oce.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +traadv_ubs.o: $(FCM_PPSRCDIR)/nemo/traadv_ubs.f90 FFLAGS__nemo__traadv_ubs.flags diaar5.o diaptr.o dom_oce.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o traadv_fct.o trc_oce.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traadv_ubs_lf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traadv_ubs_lf.done: traadv_ubs_lf.o diaar5.done diaptr.done dom_oce.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done traadv_fct.done trc_oce.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +traadv_ubs_lf.o: $(FCM_PPSRCDIR)/nemo/traadv_ubs_lf.f90 FFLAGS__nemo__traadv_ubs_lf.flags diaar5.o diaptr.o dom_oce.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o traadv_fct.o trc_oce.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traatf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traatf.done: traatf.o bdy_oce.done bdytra.done dom_oce.done domvvl.done in_out_manager.done isf_oce.done lbclnk.done ldfslp.done ldftra.done oce.done phycst.done prtctl.done sbc_oce.done sbcrnf.done timing.done traqsr.done trd_oce.done trdtra.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +traatf.o: $(FCM_PPSRCDIR)/nemo/traatf.f90 FFLAGS__nemo__traatf.flags bdy_oce.o bdytra.o dom_oce.o domvvl.o in_out_manager.o isf_oce.o lbclnk.o ldfslp.o ldftra.o oce.o phycst.o prtctl.o sbc_oce.o sbcrnf.o timing.o traqsr.o trd_oce.o trdtra.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traatf_qco.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traatf_qco.done: traatf_qco.o bdy_oce.done bdytra.done dom_oce.done domvvl.done in_out_manager.done isf_oce.done lbclnk.done ldfslp.done ldftra.done oce.done phycst.done prtctl.done sbc_oce.done sbcrnf.done timing.done traqsr.done trd_oce.done trdtra.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +traatf_qco.o: $(FCM_PPSRCDIR)/nemo/traatf_qco.f90 FFLAGS__nemo__traatf_qco.flags bdy_oce.o bdytra.o dom_oce.o domvvl.o in_out_manager.o isf_oce.o lbclnk.o ldfslp.o ldftra.o oce.o phycst.o prtctl.o sbc_oce.o sbcrnf.o timing.o traqsr.o trd_oce.o trdtra.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trabbc.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trabbc.done: trabbc.o dom_oce.done fldread.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done prtctl.done timing.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +trabbc.o: $(FCM_PPSRCDIR)/nemo/trabbc.f90 FFLAGS__nemo__trabbc.flags dom_oce.o fldread.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o prtctl.o timing.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trabbl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trabbl.done: trabbl.o dom_oce.done eosbn2.done in_out_manager.done iom.done lbclnk.done lib_fortran.done oce.done phycst.done prtctl.done timing.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +trabbl.o: $(FCM_PPSRCDIR)/nemo/trabbl.f90 FFLAGS__nemo__trabbl.flags dom_oce.o eosbn2.o in_out_manager.o iom.o lbclnk.o lib_fortran.o oce.o phycst.o prtctl.o timing.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__tradmp.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +tradmp.done: tradmp.o dom_oce.done dtatsd.done in_out_manager.done iom.done lib_mpp.done oce.done phycst.done prtctl.done timing.done trd_oce.done trdtra.done zdf_oce.done zdfmxl.done + touch $(FCM_DONEDIR)/$@ + +tradmp.o: $(FCM_PPSRCDIR)/nemo/tradmp.f90 FFLAGS__nemo__tradmp.flags dom_oce.o dtatsd.o in_out_manager.o iom.o lib_mpp.o oce.o phycst.o prtctl.o timing.o trd_oce.o trdtra.o zdf_oce.o zdfmxl.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traisf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traisf.done: traisf.o dom_oce.done in_out_manager.done isf_oce.done isfutils.done par_oce.done timing.done + touch $(FCM_DONEDIR)/$@ + +traisf.o: $(FCM_PPSRCDIR)/nemo/traisf.f90 FFLAGS__nemo__traisf.flags dom_oce.o in_out_manager.o isf_oce.o isfutils.o par_oce.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traldf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traldf.done: traldf.o dom_oce.done in_out_manager.done lbclnk.done ldfslp.done ldftra.done lib_mpp.done oce.done phycst.done prtctl.done timing.done traldf_iso.done traldf_lap_blp.done traldf_triad.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +traldf.o: $(FCM_PPSRCDIR)/nemo/traldf.f90 FFLAGS__nemo__traldf.flags dom_oce.o in_out_manager.o lbclnk.o ldfslp.o ldftra.o lib_mpp.o oce.o phycst.o prtctl.o timing.o traldf_iso.o traldf_lap_blp.o traldf_triad.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traldf_iso.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traldf_iso.done: traldf_iso.o diaar5.done diaptr.done dom_oce.done domutl.done in_out_manager.done iom.done lbclnk.done ldfslp.done ldftra.done oce.done phycst.done trc_oce.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +traldf_iso.o: $(FCM_PPSRCDIR)/nemo/traldf_iso.f90 FFLAGS__nemo__traldf_iso.flags diaar5.o diaptr.o dom_oce.o domutl.o in_out_manager.o iom.o lbclnk.o ldfslp.o ldftra.o oce.o phycst.o trc_oce.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traldf_lap_blp.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traldf_lap_blp.done: traldf_lap_blp.o diaar5.done diaptr.done dom_oce.done domutl.done in_out_manager.done iom.done lbclnk.done ldftra.done lib_mpp.done oce.done timing.done traldf_iso.done traldf_triad.done trc_oce.done zpshde.done + touch $(FCM_DONEDIR)/$@ + +traldf_lap_blp.o: $(FCM_PPSRCDIR)/nemo/traldf_lap_blp.f90 FFLAGS__nemo__traldf_lap_blp.flags diaar5.o diaptr.o dom_oce.o domutl.o in_out_manager.o iom.o lbclnk.o ldftra.o lib_mpp.o oce.o timing.o traldf_iso.o traldf_triad.o trc_oce.o zpshde.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traldf_triad.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traldf_triad.done: traldf_triad.o diaar5.done diaptr.done dom_oce.done domutl.done in_out_manager.done iom.done lbclnk.done ldfslp.done ldftra.done lib_mpp.done oce.done phycst.done traldf_iso.done trc_oce.done zdf_oce.done zpshde.done + touch $(FCM_DONEDIR)/$@ + +traldf_triad.o: $(FCM_PPSRCDIR)/nemo/traldf_triad.f90 FFLAGS__nemo__traldf_triad.flags diaar5.o diaptr.o dom_oce.o domutl.o in_out_manager.o iom.o lbclnk.o ldfslp.o ldftra.o lib_mpp.o oce.o phycst.o traldf_iso.o trc_oce.o zdf_oce.o zpshde.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__tramle.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +tramle.done: tramle.o dom_oce.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done zdf_oce.done zdfmxl.done zdfosm.done + touch $(FCM_DONEDIR)/$@ + +tramle.o: $(FCM_PPSRCDIR)/nemo/tramle.f90 FFLAGS__nemo__tramle.flags dom_oce.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o zdf_oce.o zdfmxl.o zdfosm.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__tranpc.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +tranpc.done: tranpc.o dom_oce.done eosbn2.done in_out_manager.done lbclnk.done lib_mpp.done oce.done phycst.done timing.done trd_oce.done trdtra.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +tranpc.o: $(FCM_PPSRCDIR)/nemo/tranpc.f90 FFLAGS__nemo__tranpc.flags dom_oce.o eosbn2.o in_out_manager.o lbclnk.o lib_mpp.o oce.o phycst.o timing.o trd_oce.o trdtra.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__traqsr.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +traqsr.done: traqsr.o dom_oce.done domtile.done fldread.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done prtctl.done restart.done sbc_oce.done timing.done trc_oce.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +traqsr.o: $(FCM_PPSRCDIR)/nemo/traqsr.f90 FFLAGS__nemo__traqsr.flags dom_oce.o domtile.o fldread.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o prtctl.o restart.o sbc_oce.o timing.o trc_oce.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trasbc.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trasbc.done: trasbc.o dom_oce.done eosbn2.done in_out_manager.done iom.done lbclnk.done oce.done phycst.done prtctl.done sbc_oce.done sbcmod.done sbcrnf.done timing.done traqsr.done trd_oce.done trdtra.done + touch $(FCM_DONEDIR)/$@ + +trasbc.o: $(FCM_PPSRCDIR)/nemo/trasbc.f90 FFLAGS__nemo__trasbc.flags dom_oce.o eosbn2.o in_out_manager.o iom.o lbclnk.o oce.o phycst.o prtctl.o sbc_oce.o sbcmod.o sbcrnf.o timing.o traqsr.o trd_oce.o trdtra.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trazdf.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trazdf.done: trazdf.o dom_oce.done domvvl.done eosbn2.done in_out_manager.done lbclnk.done ldfslp.done ldftra.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done timing.done trd_oce.done trdtra.done zdf_oce.done zdfmfc.done + touch $(FCM_DONEDIR)/$@ + +trazdf.o: $(FCM_PPSRCDIR)/nemo/trazdf.f90 FFLAGS__nemo__trazdf.flags dom_oce.o domvvl.o eosbn2.o in_out_manager.o lbclnk.o ldfslp.o ldftra.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o timing.o trd_oce.o trdtra.o zdf_oce.o zdfmfc.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trc_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trc_oce.done: trc_oce.o dom_oce.done in_out_manager.done lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +trc_oce.o: $(FCM_PPSRCDIR)/nemo/trc_oce.f90 FFLAGS__nemo__trc_oce.flags dom_oce.o in_out_manager.o lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trd_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trd_oce.done: trd_oce.o par_oce.done trdmxl_oce.done trdvor_oce.done + touch $(FCM_DONEDIR)/$@ + +trd_oce.o: $(FCM_PPSRCDIR)/nemo/trd_oce.f90 FFLAGS__nemo__trd_oce.flags par_oce.o trdmxl_oce.o trdvor_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trddyn.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trddyn.done: trddyn.o dom_oce.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done sbc_oce.done trd_oce.done trdglo.done trdken.done trdmxl.done trdvor.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +trddyn.o: $(FCM_PPSRCDIR)/nemo/trddyn.f90 FFLAGS__nemo__trddyn.flags dom_oce.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o sbc_oce.o trd_oce.o trdglo.o trdken.o trdmxl.o trdvor.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trdglo.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trdglo.done: trdglo.o dom_oce.done eosbn2.done in_out_manager.done iom.done ldfdyn.done ldftra.done lib_mpp.done oce.done phycst.done sbc_oce.done trd_oce.done zdf_oce.done zdfddm.done + touch $(FCM_DONEDIR)/$@ + +trdglo.o: $(FCM_PPSRCDIR)/nemo/trdglo.f90 FFLAGS__nemo__trdglo.flags dom_oce.o eosbn2.o in_out_manager.o iom.o ldfdyn.o ldftra.o lib_mpp.o oce.o phycst.o sbc_oce.o trd_oce.o zdf_oce.o zdfddm.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trdini.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trdini.done: trdini.o dom_oce.done domtile.done in_out_manager.done lib_mpp.done trd_oce.done trdglo.done trdken.done trdmxl.done trdpen.done trdvor.done + touch $(FCM_DONEDIR)/$@ + +trdini.o: $(FCM_PPSRCDIR)/nemo/trdini.f90 FFLAGS__nemo__trdini.flags dom_oce.o domtile.o in_out_manager.o lib_mpp.o trd_oce.o trdglo.o trdken.o trdmxl.o trdpen.o trdvor.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trdken.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trdken.done: trdken.o dom_oce.done in_out_manager.done iom.done ldfslp.done ldftra.done lib_mpp.done oce.done phycst.done sbc_oce.done trd_oce.done trdglo.done trdmxl.done trdvor.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +trdken.o: $(FCM_PPSRCDIR)/nemo/trdken.f90 FFLAGS__nemo__trdken.flags dom_oce.o in_out_manager.o iom.o ldfslp.o ldftra.o lib_mpp.o oce.o phycst.o sbc_oce.o trd_oce.o trdglo.o trdmxl.o trdvor.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trdmxl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trdmxl.done: trdmxl.o dianam.done dom_oce.done in_out_manager.done ioipsl.done iom.done lbclnk.done ldfslp.done ldftra.done lib_mpp.done oce.done phycst.done prtctl.done restart.done trd_oce.done trdmxl_oce.done trdmxl_rst.done zdf_oce.done zdfddm.done zdfmxl.done + touch $(FCM_DONEDIR)/$@ + +trdmxl.o: $(FCM_PPSRCDIR)/nemo/trdmxl.f90 FFLAGS__nemo__trdmxl.flags dianam.o dom_oce.o in_out_manager.o ioipsl.o iom.o lbclnk.o ldfslp.o ldftra.o lib_mpp.o oce.o phycst.o prtctl.o restart.o trd_oce.o trdmxl_oce.o trdmxl_rst.o zdf_oce.o zdfddm.o zdfmxl.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trdmxl_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trdmxl_oce.done: trdmxl_oce.o lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +trdmxl_oce.o: $(FCM_PPSRCDIR)/nemo/trdmxl_oce.f90 FFLAGS__nemo__trdmxl_oce.flags lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trdmxl_rst.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trdmxl_rst.done: trdmxl_rst.o dom_oce.done in_out_manager.done iom.done restart.done trd_oce.done + touch $(FCM_DONEDIR)/$@ + +trdmxl_rst.o: $(FCM_PPSRCDIR)/nemo/trdmxl_rst.f90 FFLAGS__nemo__trdmxl_rst.flags dom_oce.o in_out_manager.o iom.o restart.o trd_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trdpen.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trdpen.done: trdpen.o dom_oce.done eosbn2.done in_out_manager.done iom.done ldftra.done lib_mpp.done oce.done phycst.done sbc_oce.done trd_oce.done zdf_oce.done zdfddm.done + touch $(FCM_DONEDIR)/$@ + +trdpen.o: $(FCM_PPSRCDIR)/nemo/trdpen.f90 FFLAGS__nemo__trdpen.flags dom_oce.o eosbn2.o in_out_manager.o iom.o ldftra.o lib_mpp.o oce.o phycst.o sbc_oce.o trd_oce.o zdf_oce.o zdfddm.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trdtra.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trdtra.done: trdtra.o dom_oce.done in_out_manager.done iom.done ldfslp.done ldftra.done lib_mpp.done oce.done phycst.done sbc_oce.done trd_oce.done trdglo.done trdmxl.done trdpen.done trdtrc.done zdf_oce.done zdfddm.done + touch $(FCM_DONEDIR)/$@ + +trdtra.o: $(FCM_PPSRCDIR)/nemo/trdtra.f90 FFLAGS__nemo__trdtra.flags dom_oce.o in_out_manager.o iom.o ldfslp.o ldftra.o lib_mpp.o oce.o phycst.o sbc_oce.o trd_oce.o trdglo.o trdmxl.o trdpen.o trdtrc.o zdf_oce.o zdfddm.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trdtrc.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trdtrc.done: trdtrc.o par_kind.done + touch $(FCM_DONEDIR)/$@ + +trdtrc.o: $(FCM_PPSRCDIR)/nemo/trdtrc.f90 FFLAGS__nemo__trdtrc.flags par_kind.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trdvor.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trdvor.done: trdvor.o dianam.done dom_oce.done in_out_manager.done ioipsl.done lbclnk.done ldfdyn.done lib_mpp.done oce.done phycst.done sbc_oce.done trd_oce.done zdf_oce.done zdfmxl.done + touch $(FCM_DONEDIR)/$@ + +trdvor.o: $(FCM_PPSRCDIR)/nemo/trdvor.f90 FFLAGS__nemo__trdvor.flags dianam.o dom_oce.o in_out_manager.o ioipsl.o lbclnk.o ldfdyn.o lib_mpp.o oce.o phycst.o sbc_oce.o trd_oce.o zdf_oce.o zdfmxl.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__trdvor_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +trdvor_oce.done: trdvor_oce.o par_oce.done + touch $(FCM_DONEDIR)/$@ + +trdvor_oce.o: $(FCM_PPSRCDIR)/nemo/trdvor_oce.f90 FFLAGS__nemo__trdvor_oce.flags par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__usrdef_fmask.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +usrdef_fmask.done: usrdef_fmask.o dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done oce.done + touch $(FCM_DONEDIR)/$@ + +usrdef_fmask.o: $(FCM_PPSRCDIR)/nemo/usrdef_fmask.f90 FFLAGS__nemo__usrdef_fmask.flags dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__usrdef_hgr.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +usrdef_hgr.done: usrdef_hgr.o dom_oce.done in_out_manager.done lib_mpp.done par_oce.done phycst.done usrdef_nam.done + touch $(FCM_DONEDIR)/$@ + +usrdef_hgr.o: $(FCM_PPSRCDIR)/nemo/usrdef_hgr.f90 FFLAGS__nemo__usrdef_hgr.flags dom_oce.o in_out_manager.o lib_mpp.o par_oce.o phycst.o usrdef_nam.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__usrdef_istate.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +usrdef_istate.done: usrdef_istate.o in_out_manager.done lib_mpp.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +usrdef_istate.o: $(FCM_PPSRCDIR)/nemo/usrdef_istate.f90 FFLAGS__nemo__usrdef_istate.flags in_out_manager.o lib_mpp.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__usrdef_nam.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +usrdef_nam.done: usrdef_nam.o dom_oce.done in_out_manager.done lib_mpp.done par_oce.done phycst.done + touch $(FCM_DONEDIR)/$@ + +usrdef_nam.o: $(FCM_PPSRCDIR)/nemo/usrdef_nam.f90 FFLAGS__nemo__usrdef_nam.flags dom_oce.o in_out_manager.o lib_mpp.o par_oce.o phycst.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__usrdef_sbc.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +usrdef_sbc.done: usrdef_sbc.o dom_oce.done in_out_manager.done lbclnk.done lib_fortran.done lib_mpp.done oce.done phycst.done sbc_oce.done + touch $(FCM_DONEDIR)/$@ + +usrdef_sbc.o: $(FCM_PPSRCDIR)/nemo/usrdef_sbc.f90 FFLAGS__nemo__usrdef_sbc.flags dom_oce.o in_out_manager.o lbclnk.o lib_fortran.o lib_mpp.o oce.o phycst.o sbc_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__usrdef_zgr.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +usrdef_zgr.done: usrdef_zgr.o depth_e3.done dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done oce.done + touch $(FCM_DONEDIR)/$@ + +usrdef_zgr.o: $(FCM_PPSRCDIR)/nemo/usrdef_zgr.f90 FFLAGS__nemo__usrdef_zgr.flags depth_e3.o dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__wet_dry.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +wet_dry.done: wet_dry.o dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done oce.done sbc_oce.done sbcrnf.done timing.done + touch $(FCM_DONEDIR)/$@ + +wet_dry.o: $(FCM_PPSRCDIR)/nemo/wet_dry.f90 FFLAGS__nemo__wet_dry.flags dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o oce.o sbc_oce.o sbcrnf.o timing.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdf_oce.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdf_oce.done: zdf_oce.o in_out_manager.done lib_mpp.done par_oce.done + touch $(FCM_DONEDIR)/$@ + +zdf_oce.o: $(FCM_PPSRCDIR)/nemo/zdf_oce.f90 FFLAGS__nemo__zdf_oce.flags in_out_manager.o lib_mpp.o par_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfddm.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfddm.done: zdfddm.o dom_oce.done eosbn2.done in_out_manager.done lbclnk.done lib_mpp.done oce.done prtctl.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +zdfddm.o: $(FCM_PPSRCDIR)/nemo/zdfddm.f90 FFLAGS__nemo__zdfddm.flags dom_oce.o eosbn2.o in_out_manager.o lbclnk.o lib_mpp.o oce.o prtctl.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfdrg.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfdrg.done: zdfdrg.o dom_oce.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done trd_oce.done trddyn.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +zdfdrg.o: $(FCM_PPSRCDIR)/nemo/zdfdrg.f90 FFLAGS__nemo__zdfdrg.flags dom_oce.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o trd_oce.o trddyn.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfevd.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfevd.done: zdfevd.o dom_oce.done in_out_manager.done iom.done lbclnk.done oce.done timing.done trd_oce.done trdtra.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +zdfevd.o: $(FCM_PPSRCDIR)/nemo/zdfevd.f90 FFLAGS__nemo__zdfevd.flags dom_oce.o in_out_manager.o iom.o lbclnk.o oce.o timing.o trd_oce.o trdtra.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfgls.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfgls.done: zdfgls.o dom_oce.done domvvl.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done sbcwave.done zdf_oce.done zdfdrg.done zdfmxl.done + touch $(FCM_DONEDIR)/$@ + +zdfgls.o: $(FCM_PPSRCDIR)/nemo/zdfgls.f90 FFLAGS__nemo__zdfgls.flags dom_oce.o domvvl.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o sbcwave.o zdf_oce.o zdfdrg.o zdfmxl.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfiwm.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfiwm.done: zdfiwm.o dom_oce.done eosbn2.done fldread.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done phycst.done prtctl.done zdf_oce.done zdfddm.done + touch $(FCM_DONEDIR)/$@ + +zdfiwm.o: $(FCM_PPSRCDIR)/nemo/zdfiwm.f90 FFLAGS__nemo__zdfiwm.flags dom_oce.o eosbn2.o fldread.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o phycst.o prtctl.o zdf_oce.o zdfddm.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfmfc.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfmfc.done: zdfmfc.o dom_oce.done domvvl.done domzgr.done eosbn2.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done timing.done zdf_oce.done zdfmxl.done + touch $(FCM_DONEDIR)/$@ + +zdfmfc.o: $(FCM_PPSRCDIR)/nemo/zdfmfc.f90 FFLAGS__nemo__zdfmfc.flags dom_oce.o domvvl.o domzgr.o eosbn2.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o timing.o zdf_oce.o zdfmxl.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfmxl.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfmxl.done: zdfmxl.o dom_oce.done in_out_manager.done iom.done isf_oce.done lib_mpp.done oce.done phycst.done prtctl.done trc_oce.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +zdfmxl.o: $(FCM_PPSRCDIR)/nemo/zdfmxl.f90 FFLAGS__nemo__zdfmxl.flags dom_oce.o in_out_manager.o iom.o isf_oce.o lib_mpp.o oce.o phycst.o prtctl.o trc_oce.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfosm.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfosm.done: zdfosm.o dom_oce.done eosbn2.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done sbcwave.done traqsr.done trd_oce.done trdtra.done zdf_oce.done zdfddm.done zdfdrg.done + touch $(FCM_DONEDIR)/$@ + +zdfosm.o: $(FCM_PPSRCDIR)/nemo/zdfosm.f90 FFLAGS__nemo__zdfosm.flags dom_oce.o eosbn2.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o sbcwave.o traqsr.o trd_oce.o trdtra.o zdf_oce.o zdfddm.o zdfdrg.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfphy.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfphy.done: zdfphy.o domtile.done in_out_manager.done iom.done lbclnk.done lib_mpp.done oce.done sbc_ice.done sbc_oce.done sbcrnf.done timing.done tranpc.done trc_oce.done zdf_oce.done zdfddm.done zdfdrg.done zdfevd.done zdfgls.done zdfiwm.done zdfmfc.done zdfmxl.done zdfosm.done zdfric.done zdfsh2.done zdfswm.done zdftke.done + touch $(FCM_DONEDIR)/$@ + +zdfphy.o: $(FCM_PPSRCDIR)/nemo/zdfphy.f90 FFLAGS__nemo__zdfphy.flags domtile.o in_out_manager.o iom.o lbclnk.o lib_mpp.o oce.o sbc_ice.o sbc_oce.o sbcrnf.o timing.o tranpc.o trc_oce.o zdf_oce.o zdfddm.o zdfdrg.o zdfevd.o zdfgls.o zdfiwm.o zdfmfc.o zdfmxl.o zdfosm.o zdfric.o zdfsh2.o zdfswm.o zdftke.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfric.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfric.done: zdfric.o dom_oce.done in_out_manager.done iom.done lib_fortran.done oce.done phycst.done sbc_oce.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +zdfric.o: $(FCM_PPSRCDIR)/nemo/zdfric.f90 FFLAGS__nemo__zdfric.flags dom_oce.o in_out_manager.o iom.o lib_fortran.o oce.o phycst.o sbc_oce.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfsh2.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfsh2.done: zdfsh2.o dom_oce.done in_out_manager.done lib_mpp.done oce.done sbc_oce.done sbcwave.done + touch $(FCM_DONEDIR)/$@ + +zdfsh2.o: $(FCM_PPSRCDIR)/nemo/zdfsh2.f90 FFLAGS__nemo__zdfsh2.flags dom_oce.o in_out_manager.o lib_mpp.o oce.o sbc_oce.o sbcwave.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdfswm.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdfswm.done: zdfswm.o dom_oce.done in_out_manager.done lbclnk.done lib_mpp.done sbc_oce.done sbcwave.done zdf_oce.done + touch $(FCM_DONEDIR)/$@ + +zdfswm.o: $(FCM_PPSRCDIR)/nemo/zdfswm.f90 FFLAGS__nemo__zdfswm.flags dom_oce.o in_out_manager.o lbclnk.o lib_mpp.o sbc_oce.o sbcwave.o zdf_oce.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zdftke.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zdftke.done: zdftke.o dom_oce.done domvvl.done in_out_manager.done iom.done lbclnk.done lib_fortran.done lib_mpp.done oce.done phycst.done prtctl.done sbc_oce.done sbcwave.done zdf_oce.done zdfdrg.done zdfmxl.done + touch $(FCM_DONEDIR)/$@ + +zdftke.o: $(FCM_PPSRCDIR)/nemo/zdftke.f90 FFLAGS__nemo__zdftke.flags dom_oce.o domvvl.o in_out_manager.o iom.o lbclnk.o lib_fortran.o lib_mpp.o oce.o phycst.o prtctl.o sbc_oce.o sbcwave.o zdf_oce.o zdfdrg.o zdfmxl.o + fcm_internal compile:F nemo $< $@ + +FFLAGS__nemo__zpshde.flags: FFLAGS__nemo.flags + touch $(FCM_FLAGSDIR)/$@ + +zpshde.done: zpshde.o dom_oce.done domutl.done eosbn2.done in_out_manager.done lbclnk.done lib_mpp.done oce.done phycst.done timing.done + touch $(FCM_DONEDIR)/$@ + +zpshde.o: $(FCM_PPSRCDIR)/nemo/zpshde.f90 FFLAGS__nemo__zpshde.flags dom_oce.o domutl.o eosbn2.o in_out_manager.o lbclnk.o lib_mpp.o oce.o phycst.o timing.o + fcm_internal compile:F nemo $< $@ + +bfun1d.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/bfun1d.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +bfun1d.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/bfun1d.h90 + touch $(FCM_DONEDIR)/$@ + +ffsl1d.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/ffsl1d.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +ffsl1d.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/ffsl1d.h90 + touch $(FCM_DONEDIR)/$@ + +inv.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/inv.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +inv.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/inv.h90 + touch $(FCM_DONEDIR)/$@ + +oscl1d.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/oscl1d.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +oscl1d.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/oscl1d.h90 + touch $(FCM_DONEDIR)/$@ + +p1e.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/p1e.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +p1e.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/p1e.h90 + touch $(FCM_DONEDIR)/$@ + +p3e.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/p3e.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +p3e.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/p3e.h90 + touch $(FCM_DONEDIR)/$@ + +p5e.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/p5e.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +p5e.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/p5e.h90 + touch $(FCM_DONEDIR)/$@ + +pbc.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/pbc.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +pbc.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/pbc.h90 + touch $(FCM_DONEDIR)/$@ + +pcm.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/pcm.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +pcm.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/pcm.h90 + touch $(FCM_DONEDIR)/$@ + +plm.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/plm.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +plm.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/plm.h90 + touch $(FCM_DONEDIR)/$@ + +ppm.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/ppm.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +ppm.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/ppm.h90 + touch $(FCM_DONEDIR)/$@ + +FFLAGS__ppr_1d__ppr_1d.flags: FFLAGS__ppr_1d.flags + touch $(FCM_FLAGSDIR)/$@ + +ppr_1d.done: ppr_1d.o + touch $(FCM_DONEDIR)/$@ + +ppr_1d.o: $(FCM_PPSRCDIR)/ppr_1d/ppr_1d.f90 FFLAGS__ppr_1d__ppr_1d.flags + fcm_internal compile:F ppr_1d $< $@ + +pqm.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/pqm.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +pqm.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/pqm.h90 + touch $(FCM_DONEDIR)/$@ + +rcon1d.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/rcon1d.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +rcon1d.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/rcon1d.h90 + touch $(FCM_DONEDIR)/$@ + +rmap1d.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/rmap1d.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +rmap1d.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/rmap1d.h90 + touch $(FCM_DONEDIR)/$@ + +root1d.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/root1d.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +root1d.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/root1d.h90 + touch $(FCM_DONEDIR)/$@ + +util1d.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/util1d.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +util1d.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/util1d.h90 + touch $(FCM_DONEDIR)/$@ + +weno1d.h90: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/weno1d.h90 + cp $< $(FCM_INCDIR) + chmod u+w $(FCM_INCDIR)/$@ + +weno1d.h90.idone: /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src/weno1d.h90 + touch $(FCM_DONEDIR)/$@ + +# EOF diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/bin/fcm_env.ksh b/cfgs/ORCA2_OCE_MIXED/BLD/bin/fcm_env.ksh new file mode 120000 index 0000000000000000000000000000000000000000..e65424fd6d0ac5579e41f04922717111ac7d23a1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/bin/fcm_env.ksh @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/BLD/fcm_env.sh \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/bin/nemo.exe b/cfgs/ORCA2_OCE_MIXED/BLD/bin/nemo.exe new file mode 100755 index 0000000000000000000000000000000000000000..7bc85fa7c4813cb90d4a1293e69802122b16ada2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/bin/nemo.exe differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/cfg/parsed_bld.cfg b/cfgs/ORCA2_OCE_MIXED/BLD/cfg/parsed_bld.cfg new file mode 100644 index 0000000000000000000000000000000000000000..4cd9de4de6a7a64e5d0ef2ee51b803e5d38f3461 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/cfg/parsed_bld.cfg @@ -0,0 +1,119 @@ +# ----------------------- FCM extract configuration file ----------------------- +cfg::type bld +cfg::version 1.0 + + +# ------------------------------------------------------------------------------ +# Build information +# ------------------------------------------------------------------------------ + +# INC /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/mk/arch_nemo.fcm # Start + +#========================================================== +# Automatically generated by Fcheck_archfile.sh from +# /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/arch/arch-mn4.fcm +#========================================================== + +# generic ifort compiler options for linux +# NCDF_INC netcdf include file +# NCDF_LIB netcdf library +# FC Fortran compiler command +# FCFLAGS Fortran compiler flags +# FFLAGS Fortran 77 compiler flags +# LD linker +# LDFLAGS linker flags, e.g. -L if you have libraries in a +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC additional include files for the compiler, e.g. -I +# USER_LIB additional libraries to pass to the linker, e.g. -l + +%CPP cpp +%NCDF_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include +%NCDF_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff + +%XIOS_DIR /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/xios_sources/trunk +%XIOS_INC -I/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/xios_sources/trunk/inc +%XIOS_LIB -L/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/xios_sources/trunk/lib -lxios -lstdc++ + +%FC mpiifort +%CC icc +%CFLAGS -O3 +%FCFLAGS -r8 -ip -O3 -fp-model strict -extend-source 132 -heap-arrays +%FFFLAGS -r8 -ip -O3 -fp-model strict -extend-source 132 -heap-arrays +%LD mpiifort +%FPPFLAGS -P -traditional +%LDFLAGS -lstdc++ +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include -I/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/xios_sources/trunk/inc +%USER_LIB -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff -L/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/xios_sources/trunk/lib -lxios -lstdc++ + +# INC /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/mk/arch_nemo.fcm # End +# INC /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/mk/cpp.fcm # Start +bld::tool::fppkeys key_xios key_qco key_single +# INC /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/mk/cpp.fcm # End + +search_src 1 + +src::ioipsl /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/IOIPSL/src +src::nemo /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/WORK +src::ppr_1d /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/ext/PPR/src + +bld::target nemo.exe +bld::exe_dep + + +dir::root /gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/BLD + + +bld::tool::cpp cpp +bld::tool::fpp cpp +bld::tool::fc mpiifort +bld::tool::fflags -r8 -ip -O3 -fp-model strict -extend-source 132 -heap-arrays -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include -I/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/xios_sources/trunk/inc +bld::tool::ld mpiifort +bld::tool::ldflags -lstdc++ -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff -L/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/xios_sources/trunk/lib -lxios -lstdc++ +bld::tool::ar ar +bld::tool::arflags -r +bld::tool::make gmake + +# Pre-process code before analysing dependencies +bld::pp::ioipsl 1 +bld::pp::nemo 1 +bld::pp::ppr_1d 1 +bld::tool::fppflags::nemo -P -traditional +bld::tool::fppflags::ioipsl -P -traditional +bld::tool::fppflags::ppr_1d -P -traditional + +# Ignore the following dependencies +bld::excl_dep inc::netcdf.inc +bld::excl_dep inc::VT.inc +bld::excl_dep use::netcdf +bld::excl_dep use::xios +bld::excl_dep h::netcdf.inc +bld::excl_dep h::mpif.h +bld::excl_dep inc::mpif.h +bld::excl_dep inc::mpe_logf.h +bld::excl_dep use::mpi +bld::excl_dep use::mod_oasis +bld::excl_dep use::mkl_dfti +bld::excl_dep use::cudafor +bld::excl_dep use::openacc +# Don't generate interface files +bld::tool::geninterface none + +# Allow ".h90" as an extension for CPP include files +bld::infile_ext::h90 CPP::INCLUDE + +# extension for module output +bld::outfile_ext::mod .mod + +# rename executable to nemo.exe +bld::exe_name::model nemo.exe + + +# Ignore rp_emulator dependency +bld::excl_dep use::rp_emulator + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/abl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/abl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/abl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/abl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/asmbkg.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/asmbkg.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/asmbkg.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/asmbkg.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/asminc.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/asminc.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/asminc.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/asminc.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/asmpar.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/asmpar.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/asmpar.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/asmpar.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdy_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdy_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdy_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdy_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydta.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydta.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydta.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydta.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn2d.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn2d.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn2d.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn2d.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn3d.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn3d.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn3d.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdydyn3d.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdyice.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdyice.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdyini.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdyini.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdyini.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdyini.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdylib.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdylib.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdylib.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdylib.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdytides.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdytides.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdytides.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdytides.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdytra.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdytra.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdytra.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdytra.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdyvol.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdyvol.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/bdyvol.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/bdyvol.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/c1d.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/c1d.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/c1d.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/c1d.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/calendar.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/calendar.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/closea.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/closea.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/closea.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/closea.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/cpl_oasis3.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/cpl_oasis3.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/cpl_oasis3.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/cpl_oasis3.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crs.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/crs.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crs.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/crs.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crsdom.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/crsdom.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crsdom.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/crsdom.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crsdomwri.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/crsdomwri.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crsdomwri.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/crsdomwri.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crsfld.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/crsfld.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crsfld.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/crsfld.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crsini.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/crsini.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crsini.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/crsini.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crslbclnk.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/crslbclnk.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/crslbclnk.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/crslbclnk.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/cyclone.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/cyclone.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/cyclone.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/cyclone.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/daymod.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/daymod.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/daymod.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/daymod.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/defprec.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/defprec.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/depth_e3.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/depth_e3.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/depth_e3.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/depth_e3.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dia25h.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dia25h.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dia25h.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dia25h.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diaar5.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diaar5.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diaar5.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diaar5.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diacfl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diacfl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diacfl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diacfl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diadct.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diadct.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diadct.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diadct.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diadetide.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diadetide.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diadetide.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diadetide.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diahsb.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diahsb.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diahsb.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diahsb.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diahth.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diahth.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diahth.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diahth.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diamlr.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diamlr.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diamlr.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diamlr.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dianam.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dianam.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dianam.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dianam.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diaobs.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diaobs.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diaobs.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diaobs.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diaptr.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diaptr.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diaptr.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diaptr.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diawri.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diawri.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diawri.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diawri.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_bulk.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_bulk.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_bulk.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_bulk.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_coolskin.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_coolskin.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_coolskin.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_coolskin.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_layers.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_layers.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_layers.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/diu_layers.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/divhor.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/divhor.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/divhor.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/divhor.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dom_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dom_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dom_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dom_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domain.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/domain.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domain.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/domain.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domhgr.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/domhgr.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domhgr.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/domhgr.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dommsk.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dommsk.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dommsk.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dommsk.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domqco.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/domqco.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domqco.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/domqco.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domtile.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/domtile.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domtile.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/domtile.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domutl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/domutl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domutl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/domutl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domvvl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/domvvl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domvvl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/domvvl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domwri.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/domwri.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domwri.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/domwri.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domzgr.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/domzgr.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/domzgr.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/domzgr.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dtatsd.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dtatsd.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dtatsd.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dtatsd.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dtauvd.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dtauvd.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dtauvd.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dtauvd.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv_cen2.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv_cen2.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv_cen2.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv_cen2.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv_ubs.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv_ubs.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv_ubs.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynadv_ubs.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynatf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynatf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynatf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynatf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynatf_qco.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynatf_qco.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynatf_qco.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynatf_qco.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dyndmp.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dyndmp.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dyndmp.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dyndmp.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynhpg.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynhpg.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynhpg.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynhpg.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynkeg.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynkeg.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynkeg.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynkeg.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_iso.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_iso.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_iso.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_iso.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_iso_lf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_iso_lf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_lap_blp.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_lap_blp.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_lap_blp.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_lap_blp.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_lap_blp_lf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynldf_lap_blp_lf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg_exp.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg_exp.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg_exp.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg_exp.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg_ts.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg_ts.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg_ts.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynspg_ts.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynvor.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynvor.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynvor.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynvor.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynzad.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynzad.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynzad.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynzad.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynzdf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynzdf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/dynzdf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/dynzdf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/eosbn2.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/eosbn2.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/eosbn2.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/eosbn2.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/errioipsl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/errioipsl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/fldread.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/fldread.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/fldread.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/fldread.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/flincom.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/flincom.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/fliocom.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/fliocom.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/flo4rk.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/flo4rk.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/flo4rk.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/flo4rk.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/flo_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/flo_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/flo_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/flo_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/floats.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/floats.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/floats.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/floats.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/floblk.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/floblk.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/floblk.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/floblk.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/flodom.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/flodom.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/flodom.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/flodom.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/florst.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/florst.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/florst.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/florst.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/flowri.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/flowri.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/flowri.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/flowri.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/geo2ocean.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/geo2ocean.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/geo2ocean.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/geo2ocean.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/getincom.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/getincom.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/halo_mng.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/halo_mng.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/halo_mng.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/halo_mng.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/histcom.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/histcom.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icb_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/icb_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icb_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/icb_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbclv.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbclv.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbclv.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbclv.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbdia.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbdia.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbdia.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbdia.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbdyn.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbdyn.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbdyn.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbdyn.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbini.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbini.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbini.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbini.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icblbc.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/icblbc.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icblbc.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/icblbc.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbrst.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbrst.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbrst.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbrst.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbstp.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbstp.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbstp.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbstp.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbthm.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbthm.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbthm.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbthm.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbtrj.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbtrj.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbtrj.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbtrj.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbutl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbutl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/icbutl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/icbutl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/in_out_manager.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/in_out_manager.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/in_out_manager.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/in_out_manager.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ioipsl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/ioipsl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/iom.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/iom.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/iom.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/iom.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/iom_def.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/iom_def.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/iom_def.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/iom_def.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/iom_nf90.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/iom_nf90.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/iom_nf90.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/iom_nf90.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isf_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isf_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isf_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isf_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcav.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcav.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcav.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcav.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcavgam.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcavgam.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcavgam.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcavgam.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcavmlt.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcavmlt.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcavmlt.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcavmlt.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcpl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcpl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcpl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfcpl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfdiags.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfdiags.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfdiags.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfdiags.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfdynatf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfdynatf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfdynatf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfdynatf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfhdiv.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfhdiv.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfhdiv.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfhdiv.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfload.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfload.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfload.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfload.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfpar.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfpar.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfpar.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfpar.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfparmlt.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfparmlt.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfparmlt.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfparmlt.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfrst.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfrst.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfrst.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfrst.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfstp.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfstp.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfstp.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfstp.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isftbl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isftbl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isftbl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isftbl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfutils.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfutils.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/isfutils.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/isfutils.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/istate.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/istate.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/istate.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/istate.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/julian.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/julian.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/julian.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/julian.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/lbclnk.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/lbclnk.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/lbclnk.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/lbclnk.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/lbcnfd.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/lbcnfd.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/lbcnfd.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/lbcnfd.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfc1d_c2d.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfc1d_c2d.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfc1d_c2d.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfc1d_c2d.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfdyn.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfdyn.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfdyn.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfdyn.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfslp.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfslp.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfslp.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/ldfslp.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ldftra.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/ldftra.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ldftra.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/ldftra.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/lib_fortran.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/lib_fortran.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/lib_fortran.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/lib_fortran.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/lib_mpp.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/lib_mpp.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/lib_mpp.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/lib_mpp.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/mathelp.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/mathelp.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/module_example.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/module_example.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/mpp_map.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/mpp_map.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/mpp_map.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/mpp_map.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/mppini.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/mppini.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/mppini.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/mppini.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/nc4interface.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/nc4interface.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/nc4interface.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/nc4interface.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/nemogcm.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/nemogcm.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/nemogcm.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/nemogcm.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_averg_h2d.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_averg_h2d.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_averg_h2d.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_averg_h2d.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_const.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_const.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_const.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_const.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_conv.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_conv.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_conv.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_conv.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_fbm.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_fbm.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_fbm.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_fbm.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_grid.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_grid.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_grid.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_grid.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_h2d.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_h2d.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_h2d.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_h2d.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_sup.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_sup.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_sup.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_sup.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_z1d.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_z1d.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_z1d.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_inter_z1d.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_mpp.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_mpp.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_mpp.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_mpp.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_oper.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_oper.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_oper.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_oper.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_prep.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_prep.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_prep.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_prep.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_profiles.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_profiles.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_profiles_def.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_profiles_def.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_profiles_def.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_profiles_def.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_altbias.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_altbias.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_altbias.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_altbias.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_prof.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_prof.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_prof.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_prof.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_surf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_surf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_surf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_read_surf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_readmdt.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_readmdt.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_readmdt.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_readmdt.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_rot_vel.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_rot_vel.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_rot_vel.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_rot_vel.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_sort.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_sort.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_sort.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_sort.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_sstbias.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_sstbias.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_sstbias.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_sstbias.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_surf_def.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_surf_def.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_surf_def.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_surf_def.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_types.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_types.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_types.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_types.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_utils.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_utils.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_utils.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_utils.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_write.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_write.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_write.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/obs_write.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ocealb.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/ocealb.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ocealb.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/ocealb.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/par_kind.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/par_kind.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/par_kind.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/par_kind.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/par_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/par_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/par_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/par_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/phycst.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/phycst.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/phycst.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/phycst.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/ppr_1d.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/ppr_1d.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/prtctl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/prtctl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/prtctl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/prtctl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/restart.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/restart.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/restart.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/restart.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/restcom.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/restcom.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_ice.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_ice.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_ice.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_ice.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_phy.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_phy.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_phy.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbc_phy.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcabl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcabl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcabl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcabl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcapr.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcapr.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcapr.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcapr.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_andreas.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_andreas.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_andreas.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_andreas.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_coare3p0.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_coare3p0.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_coare3p0.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_coare3p0.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_coare3p6.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_coare3p6.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_coare3p6.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_coare3p6.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ecmwf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ecmwf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ecmwf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ecmwf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ice_an05.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ice_an05.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ice_cdn.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ice_cdn.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ice_lg15.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ice_lg15.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ice_lu12.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ice_lu12.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ncar.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ncar.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ncar.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_algo_ncar.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_skin_coare.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_skin_coare.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_skin_coare.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_skin_coare.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_skin_ecmwf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_skin_ecmwf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_skin_ecmwf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcblk_skin_ecmwf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcclo.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcclo.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcclo.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcclo.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbccpl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbccpl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbccpl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbccpl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcdcy.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcdcy.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcdcy.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcdcy.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcflx.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcflx.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcflx.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcflx.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcfwb.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcfwb.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcfwb.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcfwb.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcice_cice.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcice_cice.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcice_cice.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcice_cice.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcice_if.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcice_if.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcice_if.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcice_if.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcmod.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcmod.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcmod.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcmod.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcrnf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcrnf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcrnf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcrnf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcssm.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcssm.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcssm.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcssm.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcssr.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcssr.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcssr.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcssr.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcwave.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcwave.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcwave.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sbcwave.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/solfrac_mod.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/solfrac_mod.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/solfrac_mod.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/solfrac_mod.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sshwzv.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/sshwzv.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/sshwzv.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/sshwzv.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/step.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/step.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/step_diu.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/step_diu.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/step_diu.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/step_diu.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/step_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/step_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/step_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/step_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/stopar.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/stopar.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/stopar.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/stopar.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/stopts.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/stopts.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/stopts.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/stopts.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/storng.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/storng.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/storng.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/storng.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/stpctl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/stpctl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/stpctl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/stpctl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/stpmlf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/stpmlf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/stpmlf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/stpmlf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/stringop.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/stringop.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/tide_mod.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/tide_mod.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/tide_mod.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/tide_mod.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/timing.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/timing.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/timing.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/timing.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_cen.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_cen.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_cen.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_cen.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_cen_lf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_cen_lf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_fct.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_fct.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_fct.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_fct.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_mus.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_mus.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_mus.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_mus.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_qck.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_qck.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_qck.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_qck.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_qck_lf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_qck_lf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_ubs.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_ubs.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_ubs.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_ubs.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_ubs_lf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traadv_ubs_lf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traatf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traatf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traatf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traatf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traatf_qco.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traatf_qco.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traatf_qco.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traatf_qco.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trabbc.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trabbc.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trabbc.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trabbc.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trabbl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trabbl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trabbl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trabbl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/tradmp.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/tradmp.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/tradmp.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/tradmp.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traisf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traisf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traisf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traisf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_iso.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_iso.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_iso.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_iso.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_lap_blp.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_lap_blp.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_lap_blp.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_lap_blp.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_triad.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_triad.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_triad.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traldf_triad.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/tramle.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/tramle.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/tramle.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/tramle.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/tranpc.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/tranpc.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/tranpc.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/tranpc.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traqsr.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/traqsr.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/traqsr.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/traqsr.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trasbc.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trasbc.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trasbc.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trasbc.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trazdf.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trazdf.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trazdf.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trazdf.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trc_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trc_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trc_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trc_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trd_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trd_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trd_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trd_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trddyn.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trddyn.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trddyn.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trddyn.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdglo.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdglo.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdglo.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdglo.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdini.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdini.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdini.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdini.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdken.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdken.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdken.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdken.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl_rst.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl_rst.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl_rst.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdmxl_rst.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdpen.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdpen.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdpen.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdpen.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdtra.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdtra.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdtra.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdtra.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdtrc.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdtrc.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdtrc.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdtrc.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdvor.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdvor.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdvor.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdvor.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdvor_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdvor_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/trdvor_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/trdvor_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_fmask.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_fmask.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_fmask.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_fmask.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_hgr.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_hgr.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_hgr.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_hgr.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_istate.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_istate.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_istate.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_istate.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_nam.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_nam.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_nam.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_nam.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_sbc.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_sbc.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_sbc.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_sbc.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_zgr.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_zgr.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_zgr.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/usrdef_zgr.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/wet_dry.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/wet_dry.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/wet_dry.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/wet_dry.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdf_oce.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdf_oce.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdf_oce.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdf_oce.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfddm.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfddm.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfddm.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfddm.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfdrg.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfdrg.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfdrg.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfdrg.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfevd.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfevd.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfevd.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfevd.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfgls.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfgls.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfgls.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfgls.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfiwm.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfiwm.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfiwm.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfiwm.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfmfc.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfmfc.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfmfc.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfmfc.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfmxl.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfmxl.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfmxl.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfmxl.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfosm.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfosm.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfosm.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfosm.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfphy.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfphy.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfphy.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfphy.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfric.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfric.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfric.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfric.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfsh2.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfsh2.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfsh2.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfsh2.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfswm.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfswm.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfswm.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdfswm.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdftke.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdftke.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zdftke.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zdftke.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zpshde.F90.pdone b/cfgs/ORCA2_OCE_MIXED/BLD/done/zpshde.F90.pdone new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/done/zpshde.done b/cfgs/ORCA2_OCE_MIXED/BLD/done/zpshde.done new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/fcm_env.ksh b/cfgs/ORCA2_OCE_MIXED/BLD/fcm_env.ksh new file mode 120000 index 0000000000000000000000000000000000000000..e65424fd6d0ac5579e41f04922717111ac7d23a1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/fcm_env.ksh @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/BLD/fcm_env.sh \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/fcm_env.sh b/cfgs/ORCA2_OCE_MIXED/BLD/fcm_env.sh new file mode 100644 index 0000000000000000000000000000000000000000..6875b43794f1b9a061a45a1fda9b10d5c353db31 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/fcm_env.sh @@ -0,0 +1,3 @@ +#!/bin/sh +PATH=/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/BLD/bin:$PATH +export PATH diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FC.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FC.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__calendar.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__calendar.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__defprec.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__defprec.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__errioipsl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__errioipsl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__flincom.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__flincom.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__fliocom.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__fliocom.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__getincom.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__getincom.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__histcom.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__histcom.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__ioipsl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__ioipsl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__mathelp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__mathelp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__nc4interface.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__nc4interface.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__restcom.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__restcom.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__stringop.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ioipsl__stringop.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__abl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__abl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__asmbkg.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__asmbkg.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__asminc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__asminc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__asmpar.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__asmpar.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdy_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdy_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdydta.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdydta.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdydyn.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdydyn.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdydyn2d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdydyn2d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdydyn3d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdydyn3d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdyice.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdyice.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdyini.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdyini.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdylib.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdylib.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdytides.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdytides.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdytra.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdytra.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdyvol.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__bdyvol.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__c1d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__c1d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__closea.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__closea.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__cpl_oasis3.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__cpl_oasis3.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crs.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crs.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crsdom.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crsdom.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crsdomwri.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crsdomwri.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crsfld.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crsfld.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crsini.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crsini.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crslbclnk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__crslbclnk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__cyclone.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__cyclone.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__daymod.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__daymod.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__depth_e3.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__depth_e3.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dia25h.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dia25h.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diaar5.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diaar5.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diacfl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diacfl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diadct.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diadct.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diadetide.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diadetide.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diahsb.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diahsb.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diahth.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diahth.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diamlr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diamlr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dianam.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dianam.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diaobs.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diaobs.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diaptr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diaptr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diawri.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diawri.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diu_bulk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diu_bulk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diu_coolskin.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diu_coolskin.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diu_layers.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__diu_layers.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__divhor.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__divhor.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dom_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dom_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domain.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domain.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domhgr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domhgr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dommsk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dommsk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domqco.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domqco.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domtile.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domtile.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domutl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domutl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domvvl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domvvl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domwri.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domwri.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domzgr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__domzgr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dtatsd.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dtatsd.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dtauvd.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dtauvd.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynadv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynadv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynadv_cen2.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynadv_cen2.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynadv_ubs.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynadv_ubs.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynatf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynatf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynatf_qco.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynatf_qco.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dyndmp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dyndmp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynhpg.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynhpg.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynkeg.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynkeg.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynldf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynldf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynldf_iso.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynldf_iso.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynldf_iso_lf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynldf_iso_lf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynldf_lap_blp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynldf_lap_blp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynldf_lap_blp_lf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynldf_lap_blp_lf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynspg.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynspg.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynspg_exp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynspg_exp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynspg_ts.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynspg_ts.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynvor.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynvor.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynzad.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynzad.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynzdf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__dynzdf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__eosbn2.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__eosbn2.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__fldread.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__fldread.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__flo4rk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__flo4rk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__flo_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__flo_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__floats.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__floats.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__floblk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__floblk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__flodom.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__flodom.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__florst.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__florst.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__flowri.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__flowri.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__geo2ocean.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__geo2ocean.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__halo_mng.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__halo_mng.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icb_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icb_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbclv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbclv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbdia.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbdia.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbdyn.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbdyn.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbini.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbini.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icblbc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icblbc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbrst.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbrst.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbstp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbstp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbthm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbthm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbtrj.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbtrj.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbutl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__icbutl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__in_out_manager.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__in_out_manager.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__iom.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__iom.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__iom_def.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__iom_def.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__iom_nf90.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__iom_nf90.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isf_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isf_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfcav.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfcav.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfcavgam.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfcavgam.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfcavmlt.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfcavmlt.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfcpl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfcpl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfdiags.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfdiags.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfdynatf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfdynatf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfhdiv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfhdiv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfload.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfload.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfpar.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfpar.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfparmlt.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfparmlt.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfrst.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfrst.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfstp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfstp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isftbl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isftbl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfutils.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__isfutils.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__istate.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__istate.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__julian.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__julian.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__lbclnk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__lbclnk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__lbcnfd.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__lbcnfd.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__ldfc1d_c2d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__ldfc1d_c2d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__ldfdyn.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__ldfdyn.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__ldfslp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__ldfslp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__ldftra.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__ldftra.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__lib_cray.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__lib_cray.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__lib_fortran.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__lib_fortran.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__lib_mpp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__lib_mpp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__module_example.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__module_example.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__mpp_map.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__mpp_map.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__mppini.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__mppini.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__nemo.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__nemo.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__nemogcm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__nemogcm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_averg_h2d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_averg_h2d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_const.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_const.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_conv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_conv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_fbm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_fbm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_grid.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_grid.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_inter_h2d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_inter_h2d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_inter_sup.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_inter_sup.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_inter_z1d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_inter_z1d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_mpp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_mpp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_oper.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_oper.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_prep.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_prep.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_profiles.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_profiles.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_profiles_def.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_profiles_def.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_read_altbias.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_read_altbias.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_read_prof.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_read_prof.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_read_surf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_read_surf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_readmdt.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_readmdt.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_rot_vel.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_rot_vel.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_sort.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_sort.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_sstbias.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_sstbias.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_surf_def.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_surf_def.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_types.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_types.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_utils.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_utils.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_write.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__obs_write.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__ocealb.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__ocealb.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__par_kind.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__par_kind.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__par_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__par_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__phycst.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__phycst.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__prtctl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__prtctl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__restart.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__restart.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbc_ice.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbc_ice.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbc_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbc_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbc_phy.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbc_phy.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcabl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcabl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcapr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcapr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_andreas.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_andreas.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_coare3p0.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_coare3p0.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_coare3p6.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_coare3p6.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ecmwf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ecmwf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ice_an05.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ice_an05.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ice_cdn.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ice_cdn.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ice_lg15.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ice_lg15.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ice_lu12.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ice_lu12.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ncar.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_algo_ncar.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_skin_coare.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_skin_coare.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_skin_ecmwf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcblk_skin_ecmwf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcclo.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcclo.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbccpl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbccpl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcdcy.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcdcy.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcflx.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcflx.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcfwb.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcfwb.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcice_cice.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcice_cice.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcice_if.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcice_if.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcmod.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcmod.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcrnf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcrnf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcssm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcssm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcssr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcssr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcwave.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sbcwave.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__solfrac_mod.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__solfrac_mod.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sshwzv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__sshwzv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__step.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__step.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__step_diu.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__step_diu.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__step_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__step_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__stopar.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__stopar.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__stopts.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__stopts.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__storng.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__storng.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__stpctl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__stpctl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__stpmlf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__stpmlf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__tide_mod.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__tide_mod.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__timing.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__timing.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_cen.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_cen.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_cen_lf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_cen_lf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_fct.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_fct.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_mus.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_mus.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_qck.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_qck.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_qck_lf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_qck_lf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_ubs.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_ubs.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_ubs_lf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traadv_ubs_lf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traatf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traatf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traatf_qco.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traatf_qco.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trabbc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trabbc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trabbl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trabbl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__tradmp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__tradmp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traisf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traisf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traldf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traldf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traldf_iso.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traldf_iso.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traldf_lap_blp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traldf_lap_blp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traldf_triad.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traldf_triad.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__tramle.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__tramle.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__tranpc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__tranpc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traqsr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__traqsr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trasbc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trasbc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trazdf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trazdf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trc_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trc_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trd_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trd_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trddyn.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trddyn.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdglo.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdglo.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdini.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdini.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdken.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdken.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdmxl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdmxl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdmxl_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdmxl_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdmxl_rst.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdmxl_rst.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdpen.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdpen.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdtra.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdtra.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdtrc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdtrc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdvor.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdvor.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdvor_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__trdvor_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_fmask.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_fmask.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_hgr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_hgr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_istate.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_istate.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_nam.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_nam.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_sbc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_sbc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_zgr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__usrdef_zgr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__wet_dry.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__wet_dry.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdf_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdf_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfddm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfddm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfdrg.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfdrg.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfevd.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfevd.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfgls.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfgls.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfiwm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfiwm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfmfc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfmfc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfmxl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfmxl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfosm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfosm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfphy.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfphy.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfric.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfric.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfsh2.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfsh2.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfswm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdfswm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdftke.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zdftke.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zpshde.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__nemo__zpshde.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ppr_1d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ppr_1d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ppr_1d__ppr_1d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FFLAGS__ppr_1d__ppr_1d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__ioipsl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__ioipsl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__ioipsl__nc4interface.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__ioipsl__nc4interface.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__abl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__abl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__asmbkg.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__asmbkg.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__asminc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__asminc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__asmpar.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__asmpar.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdy_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdy_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdydta.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdydta.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdydyn.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdydyn.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdydyn2d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdydyn2d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdydyn3d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdydyn3d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdyice.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdyice.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdyini.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdyini.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdylib.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdylib.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdytides.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdytides.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdytra.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdytra.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdyvol.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__bdyvol.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__c1d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__c1d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__closea.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__closea.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__cpl_oasis3.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__cpl_oasis3.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crs.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crs.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crsdom.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crsdom.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crsdomwri.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crsdomwri.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crsfld.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crsfld.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crsini.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crsini.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crslbclnk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__crslbclnk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__cyclone.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__cyclone.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__daymod.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__daymod.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__depth_e3.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__depth_e3.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dia25h.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dia25h.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diaar5.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diaar5.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diacfl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diacfl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diadct.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diadct.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diadetide.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diadetide.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diahsb.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diahsb.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diahth.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diahth.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diamlr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diamlr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dianam.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dianam.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diaobs.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diaobs.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diaptr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diaptr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diawri.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diawri.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diu_bulk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diu_bulk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diu_coolskin.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diu_coolskin.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diu_layers.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__diu_layers.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__divhor.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__divhor.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dom_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dom_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domain.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domain.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domhgr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domhgr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dommsk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dommsk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domqco.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domqco.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domtile.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domtile.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domutl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domutl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domvvl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domvvl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domwri.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domwri.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domzgr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__domzgr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dtatsd.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dtatsd.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dtauvd.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dtauvd.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynadv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynadv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynadv_cen2.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynadv_cen2.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynadv_ubs.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynadv_ubs.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynatf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynatf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynatf_qco.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynatf_qco.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dyndmp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dyndmp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynhpg.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynhpg.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynkeg.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynkeg.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynldf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynldf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynldf_iso.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynldf_iso.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynldf_iso_lf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynldf_iso_lf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynldf_lap_blp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynldf_lap_blp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynldf_lap_blp_lf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynldf_lap_blp_lf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynspg.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynspg.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynspg_exp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynspg_exp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynspg_ts.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynspg_ts.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynvor.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynvor.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynzad.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynzad.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynzdf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__dynzdf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__eosbn2.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__eosbn2.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__fldread.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__fldread.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__flo4rk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__flo4rk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__flo_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__flo_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__floats.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__floats.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__floblk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__floblk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__flodom.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__flodom.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__florst.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__florst.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__flowri.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__flowri.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__geo2ocean.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__geo2ocean.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__halo_mng.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__halo_mng.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icb_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icb_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbclv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbclv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbdia.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbdia.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbdyn.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbdyn.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbini.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbini.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icblbc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icblbc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbrst.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbrst.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbstp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbstp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbthm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbthm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbtrj.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbtrj.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbutl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__icbutl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__in_out_manager.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__in_out_manager.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__iom.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__iom.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__iom_def.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__iom_def.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__iom_nf90.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__iom_nf90.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isf_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isf_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfcav.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfcav.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfcavgam.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfcavgam.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfcavmlt.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfcavmlt.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfcpl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfcpl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfdiags.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfdiags.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfdynatf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfdynatf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfhdiv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfhdiv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfload.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfload.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfpar.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfpar.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfparmlt.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfparmlt.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfrst.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfrst.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfstp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfstp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isftbl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isftbl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfutils.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__isfutils.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__istate.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__istate.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__julian.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__julian.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__lbclnk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__lbclnk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__lbcnfd.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__lbcnfd.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__ldfc1d_c2d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__ldfc1d_c2d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__ldfdyn.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__ldfdyn.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__ldfslp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__ldfslp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__ldftra.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__ldftra.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__lib_fortran.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__lib_fortran.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__lib_mpp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__lib_mpp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__module_example.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__module_example.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__mpp_map.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__mpp_map.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__mppini.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__mppini.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__nemogcm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__nemogcm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_averg_h2d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_averg_h2d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_const.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_const.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_conv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_conv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_fbm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_fbm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_grid.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_grid.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_inter_h2d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_inter_h2d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_inter_sup.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_inter_sup.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_inter_z1d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_inter_z1d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_mpp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_mpp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_oper.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_oper.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_prep.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_prep.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_profiles.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_profiles.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_profiles_def.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_profiles_def.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_read_altbias.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_read_altbias.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_read_prof.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_read_prof.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_read_surf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_read_surf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_readmdt.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_readmdt.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_rot_vel.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_rot_vel.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_sort.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_sort.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_sstbias.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_sstbias.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_surf_def.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_surf_def.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_types.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_types.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_utils.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_utils.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_write.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__obs_write.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__ocealb.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__ocealb.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__par_kind.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__par_kind.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__par_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__par_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__phycst.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__phycst.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__prtctl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__prtctl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__restart.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__restart.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbc_ice.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbc_ice.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbc_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbc_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbc_phy.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbc_phy.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcabl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcabl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcapr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcapr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_andreas.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_andreas.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_coare3p0.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_coare3p0.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_coare3p6.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_coare3p6.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ecmwf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ecmwf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ice_an05.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ice_an05.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ice_cdn.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ice_cdn.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ice_lg15.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ice_lg15.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ice_lu12.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ice_lu12.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ncar.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_algo_ncar.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_skin_coare.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_skin_coare.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_skin_ecmwf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcblk_skin_ecmwf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcclo.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcclo.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbccpl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbccpl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcdcy.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcdcy.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcflx.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcflx.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcfwb.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcfwb.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcice_cice.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcice_cice.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcice_if.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcice_if.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcmod.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcmod.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcrnf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcrnf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcssm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcssm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcssr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcssr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcwave.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sbcwave.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__solfrac_mod.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__solfrac_mod.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sshwzv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__sshwzv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__step.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__step.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__step_diu.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__step_diu.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__step_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__step_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__stopar.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__stopar.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__stopts.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__stopts.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__storng.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__storng.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__stpctl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__stpctl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__stpmlf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__stpmlf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__tide_mod.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__tide_mod.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__timing.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__timing.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_cen.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_cen.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_cen_lf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_cen_lf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_fct.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_fct.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_mus.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_mus.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_qck.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_qck.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_qck_lf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_qck_lf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_ubs.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_ubs.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_ubs_lf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traadv_ubs_lf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traatf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traatf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traatf_qco.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traatf_qco.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trabbc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trabbc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trabbl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trabbl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__tradmp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__tradmp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traisf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traisf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traldf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traldf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traldf_iso.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traldf_iso.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traldf_lap_blp.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traldf_lap_blp.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traldf_triad.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traldf_triad.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__tramle.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__tramle.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__tranpc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__tranpc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traqsr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__traqsr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trasbc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trasbc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trazdf.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trazdf.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trc_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trc_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trd_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trd_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trddyn.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trddyn.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdglo.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdglo.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdini.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdini.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdken.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdken.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdmxl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdmxl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdmxl_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdmxl_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdmxl_rst.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdmxl_rst.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdpen.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdpen.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdtra.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdtra.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdtrc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdtrc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdvor.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdvor.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdvor_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__trdvor_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_fmask.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_fmask.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_hgr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_hgr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_istate.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_istate.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_nam.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_nam.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_sbc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_sbc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_zgr.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__usrdef_zgr.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__wet_dry.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__wet_dry.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdf_oce.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdf_oce.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfddm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfddm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfdrg.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfdrg.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfevd.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfevd.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfgls.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfgls.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfiwm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfiwm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfmfc.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfmfc.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfmxl.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfmxl.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfosm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfosm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfphy.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfphy.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfric.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfric.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfsh2.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfsh2.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfswm.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdfswm.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdftke.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zdftke.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zpshde.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__nemo__zpshde.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__ppr_1d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__ppr_1d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__ppr_1d__ppr_1d.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/FPPKEYS__ppr_1d__ppr_1d.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/LD.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/LD.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/LDFLAGS.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/LDFLAGS.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/LDFLAGS__nemo.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/LDFLAGS__nemo.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/LDFLAGS__nemo__nemo.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/LDFLAGS__nemo__nemo.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/LD__nemo.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/LD__nemo.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/flags/LD__nemo__nemo.flags b/cfgs/ORCA2_OCE_MIXED/BLD/flags/LD__nemo__nemo.flags new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/abl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/abl.mod new file mode 100644 index 0000000000000000000000000000000000000000..eeb6a5af791a1144a1f56d254ccc897d89028fb6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/abl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/asmbkg.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/asmbkg.mod new file mode 100644 index 0000000000000000000000000000000000000000..fdf0345ab0fd997a2138f2fa2e368f6c1f805174 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/asmbkg.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/asminc.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/asminc.mod new file mode 100644 index 0000000000000000000000000000000000000000..6f588708046d71696a03d97d914ba38f6f5f01f2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/asminc.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/asmpar.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/asmpar.mod new file mode 100644 index 0000000000000000000000000000000000000000..ac1cf1231d2daf2fab9f84cdb172f50d695494e2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/asmpar.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdy_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdy_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..822fe5360c9d7fa51641724ff9ce3b0920740009 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdy_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydta.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydta.mod new file mode 100644 index 0000000000000000000000000000000000000000..2222bac9f5808596726686b88729365c934e2db6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydta.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydyn.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydyn.mod new file mode 100644 index 0000000000000000000000000000000000000000..f108972dfdd50fbf703eed04815696b6feeca370 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydyn.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydyn2d.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydyn2d.mod new file mode 100644 index 0000000000000000000000000000000000000000..98e8a4395e28907410238b38e16bcb26fc1f1151 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydyn2d.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydyn3d.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydyn3d.mod new file mode 100644 index 0000000000000000000000000000000000000000..fff7da2915615e5994b3a8c5c640ff5456826087 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdydyn3d.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdyice.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdyice.mod new file mode 100644 index 0000000000000000000000000000000000000000..c42eeb8d0eaa154b9f53c1c8fee631d7704573fa Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdyice.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdyini.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdyini.mod new file mode 100644 index 0000000000000000000000000000000000000000..a82f97b3c7c50eac988d09b3b7f0918a28e5b4c3 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdyini.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdylib.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdylib.mod new file mode 100644 index 0000000000000000000000000000000000000000..820875196223cfb4ce5331403f2359af979930e2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdylib.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdytides.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdytides.mod new file mode 100644 index 0000000000000000000000000000000000000000..d5b0c024d9c1340f1ec7c28e266ffa4890f77a76 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdytides.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdytra.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdytra.mod new file mode 100644 index 0000000000000000000000000000000000000000..afe67573c738e162cad81931ebadd014006c7016 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdytra.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdyvol.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdyvol.mod new file mode 100644 index 0000000000000000000000000000000000000000..eae719df1788972baae5750f79a9fd48df7375c8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bdyvol.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/bfun1d.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bfun1d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..279634678bb4805d2e674e5479a3e09bbaa0b257 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/bfun1d.h90 @@ -0,0 +1,251 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! BFUN1D.h90: poly. basis-functions for reconstruction. + ! + ! Darren Engwirda + ! 07-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine bfun1d(isel,ndof,sval,bfun) + + ! + ! ISEL basis-function "order", -1 => integral-basis , + ! +0 => function-basis, +1 => 1st deriv.-basis , + ! +2 => 2nd deriv.-basis. + ! NDOF no. degrees-of-freedom in basis. + ! SVAL local coord. at which to evaluate basis-func., + ! such that -1.0 <= SVAL <= +1.0 . + ! BFUN basis-vector evaluated at SVAL . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: isel,ndof + real*8 , intent( in) :: sval + real*8 , intent(out) :: bfun(:) + + select case (isel) + case (-1) + !------------------------------------ -1th-order basis ! + select case (ndof) + case (+1) + bfun(1) = sval**1 / 1.e0 + + case (+2) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + + case (+3) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + bfun(3) = sval**3 / 3.e0 + + case (+4) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + bfun(3) = sval**3 / 3.e0 + bfun(4) = sval**4 / 4.e0 + + case (+5) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + bfun(3) = sval**3 / 3.e0 + bfun(4) = sval**4 / 4.e0 + bfun(5) = sval**5 / 5.e0 + + case (+6) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + bfun(3) = sval**3 / 3.e0 + bfun(4) = sval**4 / 4.e0 + bfun(5) = sval**5 / 5.e0 + bfun(6) = sval**6 / 6.e0 + + case (+7) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + bfun(3) = sval**3 / 3.e0 + bfun(4) = sval**4 / 4.e0 + bfun(5) = sval**5 / 5.e0 + bfun(6) = sval**6 / 6.e0 + bfun(7) = sval**7 / 7.e0 + + end select + + case (+0) + !------------------------------------ +0th-order basis ! + select case (ndof) + case (+1) + bfun(1) = 1.e0 + + case (+2) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + + case (+3) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + bfun(3) = sval**2 * 1.e0 + + case (+4) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + bfun(3) = sval**2 * 1.e0 + bfun(4) = sval**3 * 1.e0 + + case (+5) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + bfun(3) = sval**2 * 1.e0 + bfun(4) = sval**3 * 1.e0 + bfun(5) = sval**4 * 1.e0 + + case (+6) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + bfun(3) = sval**2 * 1.e0 + bfun(4) = sval**3 * 1.e0 + bfun(5) = sval**4 * 1.e0 + bfun(6) = sval**5 * 1.e0 + + case (+7) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + bfun(3) = sval**2 * 1.e0 + bfun(4) = sval**3 * 1.e0 + bfun(5) = sval**4 * 1.e0 + bfun(6) = sval**5 * 1.e0 + bfun(7) = sval**6 * 1.e0 + + end select + + case (+1) + !------------------------------------ +1st-order basis ! + select case (ndof) + case (+1) + bfun(1) = 0.e0 + + case (+2) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + + case (+3) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + bfun(3) = sval**1 * 2.e0 + + case (+4) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + bfun(3) = sval**1 * 2.e0 + bfun(4) = sval**2 * 3.e0 + + case (+5) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + bfun(3) = sval**1 * 2.e0 + bfun(4) = sval**2 * 3.e0 + bfun(5) = sval**3 * 4.e0 + + case (+6) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + bfun(3) = sval**1 * 2.e0 + bfun(4) = sval**2 * 3.e0 + bfun(5) = sval**3 * 4.e0 + bfun(6) = sval**4 * 5.e0 + + case (+7) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + bfun(3) = sval**1 * 2.e0 + bfun(4) = sval**2 * 3.e0 + bfun(5) = sval**3 * 4.e0 + bfun(6) = sval**4 * 5.e0 + bfun(7) = sval**5 * 6.e0 + + end select + + case (+2) + !------------------------------------ +2nd-order basis ! + select case (ndof) + case (+1) + bfun(1) = 0.e0 + + case (+2) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + + case (+3) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + bfun(3) = 2.e0 + + case (+4) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + bfun(3) = 2.e0 + bfun(4) = sval**1 * 6.e0 + + case (+5) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + bfun(3) = 2.e0 + bfun(4) = sval**1 * 6.e0 + bfun(5) = sval**2 *12.e0 + + case (+6) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + bfun(3) = 2.e0 + bfun(4) = sval**1 * 6.e0 + bfun(5) = sval**2 *12.e0 + bfun(6) = sval**3 *20.e0 + + case (+7) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + bfun(3) = 2.e0 + bfun(4) = sval**1 * 6.e0 + bfun(5) = sval**2 *12.e0 + bfun(6) = sval**3 *20.e0 + bfun(7) = sval**4 *30.e0 + + end select + + end select + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/c1d.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/c1d.mod new file mode 100644 index 0000000000000000000000000000000000000000..0b3c12fcba0714556b1b2b696c930d8c037460a1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/c1d.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/calendar.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/calendar.mod new file mode 100644 index 0000000000000000000000000000000000000000..04ecb24e269d1e44d9f0e20d9b234b769b744542 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/calendar.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/closea.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/closea.mod new file mode 100644 index 0000000000000000000000000000000000000000..09a6f11fe873c5b3a47d854d6453890da1ac1e53 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/closea.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/cpl_oasis3.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/cpl_oasis3.mod new file mode 100644 index 0000000000000000000000000000000000000000..318e64ab889f9a56a017e5635c53099f42d0a660 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/cpl_oasis3.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/crs.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crs.mod new file mode 100644 index 0000000000000000000000000000000000000000..1a4931a93f178cf4981dba2c11ce4e532d92ea37 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crs.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsdom.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsdom.mod new file mode 100644 index 0000000000000000000000000000000000000000..6e1d7e2b1f972768de395c0df783ed62e4deabcc Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsdom.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsdomwri.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsdomwri.mod new file mode 100644 index 0000000000000000000000000000000000000000..e9794712b3e1a65f7b01b8b29b2dcb48971f1d34 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsdomwri.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsfld.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsfld.mod new file mode 100644 index 0000000000000000000000000000000000000000..2d882990feb8f95e495ec4809df9e41eead52d61 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsfld.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsini.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsini.mod new file mode 100644 index 0000000000000000000000000000000000000000..22955e4b97d88a1550e5b39ff2c9f1f4c969eade Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crsini.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/crslbclnk.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crslbclnk.mod new file mode 100644 index 0000000000000000000000000000000000000000..feb94e6f570b292457d7bf25b57990f77bc5894d Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/crslbclnk.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/cyclone.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/cyclone.mod new file mode 100644 index 0000000000000000000000000000000000000000..cac083a9275cd39c76731fdf496665a875af6f8a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/cyclone.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/daymod.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/daymod.mod new file mode 100644 index 0000000000000000000000000000000000000000..28cc39fd944d30172b4b78ee36d183f8d8c14b4a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/daymod.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/ddatetoymdhms.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ddatetoymdhms.h90 new file mode 100644 index 0000000000000000000000000000000000000000..91a0b6e647db9f86b5be138ddd562de280a1a1d8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ddatetoymdhms.h90 @@ -0,0 +1,43 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ddatetoymdhms.h90 13226 2020-07-02 14:24:31Z orioltp $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE ddatetoymdhms( ddate, kyea, kmon, kday, khou, kmin, ksec ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE ddatetoymdhms *** + !! + !! ** Purpose : Convert YYYYMMDD.hhmmss to components + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + real(wp), INTENT(IN) :: ddate + INTEGER, INTENT(OUT) :: kyea + INTEGER, INTENT(OUT) :: kmon + INTEGER, INTENT(OUT) :: kday + INTEGER, INTENT(OUT) :: khou + INTEGER, INTENT(OUT) :: kmin + INTEGER, INTENT(OUT) :: ksec + !! * Local declarations + INTEGER :: iyymmdd + INTEGER :: ihhmmss + + iyymmdd = INT( ddate ) + ihhmmss = INT( ( ddate - iyymmdd ) * 1000000 ) + kyea = iyymmdd/10000 + kmon = iyymmdd / 100 - 100 * kyea + kday = MOD( iyymmdd, 100 ) + khou = ihhmmss/10000 + kmin = ihhmmss / 100 - 100 * khou + ksec = MOD( ihhmmss, 100 ) + + END SUBROUTINE ddatetoymdhms \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/defprec.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/defprec.mod new file mode 100644 index 0000000000000000000000000000000000000000..d28b69e160681dc6acf7e42bd1142ee20dab2cac Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/defprec.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/depth_e3.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/depth_e3.mod new file mode 100644 index 0000000000000000000000000000000000000000..324e050dbe48f06b82a3570d86fd64823729e239 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/depth_e3.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dia25h.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dia25h.mod new file mode 100644 index 0000000000000000000000000000000000000000..b01594fdbf70bd098bfd21d49fa9d71bbbbff2b9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dia25h.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diaar5.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diaar5.mod new file mode 100644 index 0000000000000000000000000000000000000000..c5481d755051c2cacf652dbbb59ce7e2d8c3e740 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diaar5.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diacfl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diacfl.mod new file mode 100644 index 0000000000000000000000000000000000000000..8856f1c17fd162e1feceb23626704f9bbc79eb11 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diacfl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diadct.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diadct.mod new file mode 100644 index 0000000000000000000000000000000000000000..290b9f7e4fd95add6dffd9076cc41595f82d2d07 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diadct.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diadetide.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diadetide.mod new file mode 100644 index 0000000000000000000000000000000000000000..954033f388a47c4dfe088197eaae90e51af0db47 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diadetide.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diahsb.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diahsb.mod new file mode 100644 index 0000000000000000000000000000000000000000..1aefe757499d532a06e3e9037c072609729edd94 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diahsb.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diahth.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diahth.mod new file mode 100644 index 0000000000000000000000000000000000000000..74655e6f11bbec568437d47a11fbabc398a706e1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diahth.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diamlr.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diamlr.mod new file mode 100644 index 0000000000000000000000000000000000000000..7b573cb1431230f9e4cd5bbb538a31910e603a8b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diamlr.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dianam.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dianam.mod new file mode 100644 index 0000000000000000000000000000000000000000..5e46e4d7d458a6fc76110c4b92786f540834bf26 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dianam.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diaobs.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diaobs.mod new file mode 100644 index 0000000000000000000000000000000000000000..5373e9226255edb277c77f700874fcacf319a403 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diaobs.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diaptr.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diaptr.mod new file mode 100644 index 0000000000000000000000000000000000000000..78235954624548883cf8ad687b7816b3d7384d8f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diaptr.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diawri.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diawri.mod new file mode 100644 index 0000000000000000000000000000000000000000..c798605f560d753a08f07725c495297edeec9067 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diawri.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diu_bulk.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diu_bulk.mod new file mode 100644 index 0000000000000000000000000000000000000000..0ce89a88913b9ad143b434331f87ed16ec13432b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diu_bulk.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diu_coolskin.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diu_coolskin.mod new file mode 100644 index 0000000000000000000000000000000000000000..72a73a6ad0d31fcb4aef665f36eda044df090cbb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diu_coolskin.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/diu_layers.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diu_layers.mod new file mode 100644 index 0000000000000000000000000000000000000000..04829b1d7221e80d713962c60ef1a038a18610fd Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/diu_layers.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/divhor.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/divhor.mod new file mode 100644 index 0000000000000000000000000000000000000000..d556de78fa80c68e02ae1e4bd66410178f9a54e5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/divhor.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/do_loop_substitute.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/do_loop_substitute.h90 new file mode 100644 index 0000000000000000000000000000000000000000..3fed3c5cf9cccfa62ff2702fabcafe382da51acd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/do_loop_substitute.h90 @@ -0,0 +1,80 @@ +#if defined show_comments +! These comments are not intended to be retained during preprocessing; i.e. do not define "show_comments" +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.x , NEMO Consortium (2020) +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +! This header file contains preprocessor definitions and macros used in the do-loop substitutions introduced +! between version 4.0 and 4.2. The primary aim of these macros is to assist in future applications of tiling +! to improve performance. This is expected to be achieved by alternative versions of these macros in selected +! locations. The initial introduction of these macros simply replaced all identifiable nested 2D- and 3D-loops +! with single line statements (and adjusts indenting accordingly). Do loops were identifiable if they comformed +! to either: +! DO jk = .... +! DO jj = .... DO jj = ... +! DO ji = .... DO ji = ... +! . OR . +! . . +! END DO END DO +! END DO END DO +! END DO +! and white-space variants thereof. +! +! Additionally, only loops with recognised jj and ji loops limits were treated; these were: +! Lower limits of 1, 2 or fs_2 +! Upper limits of jpi, jpim1 or fs_jpim1 (for ji) or jpj, jpjm1 or fs_jpjm1 (for jj) +! +! The macro naming convention takes the form: DO_2D( L, R, B, T) where: +! L is the Left offset from the PE's inner domain; +! R is the Right offset from the PE's inner domain +! B is the Bottom offset from the PE's inner domain; +! T is the Top offset from the PE's inner domain; +! +! So, given an inner domain of 2,jpim1 and 2,jpjm1, a typical example would replace: +! +! DO jj = 2, jpj +! DO ji = 1, jpim1 +! . +! . +! END DO +! END DO +! +! with: +! +! DO_2D( 1, 0, 0, 1 ) +! . +! . +! END_2D +! +! similar conventions apply to the 3D loops macros. jk loop limits are retained through macro arguments +! and are not restricted. This includes the possibility of strides for which an extra set of DO_3DS +! macros are defined. +! +! In the following definitions the inner PE domain is defined by start indices of (Nis0, Njs0) and end +! indices of (Nie0, Nje0) where: +! +! Nis0 = 1 + nn_hls Njs0 = 1 + nn_hls +! Nie0 = jpi - nn_hls Nje0 = jpj - nn_hls +! +#endif + +#define DO_2D(L, R, B, T) DO jj = ntsj-(B), ntej+(T) ; DO ji = ntsi-(L), ntei+(R) +#define DO_2D_OVR(L, R, B, T) DO_2D(L-(L+R)*nthl, R-(R+L)*nthr, B-(B+T)*nthb, T-(T+B)*ntht) +#define A1Di(H) ntsi-(H):ntei+(H) +#define A1Dj(H) ntsj-(H):ntej+(H) +#define A2D(H) A1Di(H),A1Dj(H) +#define A1Di_T(T) (ntsi-nn_hls-1)*T+1: +#define A1Dj_T(T) (ntsj-nn_hls-1)*T+1: +#define A2D_T(T) A1Di_T(T),A1Dj_T(T) +#define JPK : +#define JPTS : +#define KJPT : + +#define DO_3D(L, R, B, T, ks, ke) DO jk = ks, ke ; DO_2D(L, R, B, T) +#define DO_3D_OVR(L, R, B, T, ks, ke) DO jk = ks, ke ; DO_2D_OVR(L, R, B, T) + +#define DO_3DS(L, R, B, T, ks, ke, ki) DO jk = ks, ke, ki ; DO_2D(L, R, B, T) +#define DO_3DS_OVR(L, R, B, T, ks, ke, ki) DO jk = ks, ke, ki ; DO_2D_OVR(L, R, B, T) + +#define END_2D END DO ; END DO +#define END_3D END DO ; END DO ; END DO \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dom_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dom_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..83f01ff1aabbcefafefd482eeea052f0371e2364 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dom_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/domain.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domain.mod new file mode 100644 index 0000000000000000000000000000000000000000..df413a716b5cf79b7c4ecbe4a826e2079ba890b8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domain.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/domhgr.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domhgr.mod new file mode 100644 index 0000000000000000000000000000000000000000..e6dd84fba04f9189ade795eb2cf71fa73b8194bc Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domhgr.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dommsk.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dommsk.mod new file mode 100644 index 0000000000000000000000000000000000000000..cfdda1606fe9180529d225ce981c1dbe906ee999 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dommsk.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/domqco.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domqco.mod new file mode 100644 index 0000000000000000000000000000000000000000..d36cd72f0b217f41e7402e8844316d828a0328c9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domqco.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/domtile.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domtile.mod new file mode 100644 index 0000000000000000000000000000000000000000..b3b9750892dad468fb229789fd6c700b59ffea47 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domtile.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/domutl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domutl.mod new file mode 100644 index 0000000000000000000000000000000000000000..3ca0a9cd345ed1b122d5c6f8ea6df841b6b6dbc6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domutl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/domvvl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domvvl.mod new file mode 100644 index 0000000000000000000000000000000000000000..5f69e5b03a0500aab3d210010888a9877e40d7d8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domvvl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/domwri.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domwri.mod new file mode 100644 index 0000000000000000000000000000000000000000..89a435bcbb4001d4345a979252f21a93ffb1bd63 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domwri.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/domzgr.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domzgr.mod new file mode 100644 index 0000000000000000000000000000000000000000..e7c182c5fe5a8ffd5e2a979e39ea4b69c41df643 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domzgr.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/domzgr_substitute.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domzgr_substitute.h90 new file mode 100644 index 0000000000000000000000000000000000000000..a709e644c34a0b852bd63215ec29a0bb06216a03 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/domzgr_substitute.h90 @@ -0,0 +1,53 @@ +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +#if defined key_qco +# define e3t(i,j,k,t) (e3t_0(i,j,k)*(1._wp+r3t(i,j,t)*tmask(i,j,k))) +# define e3u(i,j,k,t) (e3u_0(i,j,k)*(1._wp+r3u(i,j,t)*umask(i,j,k))) +# define e3v(i,j,k,t) (e3v_0(i,j,k)*(1._wp+r3v(i,j,t)*vmask(i,j,k))) +# define e3f(i,j,k) (e3f_0(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k))) +# define e3f_vor(i,j,k) (e3f_0vor(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k))) +# define e3w(i,j,k,t) (e3w_0(i,j,k)*(1._wp+r3t(i,j,t))) +# define e3uw(i,j,k,t) (e3uw_0(i,j,k)*(1._wp+r3u(i,j,t))) +# define e3vw(i,j,k,t) (e3vw_0(i,j,k)*(1._wp+r3v(i,j,t))) +# define ht(i,j) (ht_0(i,j)*(1._wp+r3t(i,j,Kmm))) +# define hu(i,j,t) (hu_0(i,j)*(1._wp+r3u(i,j,t))) +# define hv(i,j,t) (hv_0(i,j)*(1._wp+r3v(i,j,t))) +# define r1_hu(i,j,t) (r1_hu_0(i,j)/(1._wp+r3u(i,j,t))) +# define r1_hv(i,j,t) (r1_hv_0(i,j)/(1._wp+r3v(i,j,t))) +# if defined key_isf +# define gdept(i,j,k,t) ((gdept_0(i,j,k)-risfdep(i,j))*(1._wp+r3t(i,j,t))+risfdep(i,j)) +# define gdepw(i,j,k,t) ((gdepw_0(i,j,k)-risfdep(i,j))*(1._wp+r3t(i,j,t))+risfdep(i,j)) +# else +# define gdept(i,j,k,t) (gdept_0(i,j,k)*(1._wp+r3t(i,j,t))) +# define gdepw(i,j,k,t) (gdepw_0(i,j,k)*(1._wp+r3t(i,j,t))) +# endif +# define gde3w(i,j,k) (gdept(i,j,k,Kmm)-ssh(i,j,Kmm)) +#elif defined key_linssh +# define e3t(i,j,k,t) e3t_0(i,j,k) +# define e3u(i,j,k,t) e3u_0(i,j,k) +# define e3v(i,j,k,t) e3v_0(i,j,k) +# define e3f(i,j,k) e3f_0(i,j,k) +# define e3f_vor(i,j,k) e3f_0vor(i,j,k) +# define e3w(i,j,k,t) e3w_0(i,j,k) +# define e3uw(i,j,k,t) e3uw_0(i,j,k) +# define e3vw(i,j,k,t) e3vw_0(i,j,k) +# define ht(i,j) ht_0(i,j) +# define hu(i,j,t) hu_0(i,j) +# define hv(i,j,t) hv_0(i,j) +# define r1_hu(i,j,t) r1_hu_0(i,j) +# define r1_hv(i,j,t) r1_hv_0(i,j) +# define gdept(i,j,k,t) gdept_0(i,j,k) +# define gdepw(i,j,k,t) gdepw_0(i,j,k) +# define gde3w(i,j,k) gdept_0(i,j,k) +#endif +!!---------------------------------------------------------------------- \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dtatsd.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dtatsd.mod new file mode 100644 index 0000000000000000000000000000000000000000..b63198284c9c0e51e9b2d727fe2f23e9c779199a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dtatsd.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dtauvd.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dtauvd.mod new file mode 100644 index 0000000000000000000000000000000000000000..250cd8632b7e1fdaa2116688211b8fe30a54c619 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dtauvd.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynadv.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynadv.mod new file mode 100644 index 0000000000000000000000000000000000000000..88501dc3711d50f86d031bb04d22198b7bd7b093 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynadv.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynadv_cen2.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynadv_cen2.mod new file mode 100644 index 0000000000000000000000000000000000000000..e36ad1e045adeedf1008e9a957c9b91ae55785de Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynadv_cen2.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynadv_ubs.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynadv_ubs.mod new file mode 100644 index 0000000000000000000000000000000000000000..0c1cd3abe7d4bfb365ab5301fe401e0eb87438c2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynadv_ubs.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynatf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynatf.mod new file mode 100644 index 0000000000000000000000000000000000000000..9baf1c5d45aa6e6c9af473f236fa9af92354ffa5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynatf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynatf_qco.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynatf_qco.mod new file mode 100644 index 0000000000000000000000000000000000000000..6bfbf1679e2f2fb52de474587cd95e9e872cf35b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynatf_qco.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dyndmp.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dyndmp.mod new file mode 100644 index 0000000000000000000000000000000000000000..f9af3dea08fb7f9e926f2a2710ee03f40507f0d7 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dyndmp.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynhpg.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynhpg.mod new file mode 100644 index 0000000000000000000000000000000000000000..5d8d7bcb49d79ce79fa5bcc9778eb18987ea6cc1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynhpg.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynkeg.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynkeg.mod new file mode 100644 index 0000000000000000000000000000000000000000..4db51f5a61cb421bd93240a5039f2e647939b4c6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynkeg.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf.mod new file mode 100644 index 0000000000000000000000000000000000000000..c25699a478dc9416efaf3a5813491d42fbc25325 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_iso.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_iso.mod new file mode 100644 index 0000000000000000000000000000000000000000..47f0bc4636fa6f675dfc84edf9cf3836b69b0d59 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_iso.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_iso_lf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_iso_lf.mod new file mode 100644 index 0000000000000000000000000000000000000000..2ad2ed3d9d7b220168ce022080a208dd8c31f4bc Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_iso_lf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_lap_blp.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_lap_blp.mod new file mode 100644 index 0000000000000000000000000000000000000000..edffc0d65951eee4a3d46a47eddc6ad7644b1a81 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_lap_blp.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_lap_blp_lf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_lap_blp_lf.mod new file mode 100644 index 0000000000000000000000000000000000000000..745dde735b3ad4177f6563c136661b327e655dd5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynldf_lap_blp_lf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynspg.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynspg.mod new file mode 100644 index 0000000000000000000000000000000000000000..b926c60d9eaef04086fd7072c26199264a09fbf4 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynspg.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynspg_exp.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynspg_exp.mod new file mode 100644 index 0000000000000000000000000000000000000000..1b34e544254b65c1a895523d5b4b914c9027844f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynspg_exp.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynspg_ts.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynspg_ts.mod new file mode 100644 index 0000000000000000000000000000000000000000..e87687aae4d5057c589e84faa4698552d9dbfe7d Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynspg_ts.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynvor.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynvor.mod new file mode 100644 index 0000000000000000000000000000000000000000..df7f8c8326f98bc98f3fdde6087b45ca99746be8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynvor.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynzad.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynzad.mod new file mode 100644 index 0000000000000000000000000000000000000000..ad2fa02420972a50d9619ea1aef1b20045e36a0e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynzad.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynzdf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynzdf.mod new file mode 100644 index 0000000000000000000000000000000000000000..bcc963e3b5c3a56bb8f2d6d281c5c89c5a88434b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/dynzdf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/eosbn2.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/eosbn2.mod new file mode 100644 index 0000000000000000000000000000000000000000..841ded864b538ecd5a5b657f4081ae95e245086e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/eosbn2.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/errioipsl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/errioipsl.mod new file mode 100644 index 0000000000000000000000000000000000000000..b015bd25f3b11ba4c3cfbb79655ac4c4ecbea6a3 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/errioipsl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/exampl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/exampl.mod new file mode 100644 index 0000000000000000000000000000000000000000..419faf6aba1b1b505d5e44eb530c3700ba51872a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/exampl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/ffsl1d.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ffsl1d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..c2a3d9fa438ce31622a1c4cf17391e5f4ee350b7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ffsl1d.h90 @@ -0,0 +1,331 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! FFSL1D.h90: upwind-biased flux-reconstruction scheme. + ! + ! Darren Engwirda + ! 31-Mar-2019 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine ffsl1d(npos,nvar,ndof,spac,tDEL, & + & mask,uvel,qbar,qedg,bclo, & + & bchi,work,opts) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! SPAC grid-cell spacing array. LENGTH(SPAC) == +1 if + ! spacing is uniform . + ! TDEL time-step . + ! MASK logical grid-cell masking array. + ! UVEL edge-centred velocity vectors. UVEL has SIZE = + ! NPOS-by-1 . + ! QBAR cell-centred integral moments. QBAR has SIZE = + ! NDOF-by-NVAR-by-NPOS-1 . + ! QEDG edge-centred upwind flux eval. QEDG has SIZE = + ! NVAR-by-NPOS . + ! BCLO boundary condition at lower endpoint . + ! BCHI boundary condition at upper endpoint . + ! WORK method work-space. See RCON-WORK for details . + ! OPTS method parameters. See RCON-OPTS for details . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,nvar,ndof + class(rmap_work), intent(inout):: work + class(rmap_opts), intent(inout):: opts + real*8 , intent(in) :: spac(:) + real*8 , intent(in) :: tDEL + logical, intent(in) :: mask(:) + real*8 , intent(in) :: qbar(:,:,:) + real*8 , intent(in) :: uvel(:) + real*8 , intent(out) :: qedg(:,:) + class(rcon_ends), intent(in) :: bclo(:) + class(rcon_ends), intent(in) :: bchi(:) + + !------------------------------------------- variables ! + integer :: head,tail,nprt + + head = +0 ; tail = +0 ; qedg = 0.e+0 + + do while (.true.) + + !--------------------------------- 1. find active part ! + + do head = tail+1, npos-1 + if (mask(head) .eqv..true.) exit + end do + + do tail = head+1, npos-1 + if (mask(tail).neqv..true.) exit + end do + tail = tail - 1 + + if (head.ge.npos) exit + + !--------------------------------- 2. rcon active part ! + + nprt = tail - head + 1 + + if (size(spac).ne.+1) then + + call rcon1d(nprt+1,nvar,ndof , & + & spac( head:tail), & + & qbar(:,:,head:tail), & + & bclo,bchi,work%cell_func, & + & work,opts ) + + else + + call rcon1d(nprt+1,nvar,ndof , & + & spac,qbar(:,:,head:tail), & + & bclo,bchi,work%cell_func, & + & work,opts ) + + end if + + !--------------------------------- 3. int. active part ! + + select case(opts%cell_meth) + case(pcm_method) !! 1st-order scheme + + if (size(spac).ne.+1) then + + call flux1d(nprt+1,nvar,1, & + & spac( head:tail+0) , & + & tDEL, & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + else + + call flux1d(nprt+1,nvar,1, & + & spac,tDEL , & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + end if + + case(plm_method) !! 2nd-order scheme + + if (size(spac).ne.+1) then + + call flux1d(nprt+1,nvar,2, & + & spac( head:tail+0) , & + & tDEL, & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + else + + call flux1d(nprt+1,nvar,2, & + & spac,tDEL , & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + end if + + case(ppm_method) !! 3rd-order scheme + + if (size(spac).ne.+1) then + + call flux1d(nprt+1,nvar,3, & + & spac( head:tail+0) , & + & tDEL, & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + else + + call flux1d(nprt+1,nvar,3, & + & spac,tDEL , & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + end if + + case(pqm_method) !! 5th-order scheme + + if (size(spac).ne.+1) then + + call flux1d(nprt+1,nvar,5, & + & spac( head:tail+0) , & + & tDEL, & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + else + + call flux1d(nprt+1,nvar,5, & + & spac,tDEL , & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + end if + + end select + + end do + + return + + end subroutine + + ! FLUX1D: a degree-k, upwind-type flux reconstruction. ! + + pure subroutine flux1d(npos,nvar,mdof,SPAC, & + & tDEL,uvel,QHAT,qedg) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! MDOF no. degrees-of-freedom per QHAT. + ! SPAC grid spacing vector. SIZE(SPAC)==+1 if uniform . + ! TDEL time-step . + ! UVEL edge-centred velocity vectors. UVEL has SIZE = + ! NPOS-by-1 . + ! QHAT cell-centred polynomial recon. QHAT has SIZE = + ! NDOF-by-NVAR-by-NPOS-1 . + ! QEDG edge-centred upwind flux eval. QEDG has SIZE = + ! NVAR-by-NPOS . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,nvar,mdof + real*8 , intent(in) :: SPAC(:) + real*8 , intent(in) :: tDEL + real*8 , intent(in) :: uvel(:) + real*8 , intent(in) :: QHAT(:,:,:) + real*8 , intent(out) :: qedg(:,:) + + !------------------------------------------- variables ! + integer :: ipos,ivar + real*8 :: uCFL,xhat,ss11,ss22,flux + real*8 :: vv11(1:5) + real*8 :: vv22(1:5) + real*8 :: ivec(1:5) + + !----------- single-cell, lagrangian-type upwind rcon. ! + + do ipos = +2 , npos - 1 + + if (uvel(ipos) .gt. +0.e0) then + + !----------- integrate profile over upwind cell IPOS-1 ! + + if (size(SPAC).ne.+1) then + xhat = .5d0 * SPAC(ipos-1) + uCFL = uvel(ipos) & + & * tDEL / SPAC(ipos-1) + else + xhat = .5d0 * SPAC( +1) + uCFL = uvel(ipos) & + & * tDEL / SPAC( +1) + end if + + ss11 = +1.e0 - 2.e0 * uCFL + ss22 = +1.e0 + + call bfun1d(-1,mdof,ss11,vv11) + call bfun1d(-1,mdof,ss22,vv22) + + ivec = vv22 - vv11 + + do ivar = +1, nvar + + flux = dot_product ( & + & ivec(1:mdof), & + & QHAT(1:mdof,ivar,ipos-1) ) + + flux = flux * xhat + + qedg(ivar,ipos) = flux + + end do + + else & + & if (uvel(ipos) .lt. -0.e0) then + + !----------- integrate profile over upwind cell IPOS+0 ! + + if (size(SPAC).ne.+1) then + xhat = .5d0 * SPAC(ipos-0) + uCFL = uvel(ipos) & + & * tDEL / SPAC(ipos-0) + else + xhat = .5d0 * SPAC( +1) + uCFL = uvel(ipos) & + & * tDEL / SPAC( +1) + end if + + ss11 = -1.e0 - 2.e0 * uCFL + ss22 = -1.e0 + + call bfun1d(-1,mdof,ss11,vv11) + call bfun1d(-1,mdof,ss22,vv22) + + ivec = vv22 - vv11 + + do ivar = +1, nvar + + flux = dot_product ( & + & ivec(1:mdof), & + & QHAT(1:mdof,ivar,ipos-0) ) + + flux = flux * xhat + + qedg(ivar,ipos) = flux + + end do + + end if + + end do + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/find_obs_proc.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/find_obs_proc.h90 new file mode 100644 index 0000000000000000000000000000000000000000..b947b17faa22a38277968548ba781ccc604af6b9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/find_obs_proc.h90 @@ -0,0 +1,60 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: find_obs_proc.h90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE find_obs_proc(kldi,klei,kldj,klej,kmyproc,kobsp,kobsi,kobsj,kno) + !!---------------------------------------------------------------------- + !! *** ROUTINE find_obs_proc *** + !! + !! ** Purpose : From the array kobsp containing the results of the grid + !! grid search on each processor the processor return a + !! decision of which processors should hold the observation. + !! + !! ** Method : Use i and j and halo regions to decide which processor to + !! put ob in. Intended to avoid the mpp calls required by + !! obs_mpp_find_obs_proc + !! + !! History : + !!! 03-08 (D. Lea) Original code + !!----------------------------------------------------------------------- + + !! * Arguments + + INTEGER, INTENT(IN) :: kldi ! Start of inner domain in i + INTEGER, INTENT(IN) :: klei ! End of inner domain in i + INTEGER, INTENT(IN) :: kldj ! Start of inner domain in j + INTEGER, INTENT(IN) :: klej ! End of inner domain in j + + INTEGER, INTENT(IN) :: kmyproc + INTEGER, INTENT(IN) :: kno + + INTEGER, DIMENSION(kno), INTENT(IN) :: kobsi + INTEGER, DIMENSION(kno), INTENT(IN) :: kobsj + INTEGER, DIMENSION(kno), INTENT(INOUT) :: kobsp + + !! * local variables + INTEGER :: & + & ji + + ! first and last indoor i- and j-indexes kldi, klei, kldj, klej + ! exclude any obs in the bottom-left overlap region + ! also any obs outside to whole region (defined by jpi and jpj) + ! I am assuming that kobsp does not need to be the correct processor + ! number + + DO ji = 1, kno + IF (kobsi(ji) < kldi .OR. kobsj(ji) < kldj & + .OR. kobsi(ji) > klei .OR. kobsj(ji) > klej) THEN + IF (lwp .AND. kobsp(ji) /= -1) WRITE(numout,*) & + & 'kobs: ',kobsi(ji), kobsj(ji), kobsp(ji) + kobsp(ji)=1000000 + ENDIF + END DO + + ! Ensure that observations not in processor are masked + + WHERE(kobsp(:) /= kmyproc) kobsp(:)=1000000 + + END SUBROUTINE find_obs_proc \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/fldread.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/fldread.mod new file mode 100644 index 0000000000000000000000000000000000000000..8aee2fea4f941518a5a7d00185c976c229f1db95 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/fldread.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/flincom.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/flincom.mod new file mode 100644 index 0000000000000000000000000000000000000000..5e8206575b74a2f5fb81aca5bea20eaafebd0fc6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/flincom.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/fliocom.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/fliocom.mod new file mode 100644 index 0000000000000000000000000000000000000000..726209e1a73d2dd40d812d0662f3004ed7658628 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/fliocom.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/flo4rk.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/flo4rk.mod new file mode 100644 index 0000000000000000000000000000000000000000..aa4a22d9635d88f5a3556324a81eac5df91ecc84 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/flo4rk.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/flo_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/flo_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..570dff659f43a35d791fabe3371abae096dd70b7 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/flo_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/floats.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/floats.mod new file mode 100644 index 0000000000000000000000000000000000000000..bc5f78af526b6f8bc33715fbadae13ee9d1b2646 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/floats.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/floblk.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/floblk.mod new file mode 100644 index 0000000000000000000000000000000000000000..6d81940088bac1a91bed2d0b3b8835896f4f2085 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/floblk.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/flodom.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/flodom.mod new file mode 100644 index 0000000000000000000000000000000000000000..567843499af48fea4bd56511d2c28e8affc9a0ae Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/flodom.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/florst.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/florst.mod new file mode 100644 index 0000000000000000000000000000000000000000..760c9a37e6e1b4d4f29e600908a38314006cdbef Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/florst.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/flowri.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/flowri.mod new file mode 100644 index 0000000000000000000000000000000000000000..b37e1f978b86a1976fa4d4891c7c639bde927446 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/flowri.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/geo2ocean.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/geo2ocean.mod new file mode 100644 index 0000000000000000000000000000000000000000..8e76a78bf0d32dc9df4e33d4b96078c74a76920f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/geo2ocean.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/getincom.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/getincom.mod new file mode 100644 index 0000000000000000000000000000000000000000..87626072b0599db39e39fe567feefe2d0f31602c Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/getincom.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/greg2jul.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/greg2jul.h90 new file mode 100644 index 0000000000000000000000000000000000000000..d815b0d36a67796abe53a99eef8df60e112eac98 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/greg2jul.h90 @@ -0,0 +1,89 @@ +SUBROUTINE greg2jul( ksec, kmin, khour, kday, kmonth, kyear, pjulian, & + & krefdate ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE greg2jul *** + !! + !! ** Purpose : Produce the time relative to the current date and time. + !! + !! ** Method : The units are days, so hours and minutes transform to + !! fractions of a day. + !! + !! Reference date : 19500101 + !! ** Action : + !! + !! History : + !! ! 06-04 (A. Vidard) Original + !! ! 06-04 (A. Vidard) Reformatted + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + ! * Arguments + INTEGER, INTENT(IN) :: & + & ksec, & + & kmin, & + & khour, & + & kday, & + & kmonth, & + & kyear + REAL(KIND=dp), INTENT(OUT) :: & + & pjulian + INTEGER, INTENT(IN), OPTIONAL :: & + & krefdate + + !! * Local declarations + INTEGER, PARAMETER :: & + & jpgreg = 15 + 31 * ( 10 + 12 * 1582 ), & ! Gregorian calendar introduction date + & jporef = 2433283, & ! Julian reference date: 19500101 + & jparef = 2415021, & ! Julian reference date: 19000101 + & jpgref = 2299161 ! Julian reference date start of Gregorian calender + INTEGER :: & + & ija, & + & ijy, & + & ijm, & + & ijultmp, & + & ijyear, & + & iref + CHARACTER(len=200) :: & + & cerr + + IF ( PRESENT( krefdate ) ) THEN + SELECT CASE ( krefdate ) + + CASE( 0 ) + iref = jpgref + + CASE( 19500101 ) + iref = jporef + + CASE( 19000101 ) + iref = jparef + + CASE DEFAULT + WRITE(cerr,'(A,I8.8)')'greg2jul: Unknown krefdate:', krefdate + CALL ctl_stop( cerr ) + + END SELECT + + ELSE + iref = jporef + ENDIF + + ! Main computation + ijyear = kyear + IF ( ijyear < 0 ) ijyear = ijyear + 1 + IF ( kmonth > 2 ) THEN + ijy = ijyear + ijm = kmonth + 1 + ELSE + ijy = ijyear - 1 + ijm = kmonth + 13 + ENDIF + ijultmp = INT( 365.25 * ijy ) + INT( 30.6001 * ijm ) + kday + 1720995 + IF ( kday + 31 * ( kmonth + 12 * ijyear ) >= jpgreg ) THEN + ija = INT( 0.01 * ijy ) + ijultmp = ijultmp + 2 - ija + INT( 0.25 * ija ) + ENDIF + pjulian = ( ijultmp - iref ) + ( ( 60 * khour + kmin ) * 60 + ksec ) / 86400. + + END SUBROUTINE greg2jul \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/grt_cir_dis.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/grt_cir_dis.h90 new file mode 100644 index 0000000000000000000000000000000000000000..c4ea5c224625559391c1cedaaffc26beb2d4d3be --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/grt_cir_dis.h90 @@ -0,0 +1,39 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: grt_cir_dis.h90 13226 2020-07-02 14:24:31Z orioltp $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION grt_cir_dis( pa1, pa2, pb1, pb2, pc1, pc2 ) + !!---------------------------------------------------------------------- + !! *** FUNCTION grt_cir_dis *** + !! + !! ** Purpose : Great circle distance between pts (lat1,lon1) + !! & (lat2,lon2) + !! + !! ** Method : Geometry. + !! + !! History : + !! ! 1995-12 (G. Madec, E. Durand, A. Weaver, N. Daget) Original + !! ! 2006-03 (A. Vidard) Migration to NEMOVAR + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pa1 ! sin(lat1) + REAL(KIND=wp) :: pa2 ! sin(lat2) + REAL(KIND=wp) :: pb1 ! cos(lat1) * cos(lon1) + REAL(KIND=wp) :: pb2 ! cos(lat2) * cos(lon2) + REAL(KIND=wp) :: pc1 ! cos(lat1) * sin(lon1) + REAL(KIND=wp) :: pc2 ! cos(lat2) * sin(lon2) + + REAL(KIND=wp) :: cosdist ! cosine of great circle distance + + ! Compute cosine of great circle distance, constraining it to be between + ! -1 and 1 (rounding errors can take it slightly outside this range + cosdist = MAX( MIN( pa1 * pa2 + pb1 * pb2 + pc1 * pc2, 1.0_wp), -1.0_wp ) + + grt_cir_dis = & + & ASIN( SQRT( 1.0_wp - cosdist**2.0_wp ) ) + + END FUNCTION grt_cir_dis \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/grt_cir_dis_saa.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/grt_cir_dis_saa.h90 new file mode 100644 index 0000000000000000000000000000000000000000..c76484a0a7c0ca91ff6b5bcdc89d2c2f3c6023ef --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/grt_cir_dis_saa.h90 @@ -0,0 +1,31 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: grt_cir_dis_saa.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION grt_cir_dis_saa( pa, pb, pc ) + !!---------------------------------------------------------------------- + !! *** FUNCTION grt_cir_dis_saa *** + !! + !! ** Purpose : Great circle distance between pts (lat1,lon1) + !! & (lat2,lon2) with a small-angle approximation + !! + !! ** Method : Geometry + !! + !! ** Action : + !! + !! History + !! ! 95-12 (G. Madec, E. Durand, A. Weaver, N. Daget) Original + !! ! 06-03 (A. Vidard) Migration to NEMOVAR + !! ! 06-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pa ! lon1 - lon2 + REAL(KIND=wp) :: pb ! lat1 - lat2 + REAL(KIND=wp) :: pc ! cos(lat2) + + grt_cir_dis_saa = SQRT( pa * pa + ( pb * pc )**2 ) + + END FUNCTION grt_cir_dis_saa \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/halo_mng.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/halo_mng.mod new file mode 100644 index 0000000000000000000000000000000000000000..75a2c8e9b7d94261b99323414ada7f9fac426895 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/halo_mng.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/histcom.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/histcom.mod new file mode 100644 index 0000000000000000000000000000000000000000..706415a816a2cf5fcdeaad25761b80fbb41f4d46 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/histcom.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/icb_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icb_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..c7868ccc6524de107dea29a96b32601071720934 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icb_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbclv.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbclv.mod new file mode 100644 index 0000000000000000000000000000000000000000..101c8c7ed1d9a4fb1c210371dd7ca8720c832181 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbclv.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbdia.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbdia.mod new file mode 100644 index 0000000000000000000000000000000000000000..a7f6ada40b8b6c5c6511e38307c0b6efe6c7e020 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbdia.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbdyn.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbdyn.mod new file mode 100644 index 0000000000000000000000000000000000000000..c143bcc2bb5c6b4fc08d7a7a8c2bc0d63a9c5e83 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbdyn.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbini.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbini.mod new file mode 100644 index 0000000000000000000000000000000000000000..d2633932949cabc634ac27012fde3f118fe61d78 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbini.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/icblbc.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icblbc.mod new file mode 100644 index 0000000000000000000000000000000000000000..a9dc0e43e5801c9ffe7b0d25cc02a4833af81cd2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icblbc.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbrst.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbrst.mod new file mode 100644 index 0000000000000000000000000000000000000000..d1e3e9862829bca7425516488653780928d29f80 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbrst.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbstp.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbstp.mod new file mode 100644 index 0000000000000000000000000000000000000000..ab9033225dba31c8056fdb007d0d9284f213b6ff Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbstp.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbthm.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbthm.mod new file mode 100644 index 0000000000000000000000000000000000000000..340f5b092ff312e24d635712252f43d745512de9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbthm.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbtrj.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbtrj.mod new file mode 100644 index 0000000000000000000000000000000000000000..2885657f00fdcec31e04728320494b096b575882 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbtrj.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbutl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbutl.mod new file mode 100644 index 0000000000000000000000000000000000000000..e949950dbdb004c713e6508d1e17812fe62f6f6e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/icbutl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/in_out_manager.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/in_out_manager.mod new file mode 100644 index 0000000000000000000000000000000000000000..ec7f3c06bc2b70790737c789fdf28b67e790284e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/in_out_manager.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/inv.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/inv.h90 new file mode 100644 index 0000000000000000000000000000000000000000..daceabb9a808cc6348e29c44604b21daedda93e4 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/inv.h90 @@ -0,0 +1,801 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! INV.h90: block-wise solution of small linear systems. + ! + ! Darren Engwirda + ! 25-Mar-2019 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine inv_2x2(amat,adim,ainv,vdim, & + & adet) + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: adim + real*8 , intent( in) :: amat(adim,*) + integer, intent( in) :: vdim + real*8 , intent(out) :: ainv(vdim,*) + real*8 , intent(out) :: adet + + !------------------------------------------- form A^-1 ! + + adet = amat(1,1) * amat(2,2) & + - amat(1,2) * amat(2,1) + + ainv(1,1) = amat(2,2) + ainv(1,2) = - amat(1,2) + ainv(2,1) = - amat(2,1) + ainv(2,2) = amat(1,1) + + return + + end subroutine + + pure subroutine inv_3x3(amat,adim,ainv,vdim, & + & adet) + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: adim + real*8 , intent( in) :: amat(adim,*) + integer, intent( in) :: vdim + real*8 , intent(out) :: ainv(vdim,*) + real*8 , intent(out) :: adet + + !------------------------------------------- variables ! + real*8 :: & + aa2233,aa2332,aa2133,aa2331,aa2132,& + aa2231,aa1233,aa1332,aa1223,aa1322,& + aa1133,aa1331,aa1123,aa1321,aa1132,& + aa1231,aa1122,aa1221 + + !------------------------------------------- form A^-1 ! + + aa2233 = amat(2,2) * amat(3,3) + aa2332 = amat(2,3) * amat(3,2) + aa2133 = amat(2,1) * amat(3,3) + aa2331 = amat(2,3) * amat(3,1) + aa2132 = amat(2,1) * amat(3,2) + aa2231 = amat(2,2) * amat(3,1) + + adet = & + amat(1,1) * (aa2233 - aa2332) - & + amat(1,2) * (aa2133 - aa2331) + & + amat(1,3) * (aa2132 - aa2231) + + aa1233 = amat(1,2) * amat(3,3) + aa1332 = amat(1,3) * amat(3,2) + aa1223 = amat(1,2) * amat(2,3) + aa1322 = amat(1,3) * amat(2,2) + aa1133 = amat(1,1) * amat(3,3) + aa1331 = amat(1,3) * amat(3,1) + aa1123 = amat(1,1) * amat(2,3) + aa1321 = amat(1,3) * amat(2,1) + aa1132 = amat(1,1) * amat(3,2) + aa1231 = amat(1,2) * amat(3,1) + aa1122 = amat(1,1) * amat(2,2) + aa1221 = amat(1,2) * amat(2,1) + + ainv(1,1) = (aa2233 - aa2332) + ainv(1,2) = -(aa1233 - aa1332) + ainv(1,3) = (aa1223 - aa1322) + + ainv(2,1) = -(aa2133 - aa2331) + ainv(2,2) = (aa1133 - aa1331) + ainv(2,3) = -(aa1123 - aa1321) + + ainv(3,1) = (aa2132 - aa2231) + ainv(3,2) = -(aa1132 - aa1231) + ainv(3,3) = (aa1122 - aa1221) + + return + + end subroutine + + pure subroutine mul_2x2(amat,adim,bmat,bdim, & + & scal,cmat,cdim) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: bdim + real*8 , intent(in) :: bmat(bdim,*) + real*8 , intent(in) :: scal + integer, intent(in) :: cdim + real*8 , intent(inout) :: cmat(cdim,*) + + !-------------------------------- C = C + scal * A * B ! + + if (scal .eq. +1.e0) then + + cmat(1,1) = cmat(1,1) & + + ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) ) + cmat(2,1) = cmat(2,1) & + + ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) ) + + cmat(1,2) = cmat(1,2) & + + ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) ) + cmat(2,2) = cmat(2,2) & + + ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) ) + + else & + if (scal .eq. -1.e0) then + + cmat(1,1) = cmat(1,1) & + - ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) ) + cmat(2,1) = cmat(2,1) & + - ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) ) + + cmat(1,2) = cmat(1,2) & + - ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) ) + cmat(2,2) = cmat(2,2) & + - ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) ) + + else + + cmat(1,1) = cmat(1,1) + & + scal * ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) ) + cmat(2,1) = cmat(2,1) + & + scal * ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) ) + + cmat(1,2) = cmat(1,2) + & + scal * ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) ) + cmat(2,2) = cmat(2,2) + & + scal * ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) ) + + end if + + return + + end subroutine + + pure subroutine mul_3x3(amat,adim,bmat,bdim, & + & scal,cmat,cdim) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: bdim + real*8 , intent(in) :: bmat(bdim,*) + real*8 , intent(in) :: scal + integer, intent(in) :: cdim + real*8 , intent(inout) :: cmat(cdim,*) + + !-------------------------------- C = C + scal * A * B ! + + if (scal .eq. +1.e0) then + + cmat(1,1) = cmat(1,1) & + + ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) & + + amat(1,3) * bmat(3,1) ) + cmat(2,1) = cmat(2,1) & + + ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) & + + amat(2,3) * bmat(3,1) ) + cmat(3,1) = cmat(3,1) & + + ( amat(3,1) * bmat(1,1) & + + amat(3,2) * bmat(2,1) & + + amat(3,3) * bmat(3,1) ) + + cmat(1,2) = cmat(1,2) & + + ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) & + + amat(1,3) * bmat(3,2) ) + cmat(2,2) = cmat(2,2) & + + ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) & + + amat(2,3) * bmat(3,2) ) + cmat(3,2) = cmat(3,2) & + + ( amat(3,1) * bmat(1,2) & + + amat(3,2) * bmat(2,2) & + + amat(3,3) * bmat(3,2) ) + + cmat(1,3) = cmat(1,3) & + + ( amat(1,1) * bmat(1,3) & + + amat(1,2) * bmat(2,3) & + + amat(1,3) * bmat(3,3) ) + cmat(2,3) = cmat(2,3) & + + ( amat(2,1) * bmat(1,3) & + + amat(2,2) * bmat(2,3) & + + amat(2,3) * bmat(3,3) ) + cmat(3,3) = cmat(3,3) & + + ( amat(3,1) * bmat(1,3) & + + amat(3,2) * bmat(2,3) & + + amat(3,3) * bmat(3,3) ) + + else & + if (scal .eq. -1.e0) then + + cmat(1,1) = cmat(1,1) & + - ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) & + + amat(1,3) * bmat(3,1) ) + cmat(2,1) = cmat(2,1) & + - ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) & + + amat(2,3) * bmat(3,1) ) + cmat(3,1) = cmat(3,1) & + - ( amat(3,1) * bmat(1,1) & + + amat(3,2) * bmat(2,1) & + + amat(3,3) * bmat(3,1) ) + + cmat(1,2) = cmat(1,2) & + - ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) & + + amat(1,3) * bmat(3,2) ) + cmat(2,2) = cmat(2,2) & + - ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) & + + amat(2,3) * bmat(3,2) ) + cmat(3,2) = cmat(3,2) & + - ( amat(3,1) * bmat(1,2) & + + amat(3,2) * bmat(2,2) & + + amat(3,3) * bmat(3,2) ) + + cmat(1,3) = cmat(1,3) & + - ( amat(1,1) * bmat(1,3) & + + amat(1,2) * bmat(2,3) & + + amat(1,3) * bmat(3,3) ) + cmat(2,3) = cmat(2,3) & + - ( amat(2,1) * bmat(1,3) & + + amat(2,2) * bmat(2,3) & + + amat(2,3) * bmat(3,3) ) + cmat(3,3) = cmat(3,3) & + - ( amat(3,1) * bmat(1,3) & + + amat(3,2) * bmat(2,3) & + + amat(3,3) * bmat(3,3) ) + + else + + cmat(1,1) = cmat(1,1) + & + scal * ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) & + + amat(1,3) * bmat(3,1) ) + cmat(2,1) = cmat(2,1) + & + scal * ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) & + + amat(2,3) * bmat(3,1) ) + cmat(3,1) = cmat(3,1) + & + scal * ( amat(3,1) * bmat(1,1) & + + amat(3,2) * bmat(2,1) & + + amat(3,3) * bmat(3,1) ) + + cmat(1,2) = cmat(1,2) + & + scal * ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) & + + amat(1,3) * bmat(3,2) ) + cmat(2,2) = cmat(2,2) + & + scal * ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) & + + amat(2,3) * bmat(3,2) ) + cmat(3,2) = cmat(3,2) + & + scal * ( amat(3,1) * bmat(1,2) & + + amat(3,2) * bmat(2,2) & + + amat(3,3) * bmat(3,2) ) + + cmat(1,3) = cmat(1,3) + & + scal * ( amat(1,1) * bmat(1,3) & + + amat(1,2) * bmat(2,3) & + + amat(1,3) * bmat(3,3) ) + cmat(2,3) = cmat(2,3) + & + scal * ( amat(2,1) * bmat(1,3) & + + amat(2,2) * bmat(2,3) & + + amat(2,3) * bmat(3,3) ) + cmat(3,3) = cmat(3,3) + & + scal * ( amat(3,1) * bmat(1,3) & + + amat(3,2) * bmat(2,3) & + + amat(3,3) * bmat(3,3) ) + + end if + + return + + end subroutine + + pure subroutine slv_2x2(amat,adim,vrhs,vdim, & + & nrhs,fEPS,okay) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: vdim + real*8 , intent(inout) :: vrhs(vdim,*) + integer, intent(in) :: nrhs + real*8 , intent(in) :: fEPS + logical, intent(inout) :: okay + + !------------------------------------------- variables ! + real*8 :: ainv(2,2) + real*8 :: adet + real*8 :: vtmp( 2) + integer :: irhs + + integer, parameter :: LDIM = 2 + + !---------------------------------------- calc. inv(A) ! + + call inv_2x2(amat,adim,ainv,LDIM,& + adet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !---------------------------------------- v = A^-1 * v ! + + do irhs = 1, nrhs + + vtmp(1) = & + + ( & + ainv(1, 1) * vrhs(1,irhs) & + + ainv(1, 2) * vrhs(2,irhs) & + ) / adet + + vtmp(2) = & + + ( & + ainv(2, 1) * vrhs(1,irhs) & + + ainv(2, 2) * vrhs(2,irhs) & + ) / adet + + vrhs(1,irhs) = vtmp(1) + vrhs(2,irhs) = vtmp(2) + + end do + + return + + end subroutine + + pure subroutine slv_3x3(amat,adim,vrhs,vdim, & + & nrhs,fEPS,okay) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: vdim + real*8 , intent(inout) :: vrhs(vdim,*) + integer, intent(in) :: nrhs + real*8 , intent(in) :: fEPS + logical, intent(inout) :: okay + + !------------------------------------------- variables ! + real*8 :: ainv(3,3) + real*8 :: adet + real*8 :: vtmp( 3) + integer :: irhs + + integer, parameter :: LDIM = 3 + + !---------------------------------------- calc. inv(A) ! + + call inv_3x3(amat,adim,ainv,LDIM,& + adet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !---------------------------------------- v = A^-1 * v ! + + do irhs = 1, nrhs + + vtmp(1) = & + + ( & + ainv(1, 1) * vrhs(1,irhs) & + + ainv(1, 2) * vrhs(2,irhs) & + + ainv(1, 3) * vrhs(3,irhs) & + ) / adet + + vtmp(2) = & + + ( & + ainv(2, 1) * vrhs(1,irhs) & + + ainv(2, 2) * vrhs(2,irhs) & + + ainv(2, 3) * vrhs(3,irhs) & + ) / adet + + vtmp(3) = & + + ( & + ainv(3, 1) * vrhs(1,irhs) & + + ainv(3, 2) * vrhs(2,irhs) & + + ainv(3, 3) * vrhs(3,irhs) & + ) / adet + + vrhs(1,irhs) = vtmp(1) + vrhs(2,irhs) = vtmp(2) + vrhs(3,irhs) = vtmp(3) + + end do + + return + + end subroutine + + pure subroutine slv_4x4(amat,adim,vrhs,vdim, & + & nrhs,fEPS,okay) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: vdim + real*8 , intent(inout) :: vrhs(vdim,*) + integer, intent(in) :: nrhs + real*8 , intent(in) :: fEPS + logical, intent(inout) :: okay + + !------------------------------------------- variables ! + real*8 :: ainv(2,2) + real*8 :: lmat(2,2) + real*8 :: umat(2,2) + real*8 :: smat(2,2) + real*8 :: sinv(2,2) + real*8 :: adet,sdet + real*8 :: vtmp( 2) + integer :: irhs + + integer, parameter :: LDIM = 2 + + !---------------------- form a block LDU factorisation ! + + call inv_2x2(amat(1,1),adim,ainv,LDIM, & + adet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !---------------------------------------- L = C * A^-1 ! + + lmat(1,1) = +0.e0 + lmat(1,2) = +0.e0 + lmat(2,1) = +0.e0 + lmat(2,2) = +0.e0 + + call mul_2x2(amat(3,1),adim,ainv,LDIM, & + +1.e0,lmat,LDIM) + + !---------------------------------------- U = A^-1 * B ! + + umat(1,1) = +0.e0 + umat(1,2) = +0.e0 + umat(2,1) = +0.e0 + umat(2,2) = +0.e0 + + call mul_2x2(ainv,LDIM,amat(1,3),adim, & + +1.e0,umat,LDIM) + + !-------------------------------- S = D - C * A^-1 * B ! + + smat(1,1) = amat(3,3) + smat(1,2) = amat(3,4) + smat(2,1) = amat(4,3) + smat(2,2) = amat(4,4) + + call mul_2x2(lmat,LDIM,amat(1,3),adim, & + -1.e0/adet,smat,LDIM) + + call inv_2x2(smat,LDIM,sinv,LDIM,sdet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !-------------------------------- back-solve LDU = rhs ! + + do irhs = 1, nrhs + + !---------------------------------------- solve L part ! + + vrhs(3,irhs) = vrhs(3,irhs) & + - ( & + lmat(1, 1) * vrhs(1,irhs) & + + lmat(1, 2) * vrhs(2,irhs) & + ) / adet + + vrhs(4,irhs) = vrhs(4,irhs) & + - ( & + lmat(2, 1) * vrhs(1,irhs) & + + lmat(2, 2) * vrhs(2,irhs) & + ) / adet + + !---------------------------------------- solve D part ! + + vtmp(1) = & + + ( & + ainv(1, 1) * vrhs(1,irhs) & + + ainv(1, 2) * vrhs(2,irhs) & + ) / adet + + vtmp(2) = & + + ( & + ainv(2, 1) * vrhs(1,irhs) & + + ainv(2, 2) * vrhs(2,irhs) & + ) / adet + + vrhs(1,irhs) = vtmp(1) + vrhs(2,irhs) = vtmp(2) + + vtmp(1) = & + + ( & + sinv(1, 1) * vrhs(3,irhs) & + + sinv(1, 2) * vrhs(4,irhs) & + ) / sdet + + vtmp(2) = & + + ( & + sinv(2, 1) * vrhs(3,irhs) & + + sinv(2, 2) * vrhs(4,irhs) & + ) / sdet + + vrhs(3,irhs) = vtmp(1) + vrhs(4,irhs) = vtmp(2) + + !---------------------------------------- solve U part ! + + vrhs(1,irhs) = vrhs(1,irhs) & + - ( & + umat(1, 1) * vrhs(3,irhs) & + + umat(1, 2) * vrhs(4,irhs) & + ) / adet + + vrhs(2,irhs) = vrhs(2,irhs) & + - ( & + umat(2, 1) * vrhs(3,irhs) & + + umat(2, 2) * vrhs(4,irhs) & + ) / adet + + end do + + return + + end subroutine + + pure subroutine slv_6x6(amat,adim,vrhs,vdim, & + & nrhs,fEPS,okay) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: vdim + real*8 , intent(inout) :: vrhs(vdim,*) + integer, intent(in) :: nrhs + real*8 , intent(in) :: fEPS + logical, intent(inout) :: okay + + !------------------------------------------- variables ! + real*8 :: ainv(3,3) + real*8 :: lmat(3,3) + real*8 :: umat(3,3) + real*8 :: smat(3,3) + real*8 :: sinv(3,3) + real*8 :: adet,sdet + real*8 :: vtmp( 3) + integer :: irhs + + integer, parameter :: LDIM = 3 + + !---------------------- form a block LDU factorisation ! + + call inv_3x3(amat(1,1),adim,ainv,LDIM, & + adet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !---------------------------------------- L = C * A^-1 ! + + lmat(1,1) = +0.e0 + lmat(1,2) = +0.e0 + lmat(1,3) = +0.e0 + lmat(2,1) = +0.e0 + lmat(2,2) = +0.e0 + lmat(2,3) = +0.e0 + lmat(3,1) = +0.e0 + lmat(3,2) = +0.e0 + lmat(3,3) = +0.e0 + + call mul_3x3(amat(4,1),adim,ainv,LDIM, & + +1.e0,lmat,LDIM) + + !---------------------------------------- U = A^-1 * B ! + + umat(1,1) = +0.e0 + umat(1,2) = +0.e0 + umat(1,3) = +0.e0 + umat(2,1) = +0.e0 + umat(2,2) = +0.e0 + umat(2,3) = +0.e0 + umat(3,1) = +0.e0 + umat(3,2) = +0.e0 + umat(3,3) = +0.e0 + + call mul_3x3(ainv,LDIM,amat(1,4),adim, & + +1.e0,umat,LDIM) + + !-------------------------------- S = D - C * A^-1 * B ! + + smat(1,1) = amat(4,4) + smat(1,2) = amat(4,5) + smat(1,3) = amat(4,6) + smat(2,1) = amat(5,4) + smat(2,2) = amat(5,5) + smat(2,3) = amat(5,6) + smat(3,1) = amat(6,4) + smat(3,2) = amat(6,5) + smat(3,3) = amat(6,6) + + call mul_3x3(lmat,LDIM,amat(1,4),adim, & + -1.e0/adet,smat,LDIM) + + call inv_3x3(smat,LDIM,sinv,LDIM,sdet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !-------------------------------- back-solve LDU = rhs ! + + do irhs = 1, nrhs + + !---------------------------------------- solve L part ! + + vrhs(4,irhs) = vrhs(4,irhs) & + - ( & + lmat(1, 1) * vrhs(1,irhs) & + + lmat(1, 2) * vrhs(2,irhs) & + + lmat(1, 3) * vrhs(3,irhs) & + ) / adet + + vrhs(5,irhs) = vrhs(5,irhs) & + - ( & + lmat(2, 1) * vrhs(1,irhs) & + + lmat(2, 2) * vrhs(2,irhs) & + + lmat(2, 3) * vrhs(3,irhs) & + ) / adet + + vrhs(6,irhs) = vrhs(6,irhs) & + - ( & + lmat(3, 1) * vrhs(1,irhs) & + + lmat(3, 2) * vrhs(2,irhs) & + + lmat(3, 3) * vrhs(3,irhs) & + ) / adet + + !---------------------------------------- solve D part ! + + vtmp(1) = & + + ( & + ainv(1, 1) * vrhs(1,irhs) & + + ainv(1, 2) * vrhs(2,irhs) & + + ainv(1, 3) * vrhs(3,irhs) & + ) / adet + + vtmp(2) = & + + ( & + ainv(2, 1) * vrhs(1,irhs) & + + ainv(2, 2) * vrhs(2,irhs) & + + ainv(2, 3) * vrhs(3,irhs) & + ) / adet + + vtmp(3) = & + + ( & + ainv(3, 1) * vrhs(1,irhs) & + + ainv(3, 2) * vrhs(2,irhs) & + + ainv(3, 3) * vrhs(3,irhs) & + ) / adet + + vrhs(1,irhs) = vtmp(1) + vrhs(2,irhs) = vtmp(2) + vrhs(3,irhs) = vtmp(3) + + vtmp(1) = & + + ( & + sinv(1, 1) * vrhs(4,irhs) & + + sinv(1, 2) * vrhs(5,irhs) & + + sinv(1, 3) * vrhs(6,irhs) & + ) / sdet + + vtmp(2) = & + + ( & + sinv(2, 1) * vrhs(4,irhs) & + + sinv(2, 2) * vrhs(5,irhs) & + + sinv(2, 3) * vrhs(6,irhs) & + ) / sdet + + vtmp(3) = & + + ( & + sinv(3, 1) * vrhs(4,irhs) & + + sinv(3, 2) * vrhs(5,irhs) & + + sinv(3, 3) * vrhs(6,irhs) & + ) / sdet + + vrhs(4,irhs) = vtmp(1) + vrhs(5,irhs) = vtmp(2) + vrhs(6,irhs) = vtmp(3) + + !---------------------------------------- solve U part ! + + vrhs(1,irhs) = vrhs(1,irhs) & + - ( & + umat(1, 1) * vrhs(4,irhs) & + + umat(1, 2) * vrhs(5,irhs) & + + umat(1, 3) * vrhs(6,irhs) & + ) / adet + + vrhs(2,irhs) = vrhs(2,irhs) & + - ( & + umat(2, 1) * vrhs(4,irhs) & + + umat(2, 2) * vrhs(5,irhs) & + + umat(2, 3) * vrhs(6,irhs) & + ) / adet + + vrhs(3,irhs) = vrhs(3,irhs) & + - ( & + umat(3, 1) * vrhs(4,irhs) & + + umat(3, 2) * vrhs(5,irhs) & + + umat(3, 3) * vrhs(6,irhs) & + ) / adet + + end do + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/ioipsl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ioipsl.mod new file mode 100644 index 0000000000000000000000000000000000000000..3ba7894c2910ace391f7cc09e2f3c48eb3a0c269 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ioipsl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/iom.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/iom.mod new file mode 100644 index 0000000000000000000000000000000000000000..6f8dfb89ac00e91ccc51e3c5895f4bf647c50f88 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/iom.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/iom_def.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/iom_def.mod new file mode 100644 index 0000000000000000000000000000000000000000..ff4ea1b7e6e9d06a2316def91fb739cfe5ad662b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/iom_def.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/iom_nf90.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/iom_nf90.mod new file mode 100644 index 0000000000000000000000000000000000000000..ee8188a4958d8f03000ae50548ff08c09f4202a4 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/iom_nf90.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isf_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isf_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..253911bff359967bd3deee7890586eea6b5a2fc2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isf_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcav.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcav.mod new file mode 100644 index 0000000000000000000000000000000000000000..4f83da58d1c75402a9f9f09350213bc01f7f37c3 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcav.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcavgam.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcavgam.mod new file mode 100644 index 0000000000000000000000000000000000000000..214c05f61e190e183d0d273128037d086d19f3ba Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcavgam.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcavmlt.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcavmlt.mod new file mode 100644 index 0000000000000000000000000000000000000000..78f52b40c0ac7cf6f35d6e8c80dad7b58274712f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcavmlt.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcpl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcpl.mod new file mode 100644 index 0000000000000000000000000000000000000000..959d6a7f4e6b9a7d2464dbb38d784399afe82e37 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfcpl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfdiags.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfdiags.mod new file mode 100644 index 0000000000000000000000000000000000000000..728510977a57a76911e37a0a378400f9c092f1ac Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfdiags.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfdynatf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfdynatf.mod new file mode 100644 index 0000000000000000000000000000000000000000..11a3242f0a94bbc8ec51e4dbe144e4711708561f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfdynatf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfhdiv.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfhdiv.mod new file mode 100644 index 0000000000000000000000000000000000000000..0d28eb2e1dfb4cf24c4a156472a64feffcf25f94 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfhdiv.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfload.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfload.mod new file mode 100644 index 0000000000000000000000000000000000000000..3fba6f8947329f2fa55e4481df9908ec3084d6c5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfload.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfpar.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfpar.mod new file mode 100644 index 0000000000000000000000000000000000000000..fd4a25d22a8286ef2c5d5155b7b6d429b1cc36a4 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfpar.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfparmlt.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfparmlt.mod new file mode 100644 index 0000000000000000000000000000000000000000..7f80addd2ee84390f70d43cf014846ce9d65b809 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfparmlt.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfrst.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfrst.mod new file mode 100644 index 0000000000000000000000000000000000000000..d015810ff76a8f366fe345c958f651615c3feed9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfrst.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfstp.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfstp.mod new file mode 100644 index 0000000000000000000000000000000000000000..1cdbac516f2a73d1b06bdb462fe2e9efe1a28b09 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfstp.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isftbl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isftbl.mod new file mode 100644 index 0000000000000000000000000000000000000000..6588e02e85f3bafdce822bc46dfb8fa455e2760b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isftbl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfutils.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfutils.mod new file mode 100644 index 0000000000000000000000000000000000000000..a9ccea46770ad01ece2a183e29282acce39f096e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/isfutils.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/istate.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/istate.mod new file mode 100644 index 0000000000000000000000000000000000000000..0ceaad1eafb59815068ccedb010b0e140079fcfd Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/istate.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/jul2greg.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/jul2greg.h90 new file mode 100644 index 0000000000000000000000000000000000000000..f7087c95214e1f09409aeaee69a8d1cb683b565e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/jul2greg.h90 @@ -0,0 +1,115 @@ +RECURSIVE SUBROUTINE jul2greg( ksec, kminut, khour, kday, kmonth, kyear, & + & prelday, krefdate ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE jul2greg *** + !! + !! ** Purpose : Take the relative time in days and re-express in terms of + !! seconds, minutes, hours, days, month, year. + !! + !! ** Method : Reference date : 19500101 + !! + !! ** Action : + !! + !! History + !! ! 06-04 (A. Vidard) Original + !! ! 06-05 (A. Vidard) Reformatted and refdate + !! ! 06-10 (A. Weaver) Cleanup + !! ! 2014-09 (D. Lea) Change to use FLOOR to deal with negative prelday + !!----------------------------------------------------------------------- + + ! * Arguments + INTEGER, INTENT(IN), OPTIONAL :: & + & krefdate + INTEGER, INTENT(OUT) :: & + & ksec, & + & kminut, & + & khour, & + & kday, & + & kmonth, & + & kyear + REAL(KIND=dp), INTENT(IN) :: & + & prelday + + !! * Local declarations + INTEGER, PARAMETER :: & + & jpgreg = 2299161, & + & jporef = 2433283, & + & jparef = 2415021 + INTEGER :: & + & ijulian, & + & ij1, & + & ija, & + & ijb, & + & ijc, & + & ijd, & + & ije, & + & isec, & + & imin, & + & ihou, & + & iday, & + & imon, & + & iyea, & + & iref + REAL(KIND=wp) :: & + & zday, & + & zref + CHARACTER(len=200) :: & + & cerr + + ! Main computation + IF ( PRESENT( krefdate ) ) THEN + + SELECT CASE ( krefdate ) + + CASE( 0 ) + iref = jpgreg + + CASE( 19500101 ) + iref = jporef + + CASE( 19000101 ) + iref = jparef + + CASE DEFAULT + WRITE(cerr,'(A,I8.8)')'jul2greg: Unknown krefdate:', krefdate + CALL ctl_stop( cerr ) + + END SELECT + + ELSE + iref = jporef + ENDIF + + zday = prelday + ksec = FLOOR( 86400. * MOD( zday, 1. ) ) + + IF ( ksec < 0. ) ksec = 86400. + ksec + + khour = ksec / 3600 + kminut = ( ksec - 3600 * khour ) / 60 + ksec = MOD( ksec , 60 ) + + ijulian = iref + INT( zday ) + IF ( zday < 0. ) ijulian = ijulian - 1 + + ! If input date after 10/15/1582 : + IF ( ijulian >= jpgreg ) THEN + ij1 = INT( ( DBLE( ijulian - 1867216 ) - 0.25 ) / 36524.25 ) + ija = ijulian + 1 + ij1 - INT( ( 0.25 * ij1 ) ) + ELSE + ija = ijulian + ENDIF + + ijb = ija + 1524 + ijc = INT( 6680. + ( DBLE ( ijb - 2439870 ) - 122.1 ) / 365.25 ) + ijd = 365 * ijc + INT( 0.25 * ijc ) + ije = INT( ( ijb - ijd ) / 30.6001 ) + kday = ijb - ijd - INT( 30.6001 * ije ) + kmonth = ije - 1 + IF ( kmonth > 12 ) kmonth = kmonth - 12 + kyear = ijc - 4715 + IF ( kmonth > 2 ) kyear = kyear - 1 + IF ( kyear <= 0 ) kyear = kyear - 1 + + END SUBROUTINE jul2greg \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/julian.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/julian.mod new file mode 100644 index 0000000000000000000000000000000000000000..0e8af26871ca4b3278bc82adb4028af07cabaca4 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/julian.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_lnk_call_generic.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_lnk_call_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..1a7b148b9d8d2ef26d8dcdc29cbcba840bec9e12 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_lnk_call_generic.h90 @@ -0,0 +1,129 @@ +#if defined DIM_2d +# define XD 2d +# define DIMS :,: +# define ISZ3 1 +# define ISZ4 1 +#endif +#if defined DIM_3d +# define XD 3d +# define DIMS :,:,: +# define ISZ3 SIZE(ptab, dim=3) +# define ISZ4 1 +#endif +#if defined DIM_4d +# define XD 4d +# define DIMS :,:,:,: +# define ISZ3 SIZE(ptab, dim=3) +# define ISZ4 SIZE(ptab, dim=4) +#endif + + SUBROUTINE lbc_lnk_call_/**/XD/**/_/**/PRECISION( & + & cdname & + & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & + & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & + & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & + & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & + & , pt17, cdna17, psgn17, pt18, cdna18, psgn18, pt19, cdna19, psgn19, pt20, cdna20, psgn20 & + & , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24 & + & , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28 & + & , pt29, cdna29, psgn29, pt30, cdna30, psgn30 & + & , kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + !!--------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(PRECISION), DIMENSION(DIMS) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied + REAL(PRECISION), DIMENSION(DIMS), OPTIONAL, TARGET, CONTIGUOUS, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , & + & pt9 , pt10, pt11, pt12, pt13, pt14, pt15, & + & pt16, pt17, pt18, pt19, pt20, pt21, pt22, & + & pt23, pt24, pt25, pt26, pt27, pt28, pt29, & + & pt30 + CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points + CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , & + & cdna9 , cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, & + & cdna16, cdna17, cdna18, cdna19, cdna20, cdna21, cdna22, & + & cdna23, cdna24, cdna25, cdna26, cdna27, cdna28, cdna29, & + & cdna30 + REAL(PRECISION) , INTENT(in ) :: psgn1 ! sign used across the north fold + REAL(PRECISION) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , & + & psgn9 , psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, & + & psgn16, psgn17, psgn18, psgn19, psgn20, psgn21, psgn22, & + & psgn23, psgn24, psgn25, psgn26, psgn27, psgn28, psgn29, & + & psgn30 + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(PRECISION) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL , INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out + LOGICAL , OPTIONAL , INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + !! + INTEGER :: kfld ! number of elements that will be attributed + TYPE(PTR_4d_/**/PRECISION), DIMENSION(30) :: ptab_ptr ! pointer array + CHARACTER(len=1) , DIMENSION(30) :: cdna_ptr ! nature of ptab_ptr grid-points + REAL(PRECISION) , DIMENSION(30) :: psgn_ptr ! sign used across the north fold boundary + !!--------------------------------------------------------------------- + ! + kfld = 0 ! initial array of pointer size + ! + ! ! Load the first array + CALL load_ptr_/**/XD/**/_/**/PRECISION( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + ! ! Look if more arrays are added + IF( PRESENT(psgn2 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn3 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn4 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn5 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn6 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn7 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn8 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn9 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn10) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn11) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn12) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn13) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn14) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn15) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn16) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn17) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt17, cdna17, psgn17, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn18) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt18, cdna18, psgn18, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn19) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt19, cdna19, psgn19, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn20) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt20, cdna20, psgn20, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn21) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt21, cdna21, psgn21, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn22) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt22, cdna22, psgn22, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn23) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt23, cdna23, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn24) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt24, cdna24, psgn24, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn25) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt25, cdna25, psgn25, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn26) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt26, cdna26, psgn26, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn27) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt27, cdna27, psgn27, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn28) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt28, cdna28, psgn28, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn29) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn30) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + IF( nn_comm == 1 ) THEN + CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ELSE + CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ENDIF + ! + END SUBROUTINE lbc_lnk_call_/**/XD/**/_/**/PRECISION + + + SUBROUTINE load_ptr_/**/XD/**/_/**/PRECISION( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + !!--------------------------------------------------------------------- + REAL(PRECISION), DIMENSION(DIMS), TARGET, INTENT(inout), CONTIGUOUS :: ptab ! arrays on which the lbc is applied + CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points + REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold boundary + TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers + CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points + REAL(PRECISION) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary + INTEGER , INTENT(inout) :: kfld ! number of elements that has been attributed + !!--------------------------------------------------------------------- + ! + kfld = kfld + 1 + ptab_ptr(kfld)%pt4d(1:SIZE(ptab, dim=1),1:SIZE(ptab, dim=2),1:ISZ3,1:ISZ4) => ptab + cdna_ptr(kfld) = cdna + psgn_ptr(kfld) = psgn + ! + END SUBROUTINE load_ptr_/**/XD/**/_/**/PRECISION + +#undef XD +#undef DIMS +#undef ISZ3 +#undef ISZ4 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_lnk_neicoll_generic.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_lnk_neicoll_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..dec9b38632013bc56bc3766b633e476488f68c4f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_lnk_neicoll_generic.h90 @@ -0,0 +1,271 @@ +SUBROUTINE lbc_lnk_neicoll_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc + LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + ! + INTEGER :: ji, jj, jk , jl, jf, jn ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ip0i, ip1i, im0i, im1i + INTEGER :: ip0j, ip1j, im0j, im1j + INTEGER :: ishti, ishtj, ishti2, ishtj2 + INTEGER :: iszS, iszR + INTEGER :: ierr + INTEGER :: ihls, idx + INTEGER :: impi_nc + INTEGER :: ifill_nfd + INTEGER, DIMENSION(4) :: iwewe, issnn + INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi + INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj + INTEGER, DIMENSION(8) :: ifill, iszall + INTEGER, DIMENSION(8) :: jnf + INTEGER, DIMENSION(:), ALLOCATABLE :: iScnt, iRcnt ! number of elements to be sent/received + INTEGER, DIMENSION(:), ALLOCATABLE :: iSdpl, iRdpl ! displacement in halos arrays + LOGICAL, DIMENSION(8) :: llsend, llrecv + REAL(PRECISION) :: zland + LOGICAL :: ll4only ! default: 8 neighbourgs + !!---------------------------------------------------------------------- + ! + ! ----------------------------------------- ! + ! 1. local variables initialization ! + ! ----------------------------------------- ! + ! + ipi = SIZE(ptab(1)%pt4d,1) + ipj = SIZE(ptab(1)%pt4d,2) + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) + ! + ! take care of optional parameters + ! + ihls = nn_hls ! default definition + IF( PRESENT( khls ) ) ihls = khls + IF( ihls > n_hlsmax ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipi /= Ni_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipj /= Nj_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + ! + ll4only = .FALSE. ! default definition + IF( PRESENT(ld4only) ) ll4only = ld4only + ! + impi_nc = mpi_nc_com8(ihls) ! default + IF( ll4only ) impi_nc = mpi_nc_com4(ihls) + ! + zland = 0._wp ! land filling value: zero by default + IF( PRESENT( pfillval ) ) zland = pfillval ! set land value + ! + ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. + IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs + CALL ctl_stop( 'STOP', 'mpp_nc_generic+lsend and lrecv not yet implemented') + ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' + CALL ctl_stop( 'STOP', ctmp1 ) + ELSE ! default neighbours + llsend(:) = mpiSnei(ihls,:) >= 0 + IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners + llrecv(:) = mpiRnei(ihls,:) >= 0 + IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners + ENDIF + ! + ! define ifill: which method should be used to fill each parts (sides+corners) of the halos + ! default definition + DO jn = 1, 8 + IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication + ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity + ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined + ELSE ; ifill(jn) = jpfillcst ! constant value (zland) + ENDIF + END DO + ! take care of "indirect self-periodicity" for the corners + DO jn = 5, 8 + IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn) = jpfillnothing ! no bi-perio but ew-perio: do corners later + IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn) = jpfillnothing ! no bi-perio but ns-perio: do corners later + END DO + ! north fold treatment + IF( l_IdoNFold ) THEN + ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false. + ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo + ENDIF + + ! We first define the localization and size of the parts of the array that will be sent (s), received (r) + ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions. + ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array + ! + ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls + ! ! ________________________ + ip0i = 0 ! im0j = inner |__|________________|__| + ip1i = ihls ! im1j = inner - halo | |__|__________|__| | + im1i = ipi-2*ihls ! | | | | | | + im0i = ipi - ihls ! | | | | | | + ip0j = 0 ! | | | | | | + ip1j = ihls ! | |__|__________|__| | + im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__| + im0j = ipj - ihls ! ip0j = 0 |__|________________|__| + ! ! ip0i ip1i im1i im0i + ! + iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) + ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea + isizei(1:4) = (/ ihls, ihls, Ni_0, Ni_0 /) ; isizei(5:8) = ihls ! i- count + isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count + ishtSi(1:4) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data + ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data + ishtRi(1:4) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location + ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location + ishtPi(1:4) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity + ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity + ! + ! -------------------------------- ! + ! 2. Prepare MPI exchanges ! + ! -------------------------------- ! + ! + ! Allocate local temporary arrays to be sent/received. + iszS = COUNT( llsend ) + iszR = COUNT( llrecv ) + ALLOCATE( iScnt(iszS), iRcnt(iszR), iSdpl(iszS), iRdpl(iszR) ) ! ok if iszS = 0 or iszR = 0 + iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf + iScnt(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false. + iRcnt(:) = PACK( iszall, mask = llrecv ) + IF( iszS > 0 ) iSdpl(1) = 0 + DO jn = 2,iszS + iSdpl(jn) = iSdpl(jn-1) + iScnt(jn-1) ! with _alltoallv: in units of sendtype + END DO + IF( iszR > 0 ) iRdpl(1) = 0 + DO jn = 2,iszR + iRdpl(jn) = iRdpl(jn-1) + iRcnt(jn-1) ! with _alltoallv: in units of sendtype + END DO + + ! Allocate buffer arrays to be sent/received if needed + iszS = SUM(iszall, mask = llsend) ! send buffer size + IF( ALLOCATED(BUFFSND) ) THEN + IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small + ENDIF + IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) ) + iszR = SUM(iszall, mask = llrecv) ! recv buffer size + IF( ALLOCATED(BUFFRCV) ) THEN + IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small + ENDIF + IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) ) + + ! fill sending buffer with ptab(jf)%pt4d + idx = 1 + DO jn = 1, 8 + IF( llsend(jn) ) THEN + ishti = ishtSi(jn) + ishtj = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + BUFFSND(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) + idx = idx + 1 + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + END DO + ! + ! ------------------------------------------------ ! + ! 3. Do all MPI exchanges in 1 unique call ! + ! ------------------------------------------------ ! + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + CALL mpi_neighbor_alltoallv (BUFFSND, iScnt, iSdpl, MPI_TYPE, BUFFRCV, iRcnt, iRdpl, MPI_TYPE, impi_nc, ierr) + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ------------------------- ! + ! 4. Fill all halos ! + ! ------------------------- ! + ! + idx = 1 + ! MPI3 bug fix when domain decomposition has 2 columns/rows + IF (jpni .eq. 2) THEN + IF (jpnj .eq. 2) THEN + jnf(1:8) = (/ 2, 1, 4, 3, 8, 7, 6, 5 /) + ELSE + jnf(1:8) = (/ 2, 1, 3, 4, 6, 5, 8, 7 /) + ENDIF + ELSE + IF (jpnj .eq. 2) THEN + jnf(1:8) = (/ 1, 2, 4, 3, 7, 8, 5, 6 /) + ELSE + jnf(1:8) = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) + ENDIF + ENDIF + + DO jn = 1, 8 + ishti = ishtRi(jnf(jn)) + ishtj = ishtRj(jnf(jn)) + SELECT CASE ( ifill(jnf(jn)) ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! fill with data received by MPI + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idx) + idx = idx + 1 + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use periodicity + ishti2 = ishtPi(jnf(jn)) + ishtj2 = ishtPj(jnf(jn)) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + ishti2 = ishtSi(jnf(jn)) + ishtj2 = ishtSj(jnf(jn)) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland + END DO ; END DO ; END DO ; END DO ; END DO + END SELECT + END DO + + DEALLOCATE( iScnt, iRcnt, iSdpl, iRdpl ) + IF( iszS > jpi*jpj ) DEALLOCATE(BUFFSND) ! blocking Send -> can directly deallocate + IF( iszR > jpi*jpj ) DEALLOCATE(BUFFRCV) ! blocking Recv -> can directly deallocate + + ! potential "indirect self-periodicity" for the corners + DO jn = 5, 8 + IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpwe) ) THEN ! no bi-perio but ew-perio: corners indirect definition + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + ishti2 = ishtPi(jn) ! use i- shift periodicity + ishtj2 = ishtRj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpso) ) THEN ! no bi-perio but ns-perio: corners indirect definition + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + ishti2 = ishtRi(jn) ! use i- shift recv location: use ns-perio -> ok as filling of the west and east halos now done + ishtj2 = ishtPj(jn) ! use j- shift periodicity + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + END DO + ! + ! ------------------------------- ! + ! 5. north fold treatment ! + ! ------------------------------- ! + ! + IF( l_IdoNFold ) THEN + IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold + ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold + ENDIF + ENDIF + ! + END SUBROUTINE lbc_lnk_neicoll_/**/PRECISION \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_nfd_ext_generic.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_nfd_ext_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..3b2f314f432e6bcd7d177012d2221f09dfae02ce --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_nfd_ext_generic.h90 @@ -0,0 +1,118 @@ +SUBROUTINE lbc_nfd_ext_/**/PRECISION( ptab, cd_nat, psgn, kextj ) + !!---------------------------------------------------------------------- + REAL(PRECISION), DIMENSION(:,1-kextj:),INTENT(inout) :: ptab + CHARACTER(len=1), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(PRECISION), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER, INTENT(in ) :: kextj ! extra halo width at north fold + ! + INTEGER :: ji, jj, jh ! dummy loop indices + INTEGER :: ipj + INTEGER :: ijt, iju, ipjm1 + !!---------------------------------------------------------------------- + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; ipj = jpj ! 1 proc only along the i-direction + CASE DEFAULT ; ipj = 4 ! several proc along the i-direction + END SELECT + ! + ipjm1 = ipj-1 + ! + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + ! + SELECT CASE ( cd_nat ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jh = 0, kextj + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) + END DO + ptab(1,ipj+jh) = psgn * ptab(3,ipj-2-jh) + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) + END DO + CASE ( 'U' ) ! U-point + DO jh = 0, kextj + DO ji = 2, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-2-jh) + END DO + ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-2-jh) + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-2-jh) + END DO + DO ji = jpiglo/2, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) + END DO + CASE ( 'V' ) ! V-point + DO jh = 0, kextj + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipj-1+jh) = psgn * ptab(ijt,ipj-2-jh) + ptab(ji,ipj+jh ) = psgn * ptab(ijt,ipj-3-jh) + END DO + ptab(1,ipj+jh) = psgn * ptab(3,ipj-3-jh) + END DO + CASE ( 'F' ) ! F-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipj-1+jh) = psgn * ptab(iju,ipj-2-jh) + ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-3-jh) + END DO + END DO + DO jh = 0, kextj + ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-3-jh) + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-3-jh) + END DO + END SELECT + ! + ENDIF ! c_NFtype == 'T' + ! + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + ! + SELECT CASE ( cd_nat ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jh = 0, kextj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-1-jh) + END DO + END DO + CASE ( 'U' ) ! U-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-1-jh) + END DO + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-1-jh) + END DO + CASE ( 'V' ) ! V-point + DO jh = 0, kextj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) + END DO + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) + END DO + CASE ( 'F' ) ! F-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-2-jh) + END DO + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-2-jh) + END DO + DO ji = jpiglo/2+1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) + END DO + END SELECT + ! + ENDIF ! c_NFtype == 'F' + ! + END SUBROUTINE lbc_nfd_ext_/**/PRECISION \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_nfd_generic.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_nfd_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..77cbe5b718b913dc31a769c51a07c958cf8e9d7a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbc_nfd_generic.h90 @@ -0,0 +1,389 @@ +SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, khls, kfld ) + TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + ! + INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ii1, ii2, ij1, ij2 + !!---------------------------------------------------------------------- + ! + ipi = SIZE(ptab(1)%pt4d,1) + ipj = SIZE(ptab(1)%pt4d,2) + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( ipi /= Ni0glo+2*khls ) THEN + WRITE(ctmp1,*) 'lbc_nfd input array does not match khls', ipi, khls, Ni0glo + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + ! + DO jf = 1, ipf ! Loop on the number of arrays to be treated + ! + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + ! + SELECT CASE ( cd_nat(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls+1 + ii1 = khls + ji + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + 1 + ii1 = ipi - khls + ji + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! last khls-1 points + ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi + ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - khls - 1) + 1 = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls - 1) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls-1 points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'U' ) ! U-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls-1 points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'V' ) ! V-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls+1 lines (from ipj to ipj-khls) : full + DO jj = 1, khls+1 + ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls + ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls+1 + ii1 = khls + ji + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + 1 + ii1 = ipi - khls + ji + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! last khls-1 points + ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi + ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'F' ) ! F-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls+1 lines (from ipj to ipj-khls) : full + DO jj = 1, khls+1 + ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls + ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + END SELECT ! cd_nat(jf) + ! + ENDIF ! c_NFtype == 'T' + ! + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + ! + SELECT CASE ( cd_nat(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! first: line number ipj-khls : 3 points + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, 1 ! points from ipi/2+1 + ii1 = ipi/2 + ji + ii2 = ipi/2 - ji + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + DO ji = 1, 1 ! points ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + DO ji = 1, 1 ! point khls: redo it just in case (if e-w periodocity already done) + ! ! as we just changed point ipi - khls + ii1 = khls + ji - 1 + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + END DO + ! + ! Second: last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls + ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'U' ) ! U-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls + ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls + ! + DO ji = 1, khls-1 ! first khls-1 points + ii1 = ji ! ends at: khls-1 + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls + ii1 = khls + ji - 1 + ii2 = ipi - ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 + ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'V' ) ! V-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'F' ) ! F-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls-1 ! first khls-1 points + ii1 = ji ! ends at: khls-1 + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls + ii1 = khls + ji - 1 + ii2 = ipi - ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 + ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - khls-1 (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! first khls-1 points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-nn_hl-1 + ii1 = ji ! ends at: khls + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + END SELECT ! cd_nat(jf) + ! + ENDIF ! c_NFtype == 'F' + ! + END DO ! ipf + ! + END SUBROUTINE lbc_nfd_/**/PRECISION \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbclnk.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbclnk.mod new file mode 100644 index 0000000000000000000000000000000000000000..2b33e19bd967cf75e240c358b98b84201a98f3d7 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbclnk.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbcnfd.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbcnfd.mod new file mode 100644 index 0000000000000000000000000000000000000000..43f1d7849c8343f76599cc88e1d17144b15b999d Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lbcnfd.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldfc1d_c2d.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldfc1d_c2d.mod new file mode 100644 index 0000000000000000000000000000000000000000..f2b6497007b19a46a5e4832eb83d3aae2f91b270 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldfc1d_c2d.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldfdyn.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldfdyn.mod new file mode 100644 index 0000000000000000000000000000000000000000..16e07271fad9850fe22bfbf5f02ca9e458f84cbe Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldfdyn.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldfslp.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldfslp.mod new file mode 100644 index 0000000000000000000000000000000000000000..c4e8ddad8534f0df19b1d1200e74fa73bdfe6de7 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldfslp.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldftra.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldftra.mod new file mode 100644 index 0000000000000000000000000000000000000000..7838aa255aeff363d447fea2a714f1154be10627 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ldftra.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/lib_fortran.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lib_fortran.mod new file mode 100644 index 0000000000000000000000000000000000000000..1cd75b84408ce4a94ec455be140cd26c03f02940 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lib_fortran.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/lib_fortran_generic.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lib_fortran_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..77d46540aafe44f2c68c342749d3dbe6b7dc3d6d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lib_fortran_generic.h90 @@ -0,0 +1,139 @@ +#if defined GLOBSUM_CODE +! ! FUNCTION FUNCTION_GLOBSUM ! +# if defined DIM_1d +# define XD 1d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i) +# define ARRAY2_IN(i,j,k) ptab2(i) +# define J_SIZE(ptab) 1 +# define K_SIZE(ptab) 1 +# define MASK_ARRAY(i,j) 1. +# endif +# if defined DIM_2d +# define XD 2d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j) +# define ARRAY2_IN(i,j,k) ptab2(i,j) +# define J_SIZE(ptab) SIZE(ptab,2) +# define K_SIZE(ptab) 1 +# define MASK_ARRAY(i,j) tmask_i(i,j) +# endif +# if defined DIM_3d +# define XD 3d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j,k) +# define ARRAY2_IN(i,j,k) ptab2(i,j,k) +# define J_SIZE(ptab) SIZE(ptab,2) +# define K_SIZE(ptab) SIZE(ptab,3) +# define MASK_ARRAY(i,j) tmask_i(i,j) +# endif + + FUNCTION glob_sum_/**/XD/**/( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:,:,:) ! array on which operation is applied + REAL(wp) :: glob_sum_/**/XD + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(wp) :: ztmp + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ipi,ipj, ipk ! dimensions + INTEGER :: iis, iie, ijs, ije ! loop start and end + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = J_SIZE(ptab) ! 2nd dimension + ipk = K_SIZE(ptab) ! 3rd dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) + iis = Nis0 ; iie = Nie0 + ijs = Njs0 ; ije = Nje0 + ELSE + iis = 1 ; iie = jpi + ijs = 1 ; ije = jpj + ENDIF + ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + DO jk = 1, ipk + DO jj = ijs, ije + DO ji = iis, iie + ztmp = ARRAY_IN(ji,jj,jk) * MASK_ARRAY(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END DO + END DO + END DO + CALL mpp_sum( cdname, ctmp ) ! sum over the global domain + glob_sum_/**/XD = REAL(ctmp,wp) + + END FUNCTION glob_sum_/**/XD + +#undef XD +#undef ARRAY_TYPE +#undef ARRAY2_TYPE +#undef ARRAY_IN +#undef ARRAY2_IN +#undef J_SIZE +#undef K_SIZE +#undef MASK_ARRAY +! +# endif +#if defined GLOBMINMAX_CODE +! ! FUNCTION FUNCTION_GLOBMINMAX ! +# if defined DIM_2d +# define XD 2d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j) +# define ARRAY2_IN(i,j,k) ptab2(i,j) +# define K_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define XD 3d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j,k) +# define ARRAY2_IN(i,j,k) ptab2(i,j,k) +# define K_SIZE(ptab) SIZE(ptab,3) +# endif +# if defined OPERATION_GLOBMIN +# define OPER min +# endif +# if defined OPERATION_GLOBMAX +# define OPER max +# endif + + FUNCTION glob_/**/OPER/**/_/**/XD/**/( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:,:,:) ! array on which operation is applied + REAL(wp) :: glob_/**/OPER/**/_/**/XD + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(wp) :: ztmp + INTEGER :: jk ! dummy loop indices + INTEGER :: ipk ! dimensions + !!----------------------------------------------------------------------- + ! + ipk = K_SIZE(ptab) ! 3rd dimension + ! + ztmp = OPER/**/val( ARRAY_IN(:,:,1)*tmask_i(:,:) ) + DO jk = 2, ipk + ztmp = OPER/**/(ztmp, OPER/**/val( ARRAY_IN(:,:,jk)*tmask_i(:,:) )) + ENDDO + + CALL mpp_/**/OPER/**/( cdname, ztmp) + + glob_/**/OPER/**/_/**/XD = ztmp + + END FUNCTION glob_/**/OPER/**/_/**/XD + +#undef XD +#undef ARRAY_TYPE +#undef ARRAY2_TYPE +#undef ARRAY_IN +#undef ARRAY2_IN +#undef K_SIZE +#undef OPER +# endif diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/lib_mpp.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lib_mpp.mod new file mode 100644 index 0000000000000000000000000000000000000000..e01080da4f74bf5df7370f1807560585f3020f29 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/lib_mpp.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/linquad.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/linquad.h90 new file mode 100644 index 0000000000000000000000000000000000000000..b6d1e1730fdb7a99686f8834bd3afdc7e2b057ab --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/linquad.h90 @@ -0,0 +1,58 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: linquad.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + LOGICAL FUNCTION linquad( px, py, pxv, pyv ) + !!---------------------------------------------------------------------- + !! *** FUNCTION linquad *** + !! + !! ** Purpose : Determine whether a point P(x,y) lies within or on the + !! boundary of a quadrangle (ABCD) of any shape on a plane. + !! + !! ** Method : Check if the vectorial products PA x PC, PB x PA, + !! PC x PD, and PD x PB are all negative. + !! + !! ** Action : + !! + !! History : + !! ! 2001-11 (N. Daget, A. Weaver) + !! ! 2006-08 (A. Weaver) NEMOVAR migration + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: px ! (lon) of the point P(x,y) + REAL(KIND=wp), INTENT(IN) :: py ! (lat) of the point P(x,y) + REAL(KIND=wp), DIMENSION(4), INTENT(IN) :: & + & pxv, & ! (lon, lat) of the surrounding cell + & pyv + + !! * Local declarations + REAL(KIND=wp) :: zst1 + REAL(KIND=wp) :: zst2 + REAL(KIND=wp) :: zst3 + REAL(KIND=wp) :: zst4 + + !----------------------------------------------------------------------- + ! Test to see if the point is within the cell + !----------------------------------------------------------------------- + linquad = .FALSE. + zst1 = ( px - pxv(1) ) * ( py - pyv(4) ) & + & - ( py - pyv(1) ) * ( px - pxv(4) ) + IF ( zst1 <= 0.0 ) THEN + zst2 = ( px - pxv(4) ) * ( py - pyv(3) ) & + & - ( py - pyv(4) ) * ( px - pxv(3) ) + IF ( zst2 <= 0.0 ) THEN + zst3 = ( px - pxv(3) ) * ( py - pyv(2) ) & + & - ( py - pyv(3) ) * ( px - pxv(2) ) + IF ( zst3 <= 0.0) THEN + zst4 = ( px - pxv(2) ) * ( py - pyv(1) ) & + & - ( py - pyv(2) ) * ( px - pxv(1) ) + IF ( zst4 <= 0.0 ) linquad = .TRUE. + ENDIF + ENDIF + ENDIF + + END FUNCTION linquad \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/mathelp.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mathelp.mod new file mode 100644 index 0000000000000000000000000000000000000000..0716414d5e936ff51c21022dbc947c68a6ccce6b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mathelp.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/maxdist.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/maxdist.h90 new file mode 100644 index 0000000000000000000000000000000000000000..48bfdbe245ac370b7575d7c8daa93d617d1a190c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/maxdist.h90 @@ -0,0 +1,76 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: maxdist.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(wp) FUNCTION maxdist( pxv, pyv ) + !!---------------------------------------------------------------------- + !! *** FUNCTION maxdist *** + !! + !! ** Purpose : Compute the maximum distance between any points within + !! a cell + !! + !! ** Method : Call to grt_cir_dis + !! + !! ** Action : + !! + !! History : + !! ! 2006-08 (K. Mogensen) + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), DIMENSION(4), INTENT(IN) :: & + & pxv, & ! (lon, lat) of the surrounding cell + & pyv + + !! * Local declarations + REAL(KIND=wp), DIMENSION(4) :: & + & zxv, & + & zyv, & + & za, & + & zb, & + & zc + REAL(KIND=wp) :: zdist + + INTEGER :: ji + INTEGER :: jj + + !----------------------------------------------------------------------- + ! Convert data to radians + !----------------------------------------------------------------------- + DO ji = 1, 4 + zxv(ji) = pxv(ji) * rad + zyv(ji) = pyv(ji) * rad + END DO + + !----------------------------------------------------------------------- + ! Prepare input to grt_cir_dis + !----------------------------------------------------------------------- + DO ji = 1, 4 + za(ji) = SIN( zyv(ji) ) + zb(ji) = COS( zyv(ji) ) * COS( zxv(ji) ) + zc(ji) = COS( zyv(ji) ) * SIN( zxv(ji) ) + END DO + + !----------------------------------------------------------------------- + ! Get max distance between any points in the area + !----------------------------------------------------------------------- + maxdist = 0.0 + DO jj = 1, 4 + DO ji = jj+1, 4 + zdist = grt_cir_dis( za(jj), za(ji), zb(jj), & + & zb(ji), zc(jj), zc(ji)) + IF ( zdist > maxdist ) THEN + maxdist = zdist + ENDIF + END DO + END DO + + !----------------------------------------------------------------------- + ! Convert to degrees. + !----------------------------------------------------------------------- + maxdist = maxdist / rad + + END FUNCTION maxdist \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_allreduce_generic.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_allreduce_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..a0b41a21b18b3cb52d7564b43ae151aff6ed8922 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_allreduce_generic.h90 @@ -0,0 +1,89 @@ +! !== IN: ptab is an array ==! +# if defined REAL_TYPE +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i) REAL(sp) , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) REAL(sp) , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_real +# else +# define ARRAY_TYPE(i) REAL(dp) , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) REAL(dp) , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_double_precision +# endif +# endif +# if defined INTEGER_TYPE +# define ARRAY_TYPE(i) INTEGER , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) INTEGER , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_integer +# endif +# if defined COMPLEX_TYPE +# define ARRAY_TYPE(i) COMPLEX(dp) , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) COMPLEX(dp) , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_double_complex +# endif +# if defined DIM_0d +# define ARRAY_IN(i) ptab +# define I_SIZE(ptab) 1 +# endif +# if defined DIM_1d +# define ARRAY_IN(i) ptab(i) +# define I_SIZE(ptab) SIZE(ptab,1) +# endif +# if defined OPERATION_MAX +# define MPI_OPERATION mpi_max +# endif +# if defined OPERATION_MIN +# define MPI_OPERATION mpi_min +# endif +# if defined OPERATION_SUM +# define MPI_OPERATION mpi_sum +# endif +# if defined OPERATION_SUM_DD +# define MPI_OPERATION mpi_sumdd +# endif + + SUBROUTINE ROUTINE_ALLREDUCE( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator +#if ! defined key_mpi_off + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + TMP_TYPE(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = I_SIZE(ptab) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ARRAY_IN(:), work, ipi, MPI_TYPE, MPI_OPERATION, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ARRAY_IN(ii) = work(ii) + ENDDO + DEALLOCATE(work) +#else + ! nothing to do if non-mpp case + RETURN +#endif + + END SUBROUTINE ROUTINE_ALLREDUCE + +#undef PRECISION +#undef ARRAY_TYPE +#undef ARRAY_IN +#undef I_SIZE +#undef MPI_OPERATION +#undef TMP_TYPE +#undef MPI_TYPE \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_lbc_north_icb_generic.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_lbc_north_icb_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..7e9608d0ef05ffe39c65ad44798a828275181785 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_lbc_north_icb_generic.h90 @@ -0,0 +1,114 @@ +# if defined SINGLE_PRECISION +# define PRECISION sp +# define SENDROUTINE mppsend_sp +# define RECVROUTINE mpprecv_sp +# define MPI_TYPE MPI_REAL +# else +# define PRECISION dp +# define SENDROUTINE mppsend_dp +# define RECVROUTINE mpprecv_dp +# define MPI_TYPE MPI_DOUBLE_PRECISION +# endif + + SUBROUTINE ROUTINE_LNK( pt2d, cd_type, psgn, kextj) + !!--------------------------------------------------------------------- + !! *** routine mpp_lbc_north_icb *** + !! + !! ** Purpose : Ensure proper north fold horizontal bondary condition + !! in mpp configuration in case of jpn1 > 1 and for 2d + !! array with outer extra halo + !! + !! ** Method : North fold condition and mpp with more than one proc + !! in i-direction require a specific treatment. We gather + !! the 4+kextj northern lines of the global domain on 1 + !! processor and apply lbc north-fold on this sub array. + !! Then we scatter the north fold array back to the processors. + !! This routine accounts for an extra halo with icebergs + !! and assumes ghost rows and columns have been suppressed. + !! + !!---------------------------------------------------------------------- + REAL(PRECISION), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points + ! ! = T , U , V , F or W -points + REAL(PRECISION) , INTENT(in ) :: psgn ! = -1. the sign change across the + !! ! north fold, = 1. otherwise + INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold + ! + INTEGER :: ji, jj, jr + INTEGER :: ierr, itaille + INTEGER :: ipj, ij, iproc, ijnr, ii1, ipi, impp + ! + REAL(PRECISION), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e + REAL(PRECISION), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e + !!---------------------------------------------------------------------- +#if ! defined key_mpi_off + ! + ipj=4 + ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & + & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & + & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,ndim_rank_north) ) + ! +# if defined SINGLE_PRECISION + ztab_e(:,:) = 0._sp + znorthloc_e(:,:) = 0._sp +# else + ztab_e(:,:) = 0._dp + znorthloc_e(:,:) = 0._dp +# endif + ! + ij = 1 - kextj + ! put the last ipj+2*kextj lines of pt2d into znorthloc_e + DO jj = jpj - ipj + 1 - kextj , jpj + kextj + znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) + ij = ij + 1 + END DO + ! + itaille = jpimax * ( ipj + 2*kextj ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) +#if ! defined key_mpi_off + CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_TYPE, & + & znorthgloio_e(1,1-kextj,1), itaille, MPI_TYPE, & + & ncomm_north, ierr ) +#endif + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ijnr = 0 + DO jr = 1, ndim_rank_north ! recover the global north array + iproc = nfproc(jr) + IF( iproc /= -1 ) THEN + impp = nfimpp(jr) + ipi = nfjpi(jr) + ijnr = ijnr + 1 + DO jj = 1-kextj, ipj+kextj + DO ji = 1, ipi + ii1 = impp + ji - 1 ! corresponds to mig(ji) but for subdomain iproc + ztab_e(ii1,jj) = znorthgloio_e(ji,jj,ijnr) + END DO + END DO + ENDIF + END DO + + ! 2. North-Fold boundary conditions + ! ---------------------------------- + CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) + + ij = 1 - kextj + !! Scatter back to pt2d + DO jj = jpj - ipj + 1 - kextj , jpj + kextj + DO ji= 1, jpi + pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) + END DO + ij = ij +1 + END DO + ! + DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) + ! +#endif + END SUBROUTINE ROUTINE_LNK + +# undef PRECISION +# undef SENDROUTINE +# undef RECVROUTINE +# undef MPI_TYPE \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_lnk_icb_generic.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_lnk_icb_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..d5958b3119c824d58f904354d62b45514a3d54be --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_lnk_icb_generic.h90 @@ -0,0 +1,183 @@ +# if defined SINGLE_PRECISION +# define PRECISION sp +# define SENDROUTINE mppsend_sp +# define RECVROUTINE mpprecv_sp +# define LBCNORTH mpp_lbc_north_icb_sp +# else +# define PRECISION dp +# define SENDROUTINE mppsend_dp +# define RECVROUTINE mpprecv_dp +# define LBCNORTH mpp_lbc_north_icb_dp +# endif + + SUBROUTINE ROUTINE_LNK( cdname, pt2d, cd_type, psgn, kexti, kextj ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_2d_icb *** + !! + !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) + !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) + !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! jpi : first dimension of the local subdomain + !! jpj : second dimension of the local subdomain + !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) + !! kexti : number of columns for extra outer halo + !! kextj : number of rows for extra outer halo + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points + REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold + INTEGER , INTENT(in ) :: kexti ! extra i-halo width + INTEGER , INTENT(in ) :: kextj ! extra j-halo width + ! + INTEGER :: jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! local integers + INTEGER :: ipreci, iprecj ! - - + INTEGER :: ml_req1, ml_req2, ml_err ! for mpi_isend + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend + !! + REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn + REAL(PRECISION), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew + !!---------------------------------------------------------------------- + ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area + iprecj = nn_hls + kextj + + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) + + ! 1. standard boundary treatment + ! ------------------------------ + ! Order matters Here !!!! + ! + ! ! East-West boundaries + ! !* Cyclic east-west + IF( l_Iperio ) THEN + pt2d(1-kexti: 1 ,:) = pt2d(jpi-1-kexti: jpi-1 ,:) ! east + pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west + ! + ELSE !* closed +# if defined SINGLE_PRECISION + IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._sp ! east except at F-point + pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._sp ! west +# else + IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._dp ! east except at F-point + pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._dp ! west +# endif + ENDIF + ! ! North-South boundaries + IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) + pt2d(:,1-kextj: 1 ) = pt2d(:,jpj-1-kextj: jpj-1) ! north + pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south + ELSE !* closed +# if defined SINGLE_PRECISION + IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._sp ! north except at F-point + pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._sp ! south +# else + IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._dp ! north except at F-point + pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._dp ! south +# endif + ENDIF + ! + + ! north fold treatment + ! ----------------------- + IF( l_IdoNFold ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) + CASE DEFAULT ; CALL LBCNORTH ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) + END SELECT + ! + ENDIF + + ! 2. East and west directions exchange + ! ------------------------------------ + ! we play with the neigbours AND the row number because of the periodicity + ! + IF( mpinei(jpwe) >= 0 .OR. mpinei(jpea) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) + iihom = jpi - (2 * nn_hls) -kexti + DO jl = 1, ipreci + r2dew(:,jl,1) = pt2d(nn_hls+jl,:) + r2dwe(:,jl,1) = pt2d(iihom +jl,:) + END DO + ENDIF + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*kextj ) + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*kextj ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + IF( mpinei(jpwe) >= 0 ) CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, mpinei(jpwe), ml_req1 ) + IF( mpinei(jpea) >= 0 ) CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, mpinei(jpea), ml_req2 ) + IF( mpinei(jpwe) >= 0 ) CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, mpinei(jpwe) ) + IF( mpinei(jpea) >= 0 ) CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, mpinei(jpea) ) + IF( mpinei(jpwe) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF( mpinei(jpea) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ! Write Dirichlet lateral conditions + iihom = jpi - nn_hls + IF( mpinei(jpwe) >= 0 ) THEN + DO jl = 1, ipreci + pt2d(jl-kexti,:) = r2dwe(:,jl,2) + END DO + ENDIF + IF( mpinei(jpea) >= 0 ) THEN + DO jl = 1, ipreci + pt2d(iihom+jl,:) = r2dew(:,jl,2) + END DO + ENDIF + + ! 3. North and south directions + ! ----------------------------- + ! always closed : we play only with the neigbours + ! + IF( mpinei(jpso) >= 0 .OR. mpinei(jpno) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) + ijhom = jpj - (2 * nn_hls) - kextj + DO jl = 1, iprecj + r2dsn(:,jl,1) = pt2d(:,ijhom +jl) + r2dns(:,jl,1) = pt2d(:,nn_hls+jl) + END DO + ENDIF + ! + ! ! Migrations + imigr = iprecj * ( jpi + 2*kexti ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + IF( mpinei(jpso) >= 0 ) CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, mpinei(jpso), ml_req1 ) + IF( mpinei(jpno) >= 0 ) CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, mpinei(jpno), ml_req2 ) + IF( mpinei(jpso) >= 0 ) CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, mpinei(jpso) ) + IF( mpinei(jpno) >= 0 ) CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, mpinei(jpno) ) + IF( mpinei(jpso) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF( mpinei(jpno) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ! Write Dirichlet lateral conditions + ijhom = jpj - nn_hls + ! + IF( mpinei(jpso) >= 0 ) THEN + DO jl = 1, iprecj + pt2d(:,jl-kextj) = r2dsn(:,jl,2) + END DO + ENDIF + IF( mpinei(jpno) >= 0 ) THEN + DO jl = 1, iprecj + pt2d(:,ijhom+jl) = r2dns(:,jl,2) + END DO + ENDIF + ! + END SUBROUTINE ROUTINE_LNK + +# undef LBCNORTH +# undef PRECISION +# undef SENDROUTINE +# undef RECVROUTINE \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_loc_generic.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_loc_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..21783b85eea64eaa65a897d7311082636e390d82 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_loc_generic.h90 @@ -0,0 +1,139 @@ +!== IN: ptab is an array ==! +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +#if ! defined key_mpi_off +# define MPI_TYPE MPI_2REAL +#endif +# define PRECISION sp +# else +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +#if ! defined key_mpi_off +# define MPI_TYPE MPI_2DOUBLE_PRECISION +#endif +# define PRECISION dp +# endif + +# if defined DIM_2d +# define ARRAY_IN(i,j,k) ptab(i,j) +# define MASK_IN(i,j,k) ldmsk(i,j) +# define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(2) +# define K_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_IN(i,j,k) ptab(i,j,k) +# define MASK_IN(i,j,k) ldmsk(i,j,k) +# define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(3) +# define K_SIZE(ptab) SIZE(ptab,3) +# endif +# if defined OPERATION_MAXLOC +# define MPI_OPERATION MPI_MAXLOC +# define LOC_OPERATION MAXLOC +# define ERRVAL -HUGE +# endif +# if defined OPERATION_MINLOC +# define MPI_OPERATION MPI_MINLOC +# define LOC_OPERATION MINLOC +# define ERRVAL HUGE +# endif + + SUBROUTINE ROUTINE_LOC( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:,:,:) ! array on which loctrans operation is applied + LOGICAL , INTENT(in ) :: MASK_IN(:,:,:) ! local mask + REAL(PRECISION) , INTENT( out) :: pmin ! Global minimum of ptab + INDEX_TYPE(:) ! index of minimum in global frame + LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(PRECISION) :: zmin ! local minimum + REAL(PRECISION), DIMENSION(2,1) :: zain, zaout + LOGICAL :: llhalo + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo + ELSE ; llhalo = .FALSE. + ENDIF + ! + idim = SIZE(kindex) + ! + IF ( ANY( MASK_IN(:,:,:) ) ) THEN ! there is at least 1 valid point... + ! + ALLOCATE ( ilocs(idim) ) + ! + ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) ) + zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3)) + ! + kindex(1) = mig( ilocs(1) ) +#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ + kindex(2) = mjg( ilocs(2) ) +#endif +#if defined DIM_3d /* avoid warning when kindex has 2 elements */ + kindex(3) = ilocs(3) +#endif + ! + DEALLOCATE (ilocs) + ! + index0 = kindex(1)-1 ! 1d index starting at 0 +#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ + index0 = index0 + jpiglo * (kindex(2)-1) +#endif +#if defined DIM_3d /* avoid warning when kindex has 2 elements */ + index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) +#endif + ELSE + ! special case for land processors + zmin = ERRVAL(zmin) + index0 = 0 + END IF + ! + zain(1,:) = zmin + zain(2,:) = REAL(index0, PRECISION) + ! +#if ! defined key_mpi_off + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_TYPE, MPI_OPERATION ,MPI_COMM_OCE, ierror) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) +#else + zaout(:,:) = zain(:,:) +#endif + ! + pmin = zaout(1,1) + index0 = NINT( zaout(2,1) ) +#if defined DIM_3d /* avoid warning when kindex has 2 elements */ + kindex(3) = index0 / (jpiglo*jpjglo) + index0 = index0 - kindex(3) * (jpiglo*jpjglo) +#endif +#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ + kindex(2) = index0 / jpiglo + index0 = index0 - kindex(2) * jpiglo +#endif + kindex(1) = index0 + kindex(:) = kindex(:) + 1 ! start indices at 1 + + IF( .NOT. llhalo ) THEN + kindex(1) = kindex(1) - nn_hls +#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ + kindex(2) = kindex(2) - nn_hls +#endif + ENDIF + + END SUBROUTINE ROUTINE_LOC + + +#undef PRECISION +#undef ARRAY_TYPE +#undef ARRAY_IN +#undef MASK_IN +#undef K_SIZE +#if ! defined key_mpi_off +# undef MPI_TYPE +#endif +#undef MPI_OPERATION +#undef LOC_OPERATION +#undef INDEX_TYPE +#undef ERRVAL diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_map.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_map.mod new file mode 100644 index 0000000000000000000000000000000000000000..493e80f279c3b86a2a9bb0f8750c2bac5d8c69cc Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_map.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_nfd_generic.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_nfd_generic.h90 new file mode 100644 index 0000000000000000000000000000000000000000..722d9150d1bac1a97d0ba7d3e1447e4a8efa246b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mpp_nfd_generic.h90 @@ -0,0 +1,396 @@ +SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld ) + TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land + REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + ! + LOGICAL :: ll_add_line + INTEGER :: ji, jj, jk, jl, jf, jr, jg, jn ! dummy loop indices + INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ierr, ibuffsize, iis0, iie0, impp + INTEGER :: ii1, ii2, ij1, ij2, iis, iie, iib, iig, iin + INTEGER :: i0max + INTEGER :: ij, iproc, ipni, ijnr + INTEGER, DIMENSION (:), ALLOCATABLE :: ireq_s, ireq_r ! for mpi_isend when avoiding mpi_allgather + INTEGER :: ipjtot ! sum of lines for all multi fields + INTEGER :: i012 ! 0, 1 or 2 + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijsnd ! j-position of sent lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijbuf ! j-position of send buffer lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijrcv ! j-position of recv buffer lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ii1st, iiend + INTEGER , DIMENSION(:) , ALLOCATABLE :: ipjfld ! number of sent lines for each field + REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: zbufs ! buffer, receive and work arrays + REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: zbufr ! buffer, receive and work arrays + REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc + REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo + TYPE(PTR_4D_/**/PRECISION), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c. + !!---------------------------------------------------------------------- + ! + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( ln_nnogather ) THEN !== no allgather exchanges ==! + + ! --- define number of exchanged lines --- + ! + ! In theory we should exchange only nn_hls lines. + ! + ! However, some other points are duplicated in the north pole folding: + ! - c_NFtype='T', grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) + ! - c_NFtype='T', grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) + ! - c_NFtype='T', grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) + ! - c_NFtype='T', grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) + ! - c_NFtype='F', grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) + ! - c_NFtype='F', grid=U : no points are duplicated + ! - c_NFtype='F', grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) + ! - c_NFtype='F', grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) + ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) + ! This explain why these duplicated points may have different values even if they are at the exact same location. + ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. + ! This is slightly slower but necessary to avoid different values on identical grid points!! + ! + !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! + !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!! + !!!!!!!!! I don't know why we must do that... !!!!!!!! + l_full_nf_update = .TRUE. + ! also force it if not restart during the first 2 steps (leap frog?) + ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) + + ALLOCATE(ipjfld(ipf)) ! how many lines do we exchange for each field? + IF( ll_add_line ) THEN + DO jf = 1, ipf ! Loop over the number of arrays to be processed + ipjfld(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) + END DO + ELSE + ipjfld(:) = khls + ENDIF + + ipj = MAXVAL(ipjfld(:)) ! Max 2nd dimension of message transfers + ipjtot = SUM( ipjfld(:)) ! Total number of lines to be exchanged + + ! Index of modifying lines in input + ALLOCATE( ijsnd(ipj, ipf), ijbuf(ipj, ipf), ijrcv(ipj, ipf), ii1st(ipj, ipf), iiend(ipj, ipf) ) + + ij1 = 0 + DO jf = 1, ipf ! Loop over the number of arrays to be processed + ! + DO jj = 1, khls ! first khls lines (starting from top) must be fully defined + ii1st(jj, jf) = 1 + iiend(jj, jf) = jpi + END DO + ! + ! what do we do with line khls+1 (starting from top) + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + SELECT CASE ( cd_nat(jf) ) + CASE ('T','W') ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+2) ; iiend(khls+1, jf) = mi1(jpiglo-khls) + CASE ('U' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls) + CASE ('V' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi + CASE ('F' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi + END SELECT + ENDIF + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + SELECT CASE ( cd_nat(jf) ) + CASE ('T','W') ; i012 = 0 ! we don't touch line khls+1 + CASE ('U' ) ; i012 = 0 ! we don't touch line khls+1 + CASE ('V' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls ) + CASE ('F' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls-1) + END SELECT + ENDIF + ! + DO jj = 1, ipjfld(jf) + ij1 = ij1 + 1 + ijsnd(jj,jf) = jpj - 2*khls + jj - i012 ! sent lines (from bottom of sent lines) + ijbuf(jj,jf) = ij1 ! gather all lines in the snd/rcv buffers + ijrcv(jj,jf) = jpj - jj + 1 ! recv lines (from the top -> reverse order for jj) + END DO + ! + END DO + ! + i0max = jpimax - 2 * khls ! we are not sending the halos + ALLOCATE( zbufs(i0max,ipjtot,ipk,ipl), ireq_s(nfd_nbnei) ) ! store all the data to be sent in a buffer array + ibuffsize = i0max * ipjtot * ipk * ipl + ! + ! fill the send buffer with all the lines + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) + DO ji = Nis0, Nie0 ! should not use any other value + iib = ji - Nis0 + 1 + zbufs(iib,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) + END DO + DO ji = Ni_0+1, i0max ! avoid sending uninitialized values (make sure we don't use it) + zbufs(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! make sure we don't use it... + END DO + END DO + END DO ; END DO ; END DO + ! + ! start waiting time measurement + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + ! send the same buffer data to all neighbourgs as soon as possible + DO jn = 1, nfd_nbnei + iproc = nfd_rknei(jn) + IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN +#if ! defined key_mpi_off + CALL MPI_Isend( zbufs, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_s(jn), ierr ) +#endif + ELSE + ireq_s(jn) = MPI_REQUEST_NULL + ENDIF + END DO + ! + ALLOCATE( zbufr(i0max,ipjtot,ipk,ipl,nfd_nbnei), ireq_r(nfd_nbnei) ) + ! + DO jn = 1, nfd_nbnei + ! + iproc = nfd_rknei(jn) + ! + IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) + ! + ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received + zbufr(:,:,:,:,jn) = HUGE(0._/**/PRECISION) ! default: define it and make sure we don't use it... + SELECT CASE ( kfillmode ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) ! we will use only the first value, see init_nfdcom + zbufr(1,ij1,jk,jl,jn) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point + END DO + END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + zbufr(1,:,:,:,jn) = pfillval ! we will use only the first value, see init_nfdcom + END SELECT + ! + ELSE IF( iproc == narea-1 ) THEN ! get data from myself! + ! + ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) + DO ji = Nis0, Nie0 ! should not use any other value + iib = ji - Nis0 + 1 + zbufr(iib,ij1,jk,jl,jn) = ptab(jf)%pt4d(ji,ij2,jk,jl) + END DO + END DO + END DO ; END DO ; END DO + ! + ELSE ! get data from a neighbour trough communication +#if ! defined key_mpi_off + CALL MPI_Irecv( zbufr(:,:,:,:,jn), ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr ) +#endif + ENDIF + ! + END DO ! nfd_nbnei + ! + CALL mpi_waitall(nfd_nbnei, ireq_r, MPI_STATUSES_IGNORE, ierr) ! wait for all Irecv + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! North fold boundary condition + ! + DO jf = 1, ipf + ! + SELECT CASE ( cd_nat(jf) ) ! which grid number? + CASE ('T','W') ; iig = 1 ! T-, W-point + CASE ('U') ; iig = 2 ! U-point + CASE ('V') ; iig = 3 ! V-point + CASE ('F') ; iig = 4 ! F-point + END SELECT + ! + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! if T point with F-point pivot : must be done first + ! --> specific correction of 3 points near the 2 pivots (to be clean, usually masked -> so useless) + IF( c_NFtype == 'F' .AND. iig == 1 ) THEN + ij1 = jpj - khls ! j-index in the receiving array + ij2 = 1 ! only 1 line in the buffer + DO ji = mi0(khls), mi1(khls) ! change because of EW periodicity as we also change jpiglo-khls + iib = nfd_jisnd(mi0( khls),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0( khls),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + DO ji = mi0(jpiglo/2+1), mi1(jpiglo/2+1) + iib = nfd_jisnd(mi0( jpiglo/2+1),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0( jpiglo/2+1),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + DO ji = mi0(jpiglo-khls), mi1(jpiglo-khls) + iib = nfd_jisnd(mi0(jpiglo-khls),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0(jpiglo-khls),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + ENDIF + ! + ! Apply the North pole folding. + DO jj = 1, ipjfld(jf) ! for all lines to be exchanged for this field + ij1 = ijrcv(jj,jf) ! j-index in the receiving array + ij2 = ijbuf(jj,jf) ! j-index in the buffer + iis = ii1st(jj,jf) ! stating i-index in the receiving array + iie = iiend(jj,jf) ! ending i-index in the receiving array + DO ji = iis, iie + iib = nfd_jisnd(ji,iig) ! i-index in the buffer + iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) + END DO + END DO + ! + ! re-apply periodocity when we modified the eastern side of the inner domain (and not the full line) + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + IF( iig <= 2 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'T','W','U': update west halo + ELSE ; iis = 1 ; iie = 0 ! 'V','F' : full line already exchanged + ENDIF + ENDIF + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + IF( iig <= 2 ) THEN ; iis = 1 ; iie = 0 ! 'T','W','U': nothing to do + ELSEIF( iig == 3 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'V' : update west halo + ELSEIF( khls > 1 ) THEN ; iis = mi0(1) ; iie = mi1(khls-1) ! 'F' and khls > 1 + ELSE ; iis = 1 ; iie = 0 ! 'F' and khls == 1 : nothing to do + ENDIF + ENDIF + jj = ipjfld(jf) ! only for the last line of this field + ij1 = ijrcv(jj,jf) ! j-index in the receiving array + ij2 = ijbuf(jj,jf) ! j-index in the buffer + DO ji = iis, iie + iib = nfd_jisnd(ji,iig) ! i-index in the buffer + iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) + END DO + ! + END DO ; END DO ! ipl ; ipk + ! + END DO ! ipf + + ! + DEALLOCATE( zbufr, ireq_r, ijsnd, ijbuf, ijrcv, ii1st, iiend, ipjfld ) + ! + CALL mpi_waitall(nfd_nbnei, ireq_s, MPI_STATUSES_IGNORE, ierr) ! wait for all Isend + ! + DEALLOCATE( zbufs, ireq_s ) + ! + ELSE !== allgather exchanges ==! + ! + ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) + ipj = khls + 2 + ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) + ipj2 = 2 * khls + 2 + ! + i0max = jpimax - 2 * khls + ibuffsize = i0max * ipj * ipk * ipl * ipf + ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) + ! + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab + DO jj = 1, ipj + ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines + DO ji = 1, Ni_0 + ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 + znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = Ni_0+1, i0max + znorthloc(ji,jj,jk,jl,jf) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it) + END DO + END DO + END DO ; END DO ; END DO + ! + ! start waiting time measurement + IF( ln_timing ) CALL tic_tac(.TRUE.) +#if ! defined key_mpi_off + CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) +#endif + ! stop waiting time measurement + IF( ln_timing ) CALL tic_tac(.FALSE.) + DEALLOCATE( znorthloc ) + ALLOCATE( ztabglo(ipf) ) + DO jf = 1, ipf + ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) ) + END DO + ! + ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines + ijnr = 0 + DO jr = 1, jpni ! recover the global north array + iproc = nfproc(jr) + impp = nfimpp(jr) + ipi = nfjpi( jr) - 2 * khls ! corresponds to Ni_0 but for subdomain iproc + IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) + ! + SELECT CASE ( kfillmode ) + CASE ( jpfillnothing ) ! no filling + CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F') + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point + END DO + END DO + END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval + END DO + END DO + END DO ; END DO ; END DO + END SELECT + ! + ELSE + ijnr = ijnr + 1 + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr) + END DO + END DO + END DO ; END DO ; END DO + ENDIF + ! + END DO ! jpni + DEALLOCATE( znorthglo ) + ! + DO jf = 1, ipf + CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 ) ! North fold boundary condition + DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity + DO jj = 1, khls + 1 + ij1 = ipj2 - (khls + 1) + jj ! need only the last khls + 1 lines until ipj2 + ztabglo(jf)%pt4d( 1: khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl) + ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( khls+1: 2*khls,ij1,jk,jl) + END DO + END DO ; END DO + END DO + ! + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN + DO jj = 1, khls + 1 + ij1 = jpj - (khls + 1) + jj ! last khls + 1 lines until jpj + ij2 = ipj2 - (khls + 1) + jj ! last khls + 1 lines until ipj2 + DO ji= 1, jpi + ii2 = mig(ji) + ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + END DO ; END DO ; END DO + ! + DO jf = 1, ipf + DEALLOCATE( ztabglo(jf)%pt4d ) + END DO + DEALLOCATE( ztabglo ) + ! + ENDIF ! ln_nnogather + ! + END SUBROUTINE mpp_nfd_/**/PRECISION \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/mppini.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mppini.mod new file mode 100644 index 0000000000000000000000000000000000000000..ca0044fdb2a21ce75b57d7511c168abb143e82f6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/mppini.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/nc4interface.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/nc4interface.mod new file mode 100644 index 0000000000000000000000000000000000000000..3d9cc9fe6d37337be1382a7e0234b0da40f9b719 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/nc4interface.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/nemogcm.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/nemogcm.mod new file mode 100644 index 0000000000000000000000000000000000000000..594afc455c65b4992b417396a448e55da66235e7 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/nemogcm.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_averg_h2d.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_averg_h2d.mod new file mode 100644 index 0000000000000000000000000000000000000000..3affeb6314ac6182d403bee8dafca258c03c8e44 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_averg_h2d.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_const.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_const.mod new file mode 100644 index 0000000000000000000000000000000000000000..13f278e7b535b8efb9aa73f2a071c472eb8f5519 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_const.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_conv.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_conv.mod new file mode 100644 index 0000000000000000000000000000000000000000..c3718753a0f0397e4a6c1eb27421c41d38d0aa3a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_conv.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_conv_functions.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_conv_functions.h90 new file mode 100644 index 0000000000000000000000000000000000000000..8fc5ee99c9d5e21528edb2464c8e77316d186e21 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_conv_functions.h90 @@ -0,0 +1,294 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_conv_functions.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION potemp( ps, pt, pp, ppr ) + !!---------------------------------------------------------------------- + !! *** FUNCTION potemp *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: potemp(35,20,2000,0) = 19.621967 + !! + !! References : T. J. Mcdougall, D. R. Jackett, D. G. Wright + !! and R. Feistel + !! Accurate and computationally efficient algoritms for + !! potential temperatures and density of seawater + !! Journal of atmospheric and oceanic technology + !! Vol 20, 2003, pp 730-741 + !! + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + + REAL(KIND=wp), INTENT(IN) :: ps + REAL(KIND=wp), INTENT(IN) :: pt + REAL(KIND=wp), INTENT(IN) :: pp + REAL(KIND=wp), INTENT(IN) :: ppr + + !! * Local declarations + REAL(KIND=wp) :: zpol + REAL(KIND=wp), PARAMETER :: a1 = 1.067610e-05 + REAL(KIND=wp), PARAMETER :: a2 = -1.434297e-06 + REAL(KIND=wp), PARAMETER :: a3 = -7.566349e-09 + REAL(KIND=wp), PARAMETER :: a4 = -8.535585e-06 + REAL(KIND=wp), PARAMETER :: a5 = 3.074672e-08 + REAL(KIND=wp), PARAMETER :: a6 = 1.918639e-08 + REAL(KIND=wp), PARAMETER :: a7 = 1.788718e-10 + + zpol = a1 + a2 * ps + a3 * ( pp + ppr ) + a4 * pt & + & + a5 * ps * pt + a6 * pt * pt + a7 * pt * ( pp + ppr ) + + potemp = pt + ( pp - ppr ) * zpol + + END FUNCTION potemp + + REAL(KIND=wp) FUNCTION fspott( pft, pfs, pfp ) + !!---------------------------------------------------------------------- + !! *** FUNCTION fspott *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : Check value: fspott(10,25,1000) = 8.4678516 + !! + !! References : A. E. Gill + !! Atmosphere-Ocean Dynamics + !! Volume 30 (International Geophysics) + !! + !! History : + !! ! 07-05 (K. Mogensen) NEMO adopting of OPAVAR code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pft ! in situ temperature in degrees Celsius + REAL(KIND=wp) :: pfs ! salinity in psu + REAL(KIND=wp) :: pfp ! pressure in bars + + fspott = & + & pft - pfp * ( ( 3.6504e-4 & + & + pft * ( 8.3198e-5 & + & + pft * ( -5.4065e-7 & + & + pft * 4.0274e-9 ) ) ) & + & + ( pfs - 35.0 ) * ( 1.7439e-5 & + & - pft * 2.9778e-7 ) & + & + pfp * ( 8.9309e-7 & + & + pft * ( -3.1628e-8 & + & + pft * 2.1987e-10 ) & + & - ( pfs - 35.0 ) * 4.1057e-9 & + & + pfp * ( -1.6056e-10 & + & + pft * 5.0484e-12 ) ) ) + + END FUNCTION fspott + + REAL(KIND=wp) FUNCTION atg( p_s, p_t, p_p ) + !!---------------------------------------------------------------------- + !! *** FUNCTION atg *** + !! + !! ** Purpose : Compute adiabatic temperature gradient deg c per decibar + !! + !! ** Method : A regression formula is used + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: atg(40,40,10000) = 3.255974e-4 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + + REAL(KIND=wp), INTENT(IN) :: p_s ! Salinity in PSU + REAL(KIND=wp), INTENT(IN) :: p_t ! Temperature in centigrades + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars. + + !! * Local declarations + + REAL(KIND=wp) :: z_ds + + z_ds = p_s - 35.0 + atg = ((( -2.1687e-16 * p_t + 1.8676e-14 ) * p_t - 4.6206e-13 ) * p_p & + & + (( 2.7759e-12 * p_t - 1.1351e-10 ) * z_ds + (( - 5.4481e-14 * p_t & + & + 8.733e-12 ) * p_t - 6.7795e-10 ) * p_t + 1.8741e-8)) * p_p & + & + ( -4.2393e-8 * p_t + 1.8932e-6 ) * z_ds & + & + (( 6.6228e-10 * p_t - 6.836e-8 ) * p_t + 8.5258e-6 ) * p_t + 3.5803e-5 + + END FUNCTION atg + + REAL(KIND=wp) FUNCTION theta( p_s, p_t0, p_p0, p_pr ) + !!---------------------------------------------------------------------- + !! *** FUNCTION theta *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: theta(40,40,10000,0) = 36.89073 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_s + REAL(KIND=wp), INTENT(IN) :: p_t0 + REAL(KIND=wp), INTENT(IN) :: p_p0 + REAL(KIND=wp), INTENT(IN) :: p_pr + + !! * Local declarations + REAL(KIND=wp) :: z_p + REAL(KIND=wp) :: z_t + REAL(KIND=wp) :: z_h + REAL(KIND=wp) :: z_xk + REAL(KIND=wp) :: z_q + + z_p = p_p0 + z_t = p_t0 + z_h = p_pr - z_p + z_xk = z_h * atg( p_s, z_t, z_p ) + Z_t = z_t + 0.5 * z_xk + z_q = z_xk + z_p = z_p + 0.5 * z_h + z_xk = z_h * atg( p_s, z_t, z_p ) + z_t = z_t + 0.29289322 * ( z_xk - z_q ) + z_q = 0.58578644 * z_xk + 0.121320344 * z_q + z_xk = z_h * atg( p_s, z_t, z_p ) + z_t = z_t + 1.707106781 * ( z_xk - z_q ) + z_q = 3.414213562 * z_xk - 4.121320244 * z_q + z_p = z_p + 0.5 * z_h + z_xk = z_h * atg( p_s, z_t, z_p ) + theta = z_t + ( z_xk - 2.0 * z_q ) / 6.0 + + END FUNCTION theta + + REAL(KIND=wp) FUNCTION depth( p_p, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION depth *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: depth(10000,30) = 9712.653 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_gr + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_gr = 9.780318 * ( 1.0 + ( 5.2788e-3 + 2.36e-5 * z_x ) * z_x ) + 1.092e-6 * p_p + depth = ((( -1.82e-15 * p_p + 2.279e-10 ) * p_p - 2.2512e-5 ) * p_p + 9.72659 ) * p_p + depth = depth / z_gr + + END FUNCTION depth + + REAL(KIND=wp) FUNCTION p_to_dep( p_p, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION p_to_dep *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : A regression formula is used. This version is less + !! accurate the "depth" but invertible. + !! + !! ** Action : + !! + !! References : P.M Saunders + !! Pratical conversion of pressure to depth + !! Journal of physical oceanography Vol 11, 1981, pp 573-574 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_c1 + REAL(KIND=wp) :: z_c2 + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_c1 = ( 5.92 + 5.25 * z_x ) * 1e-3 + z_c2 = 2.21e-6 + p_to_dep = (1 - z_c1) * p_p - z_c2 * p_p * p_p + + END FUNCTION p_to_dep + + REAL(KIND=wp) FUNCTION dep_to_p( p_dep, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION dep_to_p *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : The expression used in p_to_dep is inverted. + !! + !! ** Action : + !! + !! References : P.M Saunders + !! Pratical conversion of pressure to depth + !! Journal of physical oceanography Vol 11, 1981, pp 573-574 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_dep ! Depth in meters + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_c1 + REAL(KIND=wp) :: z_c2 + REAL(KIND=wp) :: z_d + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_c1 = ( 5.92 + 5.25 * z_x ) * 1e-3 + z_c2 = 2.21e-6 + z_d = ( z_c1 - 1 ) * ( z_c1 - 1 ) - 4 * z_c2 * p_dep + dep_to_p = (( 1 - z_c1 ) - SQRT( z_d )) / ( 2 * z_c2 ) + + END FUNCTION dep_to_p \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_fbm.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_fbm.mod new file mode 100644 index 0000000000000000000000000000000000000000..265977fbc163cf5034e417fad385784ad1bd04d0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_fbm.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_grd_bruteforce.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_grd_bruteforce.h90 new file mode 100644 index 0000000000000000000000000000000000000000..e15bbbe419ebba5164f98d06e711c0e76cfcf469 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_grd_bruteforce.h90 @@ -0,0 +1,349 @@ +SUBROUTINE obs_grd_bruteforce( kpi, kpj, kpiglo, kpjglo, & + & kldi, klei, kldj, klej, & + & kmyproc, ktotproc, & + & pglam, pgphi, pmask, & + & kobs, plam, pphi, kobsi, kobsj, & + & kproc) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_grd_bruteforce *** + !! + !! ** Purpose : Search gridpoints to find the grid box containing + !! the observations + !! + !! ** Method : Call to linquad + !! + !! ** Action : Return kproc holding the observation and kiobsi,kobsj + !! valid on kproc=kmyproc processor only. + !! + !! History : + !! ! 2001-11 (N. Daget, A. Weaver) + !! ! 2006-03 (A. Weaver) NEMOVAR migration. + !! ! 2006-05 (K. Mogensen) Moved to to separate routine. + !! ! 2007-10 (A. Vidard) Bug fix in wrap around checks; cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kpi ! Number of local longitudes + INTEGER, INTENT(IN) :: kpj ! Number of local latitudes + INTEGER, INTENT(IN) :: kpiglo ! Number of global longitudes + INTEGER, INTENT(IN) :: kpjglo ! Number of global latitudes + INTEGER, INTENT(IN) :: kldi ! Start of inner domain in i + INTEGER, INTENT(IN) :: klei ! End of inner domain in i + INTEGER, INTENT(IN) :: kldj ! Start of inner domain in j + INTEGER, INTENT(IN) :: klej ! End of inner domain in j + INTEGER, INTENT(IN) :: kmyproc ! Processor number for MPP + INTEGER, INTENT(IN) :: ktotproc ! Total number of processors + REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) :: & + & pglam, & ! Grid point longitude + & pgphi, & ! Grid point latitude + & pmask ! Grid point mask + INTEGER,INTENT(IN) :: kobs ! Size of the observation arrays + REAL(KIND=wp), DIMENSION(kobs), INTENT(IN) :: & + & plam, & ! Longitude of obsrvations + & pphi ! Latitude of observations + INTEGER, DIMENSION(kobs), INTENT(OUT) :: & + & kobsi, & ! I-index of observations + & kobsj, & ! J-index of observations + & kproc ! Processor number of observations + + !! * Local declarations + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zplam, zpphi + REAL(wp) :: zlammax + REAL(wp) :: zlam + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jo + INTEGER :: jlon + INTEGER :: jlat + INTEGER :: joffset + INTEGER :: jostride + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax,& + & zphitmin,& + & zlamtmax,& + & zlamtmin + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: & + & llinvalidcell + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zlamtm, & + & zphitm + + !----------------------------------------------------------------------- + ! Define grid setup for grid search + !----------------------------------------------------------------------- + IF (ln_grid_global) THEN + jlon = kpiglo + jlat = kpjglo + joffset = kmyproc + jostride = ktotproc + ELSE + jlon = kpi + jlat = kpj + joffset = 0 + jostride = 1 + ENDIF + !----------------------------------------------------------------------- + ! Set up data for grid search + !----------------------------------------------------------------------- + ALLOCATE( & + & zlamg(jlon,jlat), & + & zphig(jlon,jlat), & + & zmskg(jlon,jlat), & + & zphitmax(jlon-1,jlat-1), & + & zphitmin(jlon-1,jlat-1), & + & zlamtmax(jlon-1,jlat-1), & + & zlamtmin(jlon-1,jlat-1), & + & llinvalidcell(jlon-1,jlat-1), & + & zlamtm(4,jlon-1,jlat-1), & + & zphitm(4,jlon-1,jlat-1) & + & ) + !----------------------------------------------------------------------- + ! Copy data to local arrays + !----------------------------------------------------------------------- + IF (ln_grid_global) THEN + zlamg(:,:) = -1.e+10 + zphig(:,:) = -1.e+10 + zmskg(:,:) = -1.e+10 + DO jj = kldj, klej + DO ji = kldi, klei + zlamg(mig(ji),mjg(jj)) = pglam(ji,jj) + zphig(mig(ji),mjg(jj)) = pgphi(ji,jj) + zmskg(mig(ji),mjg(jj)) = pmask(ji,jj) + END DO + END DO + CALL mpp_global_max( zlamg ) + CALL mpp_global_max( zphig ) + CALL mpp_global_max( zmskg ) + ELSE + DO jj = 1, jlat + DO ji = 1, jlon + zlamg(ji,jj) = pglam(ji,jj) + zphig(ji,jj) = pgphi(ji,jj) + zmskg(ji,jj) = pmask(ji,jj) + END DO + END DO + ENDIF + !----------------------------------------------------------------------- + ! Copy longitudes and latitudes + !----------------------------------------------------------------------- + ALLOCATE( & + & zplam(kobs), & + & zpphi(kobs) & + & ) + DO jo = 1, kobs + zplam(jo) = plam(jo) + zpphi(jo) = pphi(jo) + END DO + !----------------------------------------------------------------------- + ! Set default values for output + !----------------------------------------------------------------------- + kproc(:) = -1 + kobsi(:) = -1 + kobsj(:) = -1 + !----------------------------------------------------------------------- + ! Copy grid positions to temporary arrays and renormalize to 0 to 360. + !----------------------------------------------------------------------- + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + zlamtm(1,ji,jj) = zlamg(ji ,jj ) + zphitm(1,ji,jj) = zphig(ji ,jj ) + zlamtm(2,ji,jj) = zlamg(ji+1,jj ) + zphitm(2,ji,jj) = zphig(ji+1,jj ) + zlamtm(3,ji,jj) = zlamg(ji+1,jj+1) + zphitm(3,ji,jj) = zphig(ji+1,jj+1) + zlamtm(4,ji,jj) = zlamg(ji ,jj+1) + zphitm(4,ji,jj) = zphig(ji ,jj+1) + END DO + END DO + WHERE ( zlamtm(:,:,:) < 0.0_wp ) + zlamtm(:,:,:) = zlamtm(:,:,:) + 360.0_wp + END WHERE + WHERE ( zlamtm(:,:,:) > 360.0_wp ) + zlamtm(:,:,:) = zlamtm(:,:,:) - 360.0_wp + END WHERE + !----------------------------------------------------------------------- + ! Handle case of the wraparound; beware, not working with orca180 + !----------------------------------------------------------------------- + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + zlammax = MAXVAL( zlamtm(:,ji,jj) ) + WHERE (zlammax - zlamtm(:, ji, jj) > 180 ) & + & zlamtm(:,ji,jj) = zlamtm(:,ji,jj) + 360._wp + zphitmax(ji,jj) = MAXVAL(zphitm(:,ji,jj)) + zphitmin(ji,jj) = MINVAL(zphitm(:,ji,jj)) + zlamtmax(ji,jj) = MAXVAL(zlamtm(:,ji,jj)) + zlamtmin(ji,jj) = MINVAL(zlamtm(:,ji,jj)) + END DO + END DO + !----------------------------------------------------------------------- + ! Search for boxes with only land points mark them invalid + !----------------------------------------------------------------------- + llinvalidcell(:,:) = .FALSE. + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + llinvalidcell(ji,jj) = & + & zmskg(ji ,jj ) == 0.0_wp .AND. & + & zmskg(ji+1,jj ) == 0.0_wp .AND. & + & zmskg(ji+1,jj+1) == 0.0_wp .AND. & + & zmskg(ji ,jj+1) == 0.0_wp + END DO + END DO + + !------------------------------------------------------------------------ + ! Master loop for grid search + !------------------------------------------------------------------------ + + DO jo = 1+joffset, kobs, jostride + + !--------------------------------------------------------------------- + ! Ensure that all observation longtiudes are between 0 and 360 + !--------------------------------------------------------------------- + + IF ( zplam(jo) < 0.0_wp ) zplam(jo) = zplam(jo) + 360.0_wp + IF ( zplam(jo) > 360.0_wp ) zplam(jo) = zplam(jo) - 360.0_wp + + !--------------------------------------------------------------------- + ! Find observations which are on within 1e-6 of a grid point + !--------------------------------------------------------------------- + + gridloop: DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + IF ( ABS( zphig(ji,jj) - zpphi(jo) ) < 1e-6 ) THEN + zlam = zlamg(ji,jj) + IF ( zlam < 0.0_wp ) zlam = zlam + 360.0_wp + IF ( zlam > 360.0_wp ) zlam = zlam - 360.0_wp + IF ( ABS( zlam - zplam(jo) ) < 1e-6 ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = kmyproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = kmyproc + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridloop + ENDIF + ENDIF + ENDIF + END DO + END DO gridloop + + !--------------------------------------------------------------------- + ! Ensure that all observation longtiudes are between -180 and 180 + !--------------------------------------------------------------------- + + IF ( zplam(jo) > 180 ) zplam(jo) = zplam(jo) - 360.0_wp + + !--------------------------------------------------------------------- + ! Do coordinate search using brute force. + ! - For land points kproc is set to number of the processor + 1000000 + ! and we continue the search. + ! - For ocean points kproc is set to the number of the processor + ! and we stop the search. + !--------------------------------------------------------------------- + + IF ( kproc(jo) == -1 ) THEN + + ! Normal case + gridpoints : DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + + IF ( ( zplam(jo) > zlamtmax(ji,jj) ) .OR. & + & ( zplam(jo) < zlamtmin(ji,jj) ) ) CYCLE + + IF ( ABS( zpphi(jo) ) < 85 ) THEN + IF ( ( zpphi(jo) > zphitmax(ji,jj) ) .OR. & + & ( zpphi(jo) < zphitmin(ji,jj) ) ) CYCLE + ENDIF + + IF ( linquad( zplam(jo), zpphi(jo), & + & zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = kmyproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = kmyproc + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridpoints + ENDIF + ENDIF + + END DO + END DO gridpoints + + ENDIF + + ! In case of failure retry for obs. longtiude + 360. + IF ( kproc(jo) == -1 ) THEN + gridpoints_greenwich : DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + + IF ( ( zplam(jo)+360.0_wp > zlamtmax(ji,jj) ) .OR. & + & ( zplam(jo)+360.0_wp < zlamtmin(ji,jj) ) ) CYCLE + + IF ( ABS( zpphi(jo) ) < 85 ) THEN + IF ( ( zpphi(jo) > zphitmax(ji,jj) ) .OR. & + & ( zpphi(jo) < zphitmin(ji,jj) ) ) CYCLE + ENDIF + + IF ( linquad( zplam(jo)+360.0_wp, zpphi(jo), & + & zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = kmyproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = kmyproc + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridpoints_greenwich + ENDIF + ENDIF + + END DO + END DO gridpoints_greenwich + + ENDIF + END DO + + !---------------------------------------------------------------------- + ! Synchronize kproc on all processors + !---------------------------------------------------------------------- + IF ( ln_grid_global ) THEN + CALL obs_mpp_max_integer( kproc, kobs ) + CALL obs_mpp_max_integer( kobsi, kobs ) + CALL obs_mpp_max_integer( kobsj, kobs ) + ELSE + CALL obs_mpp_find_obs_proc( kproc, kobs ) + ENDIF + + WHERE( kproc(:) >= 1000000 ) + kproc(:) = kproc(:) - 1000000 + END WHERE + + DEALLOCATE( & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax, & + & zphitmin, & + & zlamtmax, & + & zlamtmin, & + & llinvalidcell, & + & zlamtm, & + & zphitm, & + & zplam, & + & zpphi & + & ) + + END SUBROUTINE obs_grd_bruteforce \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_grid.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_grid.mod new file mode 100644 index 0000000000000000000000000000000000000000..df1f5e5343410153252a272d76363ddd7eee5ca0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_grid.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_inter_h2d.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_inter_h2d.mod new file mode 100644 index 0000000000000000000000000000000000000000..b615dbea7058055089bfb0e114d375cc252f1ac4 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_inter_h2d.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_inter_sup.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_inter_sup.mod new file mode 100644 index 0000000000000000000000000000000000000000..43587868529f186fa361c0578680c6c1ac92188f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_inter_sup.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_inter_z1d.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_inter_z1d.mod new file mode 100644 index 0000000000000000000000000000000000000000..ae1b8b7b4714d49962df4ac62a9bab40ccca1742 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_inter_z1d.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_level_search.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_level_search.h90 new file mode 100644 index 0000000000000000000000000000000000000000..b79c1a482e05148f4bab311b5d194062005b76f1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_level_search.h90 @@ -0,0 +1,51 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_level_search.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE obs_level_search( kgrd, pgrddep, kobs, pobsdep, kobsk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_level_search *** + !! + !! ** Purpose : Search levels to find matching level to observed depth + !! + !! ** Method : Straightforward search + !! + !! ** Action : + !! + !! History : + !! ! 2001-11 (N. Daget, A. Weaver) + !! ! 2006-03 (A. Weaver) NEMOVAR migration. + !! ! 2006-05 (K. Mogensen) Moved to to separate routine. + !! ! 2006-10 (A. Weaver) Cleanup + !! ! 2008-10 (K. Mogensen) Remove assumptions on grid. + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kgrd ! Number of gridpoints + REAL(KIND=wp), DIMENSION(kgrd), INTENT(INOUT) :: & + & pgrddep ! Depths of gridpoints + INTEGER, INTENT(IN) :: & + & kobs ! Number of observations + REAL(KIND=wp), DIMENSION(kobs), INTENT(INOUT) :: & + & pobsdep ! Depths of observations + INTEGER ,DIMENSION(kobs), INTENT(OUT) :: & + & kobsk ! Level indices of observations + + !! * Local declarations + INTEGER :: ji + INTEGER :: jk + + !------------------------------------------------------------------------ + ! Search levels for each observations to find matching level + !------------------------------------------------------------------------ + DO ji = 1, kobs + kobsk(ji) = 1 + depk: DO jk = 2, kgrd + IF ( pgrddep(jk) >= pobsdep(ji) ) EXIT depk + END DO depk + kobsk(ji) = jk + END DO + + END SUBROUTINE obs_level_search \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_mpp.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_mpp.mod new file mode 100644 index 0000000000000000000000000000000000000000..a3ba9a92f514d093085d0052d2047a083f382d66 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_mpp.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_oper.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_oper.mod new file mode 100644 index 0000000000000000000000000000000000000000..9b1bd372d368b6d192c67e498a61483f9cc0ab15 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_oper.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_prep.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_prep.mod new file mode 100644 index 0000000000000000000000000000000000000000..5b8adcdecd1ea97eddd40a0d596f50063c1b1c3f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_prep.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_profiles.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_profiles.mod new file mode 100644 index 0000000000000000000000000000000000000000..c0411417c01b998288982891e5ab966e32501187 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_profiles.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_profiles_def.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_profiles_def.mod new file mode 100644 index 0000000000000000000000000000000000000000..5039eb3ec73499fc7610e081a573afd6328341d9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_profiles_def.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_read_altbias.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_read_altbias.mod new file mode 100644 index 0000000000000000000000000000000000000000..0bc66196a84fd91a69136fcfe3eff9e7f64617bb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_read_altbias.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_read_prof.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_read_prof.mod new file mode 100644 index 0000000000000000000000000000000000000000..bbde74b5dde8c996fd324bead08039122fbdd598 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_read_prof.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_read_surf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_read_surf.mod new file mode 100644 index 0000000000000000000000000000000000000000..a9d7cc7c018bad4d0ed2671ad7d3cc9d65f96e66 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_read_surf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_readmdt.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_readmdt.mod new file mode 100644 index 0000000000000000000000000000000000000000..20386d29b10afb404706948eec956dd03d306631 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_readmdt.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_rot_vel.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_rot_vel.mod new file mode 100644 index 0000000000000000000000000000000000000000..65a2f5888aff478f509c2a5c8155aaa375d7330e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_rot_vel.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_sort.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_sort.mod new file mode 100644 index 0000000000000000000000000000000000000000..5435738fc38cd5378432da024d337137e8bfd93a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_sort.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_sstbias.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_sstbias.mod new file mode 100644 index 0000000000000000000000000000000000000000..824bed3d462e0845c74853aa313c57fcb2b126cd Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_sstbias.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_surf_def.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_surf_def.mod new file mode 100644 index 0000000000000000000000000000000000000000..c3b50965f8db8622aad7b6527e769925afc05cf6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_surf_def.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_types.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_types.mod new file mode 100644 index 0000000000000000000000000000000000000000..19a56e2e78b91e5afc71ad496e5e0e8568abc611 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_types.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_utils.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_utils.mod new file mode 100644 index 0000000000000000000000000000000000000000..f313fffa25d8e6fd6f36cad297661ef8996ac539 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_utils.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_write.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_write.mod new file mode 100644 index 0000000000000000000000000000000000000000..6a078a5fdc52525f3e576ff436bd3c56fa4ce32a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obs_write.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obsinter_h2d.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obsinter_h2d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..103db7a9e72f8c5374d54a3feef1ed081bb86c5f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obsinter_h2d.h90 @@ -0,0 +1,1359 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obsinter_h2d.h90 10353 2018-11-21 16:04:47Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE obs_int_h2d_init( kpk, kpk2, k2dint, plam, pphi, & + & pglam, pgphi, pmask, pweig, pobsmask, & + & iminpoints ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d *** + !! + !! ** Purpose : Computes weights for horizontal interpolation to the + !! observation point. + !! + !! ** Method : Horizontal interpolation to the observation point using + !! model values at the corners of the surrounding grid + !! points. + !! + !! Interpolation Schemes : + !! + !! 1) k2dint = 0: Distance-weighted interpolation scheme 1 + !! + !! The interpolation weights are computed as a weighted + !! sum of the distance between the model grid points (A) + !! and the observation point (B). Distance (s) is computed + !! using the great-circle distance formula: + !! + !! s(AB) = arcos( sin( phiA ) x sin( phiB ) + !! + cos( phiA ) x cos( phiB ) + !! x cos( lamB - lamA ) ) + !! + !! 2) k2dint = 1: Distance-weighted interpolation scheme 2 + !! + !! As k2dint = 0 but with distance (ds) computed using + !! a small-angle approximation to the great-circle formula: + !! + !! ds(AB) = sqrt( ( phiB - phiA )^{2} + !! + ( ( lamB - lamA ) * cos( phiB ) )^{2} ) + !! + !! 3) k2dint = 2: Bilinear interpolation on a geographical grid + !! + !! The interpolation is split into two 1D interpolations in + !! the longitude and latitude directions, respectively. + !! + !! 4) k2dint = 3: General bilinear remapping interpolation + !! + !! An iterative scheme that involves first mapping a + !! quadrilateral cell into a cell with coordinates + !! (0,0), (1,0), (0,1) and (1,1). + !! + !! 5) k2dint = 4: Polynomial interpolation + !! + !! The interpolation weights are computed by fitting a + !! polynomial function of the form + !! + !! P(i) = a1(i) + a2(i) * phi + a3(i) * plam + !! + a4(i) * phi * plam + !! + !! through the model values at the four surrounding grid points. + !! + !! ** Action : + !! + !! References : Jones, P.: A users guide for SCRIP: A Spherical + !! Coordinate Remapping and Interpolation Package. + !! Version 1.4. Los Alomos. + !! + !! http://www.acl.lanl.gov/climate/software/SCRIP/SCRIPmain.html + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) NEMOVAR migration + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-08 (K. Mogensen) Split in two routines for easier adj. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk, & ! Parameter values for automatic arrays + & kpk2, & + & k2dint ! Interpolation scheme options + ! = 0 distance-weighted (great circle) + ! = 1 distance-weighted (small angle) + ! = 2 bilinear (geographical grid) + ! = 3 bilinear (quadrilateral grid) + ! = 4 polynomial (quadrilateral grid) + REAL(KIND=wp), INTENT(INOUT) :: & + & plam, & + & pphi ! Geographical (lat,lon) coordinates of + ! observation + REAL(KIND=wp), DIMENSION(2,2), INTENT(IN) :: & + & pglam, & ! Model variable lat + & pgphi ! Model variable lon + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(OUT) :: & + & pweig ! Weights for interpolation + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsmask ! Vertical mask for observations + INTEGER, INTENT(IN), OPTIONAL :: & + & iminpoints ! Reject point which is not surrounded + ! by at least iminpoints sea points + + !! * Local declarations + INTEGER :: & + & jk + INTEGER :: & + & ikmax, & + & iamb1, & + & iamb2 + REAL(KIND=wp) :: & + & zphimm, & + & zphimp, & + & zphipm, & + & zphipp, & + & zlammm, & + & zlammp, & + & zlampm, & + & zlampp, & + & zphimin, & + & zphimax, & + & zlammin, & + & zlammax + REAL(KIND=wp), DIMENSION(kpk2) :: & + & z2dmm, & + & z2dmp, & + & z2dpm, & + & z2dpp, & + & z2dmmt, & + & z2dmpt, & + & z2dpmt, & + & z2dppt, & + & zsum + LOGICAL :: & + & ll_ds1, & + & ll_skip, & + & ll_fail + + !------------------------------------------------------------------------ + ! Constants for the 360 degrees ambiguity + !------------------------------------------------------------------------ + iamb1 = 10 ! dlam < iamb1 * dphi + iamb2 = 3 ! Special treatment if iamb2 * lam < max(lam) + + !------------------------------------------------------------------------ + ! Initialize number of levels + !------------------------------------------------------------------------ + IF ( kpk2 == 1 ) THEN + ikmax = 1 + ELSEIF ( kpk2 == kpk) THEN + ikmax = kpk-1 + ENDIF + !------------------------------------------------------------------------ + ! Initialize the cell corners + !------------------------------------------------------------------------ + zphimm = pgphi(1,1) + zphimp = pgphi(1,2) + zphipm = pgphi(2,1) + zphipp = pgphi(2,2) + zlammm = pglam(1,1) + zlammp = pglam(1,2) + zlampm = pglam(2,1) + zlampp = pglam(2,2) + + !------------------------------------------------------------------------ + ! Treat the 360 degrees ambiguity + !------------------------------------------------------------------------ + DO WHILE ( ( zlammm < 0.0_wp ).OR.( zlammm > 360.0_wp ) & + & .OR.( zlampm < 0.0_wp ).OR.( zlampm > 360.0_wp ) & + & .OR.( zlampp < 0.0_wp ).OR.( zlampp > 360.0_wp ) & + & .OR.( zlammp < 0.0_wp ).OR.( zlammp > 360.0_wp ) ) + + IF ( zlammm < 0.0_wp ) zlammm = zlammm + 360.0_wp + IF ( zlammm > 360.0_wp ) zlammm = zlammm - 360.0_wp + IF ( zlammp < 0.0_wp ) zlammp = zlammp + 360.0_wp + IF ( zlammp > 360.0_wp ) zlammp = zlammp - 360.0_wp + IF ( zlampm < 0.0_wp ) zlampm = zlampm + 360.0_wp + IF ( zlampm > 360.0_wp ) zlampm = zlampm - 360.0_wp + IF ( zlampp < 0.0_wp ) zlampp = zlampp + 360.0_wp + IF ( zlampp > 360.0_wp ) zlampp = zlampp - 360.0_wp + + END DO + + DO WHILE ( ( plam < 0.0_wp ) .OR. ( plam > 360.0_wp ) ) + IF ( plam < 0.0_wp ) plam = plam + 360.0_wp + IF ( plam > 360.0_wp ) plam = plam - 360.0_wp + END DO + + !------------------------------------------------------------------------ + ! Special case for observation on grid points + !------------------------------------------------------------------------ + ll_skip = .FALSE. + IF ( ( ABS( zphimm - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlammm - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 1.0_wp + z2dpm(:) = 0.0_wp + z2dmp(:) = 0.0_wp + z2dpp(:) = 0.0_wp + ll_skip = .TRUE. + ENDIF + IF ( ( ABS( zphipm - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlampm - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 0.0_wp + z2dpm(:) = 1.0_wp + z2dmp(:) = 0.0_wp + z2dpp(:) = 0.0_wp + ll_skip = .TRUE. + ENDIF + IF ( ( ABS( zphimp - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlammp - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 0.0_wp + z2dpm(:) = 0.0_wp + z2dmp(:) = 1.0_wp + z2dpp(:) = 0.0_wp + ll_skip = .TRUE. + ENDIF + IF ( ( ABS( zphipp - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlampp - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 0.0_wp + z2dpm(:) = 0.0_wp + z2dmp(:) = 0.0_wp + z2dpp(:) = 1.0_wp + ll_skip = .TRUE. + ENDIF + + IF ( .NOT.ll_skip ) THEN + + zphimin = MIN( zphimm, zphipm, zphipp, zphimp ) + zphimax = MAX( zphimm, zphipm, zphipp, zphimp ) + zlammin = MIN( zlammm, zlampm, zlampp, zlammp ) + zlammax = MAX( zlammm, zlampm, zlampp, zlammp ) + + IF ( ( ( zlammax - zlammin ) / ( zphimax - zphimin ) ) > iamb1 ) THEN + IF ( iamb2 * zlammm < zlammax ) zlammm = zlammm + 360.0_wp + IF ( iamb2 * zlammp < zlammax ) zlammp = zlammp + 360.0_wp + IF ( iamb2 * zlampm < zlammax ) zlampm = zlampm + 360.0_wp + IF ( iamb2 * zlampp < zlammax ) zlampp = zlampp + 360.0_wp + ENDIF + + zlammin = MIN( zlammm, zlampm, zlampp, zlammp ) + IF ( zlammm > ( zlammin + 180.0_wp ) ) zlammm = zlammm - 360.0_wp + IF ( zlammp > ( zlammin + 180.0_wp ) ) zlammp = zlammp - 360.0_wp + IF ( zlampm > ( zlammin + 180.0_wp ) ) zlampm = zlampm - 360.0_wp + IF ( zlampp > ( zlammin + 180.0_wp ) ) zlampp = zlampp - 360.0_wp + + IF ( plam < zlammin ) plam = plam + 360.0_wp + z2dmm = 0.0_wp + z2dmp = 0.0_wp + z2dpm = 0.0_wp + z2dpp = 0.0_wp + SELECT CASE (k2dint) + + CASE(0) + CALL obs_int_h2d_ds1( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + CASE(1) + CALL obs_int_h2d_ds2( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + CASE(2) + CALL obs_int_h2d_bil( kpk2, ikmax, & + & pphi, plam, pmask, & + & zlammp, & + & zphipm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + CASE(3) + CALL obs_int_h2d_bir( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp, ll_fail ) + IF (ll_fail) THEN + IF(lwp) THEN + WRITE(numout,*)'Bilinear weight computation failed' + WRITE(numout,*)'Switching to great circle distance' + WRITE(numout,*) + ENDIF + CALL obs_int_h2d_ds1( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + ENDIF + CASE(4) + CALL obs_int_h2d_pol( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + END SELECT + + ENDIF + !------------------------------------------------------------------------ + ! Compute weights for interpolation to the observation point + !------------------------------------------------------------------------ + pobsmask(:) = 0.0_wp + pweig(:,:,:) = 0.0_wp + ! ll_ds1 is used for failed interpolations + ll_ds1 = .FALSE. + DO jk = 1, ikmax + IF (PRESENT(iminpoints)) THEN + IF (NINT(SUM(pmask(:,:,jk))) 0.0_wp ) .AND. & + & ( pmask(1,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dmp(jk) > 0.0_wp ) .AND. & + & ( pmask(1,2,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dpm(jk) > 0.0_wp ) .AND. & + & ( pmask(2,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dpp(jk) > 0.0_wp ) .AND. & + & ( pmask(2,2,jk) == 1.0_wp ) ) ) pobsmask(jk)=1.0_wp + ELSE + ! If the interpolation has failed due to the point + ! being on the intersect of two land points retry with + ! k2dint = 0 + IF ( ( pmask(1,1,jk) /= 0.0_wp ).OR. & + & ( pmask(1,2,jk) /= 0.0_wp ).OR. & + & ( pmask(2,1,jk) /= 0.0_wp ).OR. & + & ( pmask(2,2,jk) /= 0.0_wp ) ) THEN + ! If ll_ds1 is false compute k2dint = 0 weights + IF ( .NOT.ll_ds1 ) THEN + CALL obs_int_h2d_ds1( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmmt, z2dmpt, z2dpmt, z2dppt ) + ll_ds1 = .TRUE. + ENDIF + zsum(jk) = z2dmmt(jk) + z2dmpt(jk) + z2dpmt(jk) + z2dppt(jk) + IF ( zsum(jk) /= 0.0_wp ) THEN + pweig(1,1,jk) = z2dmmt(jk) + pweig(1,2,jk) = z2dmpt(jk) + pweig(2,1,jk) = z2dpmt(jk) + pweig(2,2,jk) = z2dppt(jk) + ! Set the vertical mask + IF ( ( ( z2dmmt(jk) > 0.0_wp ) .AND. & + & ( pmask(1,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dmpt(jk) > 0.0_wp ) .AND. & + & ( pmask(1,2,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dpmt(jk) > 0.0_wp) .AND. & + & ( pmask(2,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dppt(jk) > 0.0_wp ) .AND. & + & ( pmask(2,2,jk) == 1.0_wp ) ) ) & + & pobsmask(jk)=1.0_wp + ENDIF + ENDIF + ENDIF + END DO + + END SUBROUTINE obs_int_h2d_init + + SUBROUTINE obs_int_h2d( kpk, kpk2, & + & pweig, pmod, pobsk ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d *** + !! + !! ** Purpose : Horizontal interpolation to the observation point. + !! + !! ** Method : Horizontal interpolation to the observation point using + !! model values at the corners of the surrounding grid + !! points. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) NEMOVAR migration + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-08 (K. Mogensen) Split in two routines for easier adj. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk, & ! Parameter values for automatic arrays + & kpk2 + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pweig ! Interpolation weights + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmod ! Model variable to interpolate + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsk ! Model profile interpolated to obs (i,j) pt + + !! * Local declarations + INTEGER :: & + & jk + INTEGER :: & + & ikmax + REAL(KIND=wp) :: & + & zsum + !------------------------------------------------------------------------ + ! Initialize number of levels + !------------------------------------------------------------------------ + IF ( kpk2 == 1 ) THEN + ikmax = 1 + ELSEIF ( kpk2 == kpk) THEN + ikmax = kpk-1 + ENDIF + !------------------------------------------------------------------------ + ! Interpolate to the observation point + !------------------------------------------------------------------------ + pobsk(:) = obfillflt + DO jk = 1, ikmax + zsum = pweig(1,1,jk) + pweig(1,2,jk) + pweig(2,1,jk) + pweig(2,2,jk) + IF ( zsum /= 0.0_wp ) THEN + pobsk(jk) = ( pweig(1,1,jk) * pmod(1,1,jk) & + & + pweig(1,2,jk) * pmod(1,2,jk) & + & + pweig(2,1,jk) * pmod(2,1,jk) & + & + pweig(2,2,jk) * pmod(2,2,jk) & + & ) / zsum + ENDIF + END DO + + END SUBROUTINE obs_int_h2d + + SUBROUTINE obs_int_h2d_ds1( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_ds1 *** + !! + !! ** Purpose : Distance-weighted interpolation scheme (k2dint = 0) + !! + !! ** Method : The interpolation weights are computed as a weighted + !! sum of the distance between the model grid points (A) + !! and the observation point (B). + !! + !! Distance (s) is computed using the great-circle distance formula: + !! + !! s(AB) = arcos( sin( phiA ) x sin( phiB ) + !! + cos( phiA ) x cos( phiB ) x cos( lamB - lamA ) + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Modules used + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zphi2, & + & zlam2, & + & zcola, & + & za2, & + & zb2, & + & zc2, & + & zphimm2, & + & zphimp2, & + & zphipm2, & + & zphipp2, & + & zlammm2, & + & zlammp2, & + & zlampm2, & + & zlampp2, & + & za1mm, & + & za1mp, & + & za1pm, & + & za1pp, & + & zcomm, & + & zcomp, & + & zcopm, & + & zcopp, & + & zb1mm, & + & zb1mp, & + & zb1pm, & + & zb1pp, & + & zc1mm, & + & zc1mp, & + & zc1pm, & + & zc1pp, & + & zsopmpp, & + & zsommmp, & + & zsomm, & + & zsomp, & + & zsopm, & + & zsopp + + !------------------------------------------------------------------------ + ! Distance-weighted interpolation using the great circle formula + !------------------------------------------------------------------------ + zphi2 = pphi * rad + zlam2 = plam * rad + zcola = COS( zphi2 ) + za2 = SIN( zphi2 ) + zb2 = zcola * COS( zlam2 ) + zc2 = zcola * SIN( zlam2 ) + + zphimm2 = pphimm * rad + zphimp2 = pphimp * rad + zphipm2 = pphipm * rad + zphipp2 = pphipp * rad + + zlammm2 = plammm * rad + zlammp2 = plammp * rad + zlampm2 = plampm * rad + zlampp2 = plampp * rad + + za1mm = SIN( zphimm2 ) + za1mp = SIN( zphimp2 ) + za1pm = SIN( zphipm2 ) + za1pp = SIN( zphipp2 ) + + zcomm = COS( zphimm2 ) + zcomp = COS( zphimp2 ) + zcopm = COS( zphipm2 ) + zcopp = COS( zphipp2 ) + + zb1mm = zcomm * COS( zlammm2 ) + zb1mp = zcomp * COS( zlammp2 ) + zb1pm = zcopm * COS( zlampm2 ) + zb1pp = zcopp * COS( zlampp2 ) + + zc1mm = zcomm * SIN( zlammm2 ) + zc1mp = zcomp * SIN( zlammp2 ) + zc1pm = zcopm * SIN( zlampm2 ) + zc1pp = zcopp * SIN( zlampp2 ) + + ! Function for arcsin(sqrt(1-x^2) version of great-circle formula + zsomm = grt_cir_dis( za1mm, za2, zb1mm, zb2, zc1mm, zc2 ) + zsomp = grt_cir_dis( za1mp, za2, zb1mp, zb2, zc1mp, zc2 ) + zsopm = grt_cir_dis( za1pm, za2, zb1pm, zb2, zc1pm, zc2 ) + zsopp = grt_cir_dis( za1pp, za2, zb1pp, zb2, zc1pp, zc2 ) + + zsopmpp = zsopm * zsopp + zsommmp = zsomm * zsomp + DO jk = 1, kmax + p2dmm(jk) = zsomp * zsopmpp * pmask(1,1,jk) + p2dmp(jk) = zsomm * zsopmpp * pmask(1,2,jk) + p2dpm(jk) = zsopp * zsommmp * pmask(2,1,jk) + p2dpp(jk) = zsopm * zsommmp * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_ds1 + + SUBROUTINE obs_int_h2d_ds2( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_ds2 *** + !! + !! ** Purpose : Distance-weighted interpolation scheme (k2dint = 1) + !! + !! ** Method : As k2dint = 0 but with distance (ds) computed using a + !! small-angle approximation to the great-circle distance + !! formula: + !! + !! ds(AB) = sqrt( ( phiB - phiA )^{2} + !! + ( ( lamB - lamA ) * cos( phiB ) )^{2} ) + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !!----------------------------------------------------------------------- + !! * Modules used + !!----------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zcosp, & + & zdlmm, & + & zdlmp, & + & zdlpm, & + & zdlpp, & + & zdpmm, & + & zdpmp, & + & zdppm, & + & zdppp, & + & zsomm, & + & zsomp, & + & zsopm, & + & zsopp, & + & zsopmpp, & + & zsommmp + + !------------------------------------------------------------------------ + ! Distance-weighted interpolation with a small angle approximation + !------------------------------------------------------------------------ + zcosp = COS( pphi * rad ) + + zdlmm = plammm - plam + zdlmp = plammp - plam + zdlpm = plampm - plam + zdlpp = plampp - plam + + zdpmm = pphimm - pphi + zdpmp = pphimp - pphi + zdppm = pphipm - pphi + zdppp = pphipp - pphi + + zsomm = grt_cir_dis_saa( zdlmm, zdpmm, zcosp ) + zsomp = grt_cir_dis_saa( zdlmp, zdpmp, zcosp ) + zsopm = grt_cir_dis_saa( zdlpm, zdppm, zcosp ) + zsopp = grt_cir_dis_saa( zdlpp, zdppp, zcosp ) + + zsopmpp = zsopm * zsopp + zsommmp = zsomm * zsomp + + DO jk = 1, kmax + p2dmm(jk) = zsomp * zsopmpp * pmask(1,1,jk) + p2dmp(jk) = zsomm * zsopmpp * pmask(1,2,jk) + p2dpm(jk) = zsopp * zsommmp * pmask(2,1,jk) + p2dpp(jk) = zsopm * zsommmp * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_ds2 + + SUBROUTINE obs_int_h2d_bil( kpk2, kmax, & + & pphi, plam, pmask, & + & plammp, pphipm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_bil *** + !! + !! ** Purpose : Bilinear interpolation on a geographical grid (k2dint = 2) + !! + !! ** Method : The interpolation is split into two 1D interpolations in + !! the longitude and latitude directions, respectively. + !! + !! An iterative scheme that involves first mapping a quadrilateral + !! cell into a cell with coordinates (0,0), (1,0), (0,1) and (1,1). + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphipm, & ! Geographical location of surrounding + & pphipp, & ! model grid points + & plammp, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zdlmp, & + & zdppm, & + & zdlpp, & + & zdppp + + !---------------------------------------------------------------------- + ! Bilinear interpolation for geographical grid + !---------------------------------------------------------------------- + zdlmp = ABS(plam - plammp) + zdppm = ABS(pphi - pphipm) + zdlpp = ABS(plampp - plam) + zdppp = ABS(pphipp - pphi) + + DO jk = 1, kmax + p2dmm(jk) = zdlpp * zdppp * pmask(1,1,jk) + p2dmp(jk) = zdlpp * zdppm * pmask(1,2,jk) + p2dpm(jk) = zdlmp * zdppp * pmask(2,1,jk) + p2dpp(jk) = zdlmp * zdppm * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_bil + + SUBROUTINE obs_int_h2d_bir( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp, ldfail ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_bir *** + !! + !! ** Purpose : General bilinear remapping interpolation (k2dint = 3) + !! + !! ** Method : An iterative scheme that involves first mapping a + !! quadrilateral cell into a cell with coordinates + !! (0,0), (1,0), (0,1) and (1,1). + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + LOGICAL, INTENT(OUT) :: & + & ldfail + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zbiwmm, & + & zbiwmp, & + & zbiwpm, & + & zbiwpp + + !---------------------------------------------------------------------- + ! Bilinear remapping interpolation for general quadrilateral grid + !---------------------------------------------------------------------- + CALL bil_wgt( pphimm, pphimp, pphipm, pphipp, & + & plammm, plammp, plampm, plampp, & + & zbiwmm, zbiwmp, zbiwpm, zbiwpp, & + & pphi , plam, ldfail ) + + IF ( .NOT.ldfail ) THEN + DO jk = 1, kmax + p2dmm(jk) = zbiwmm * pmask(1,1,jk) + p2dmp(jk) = zbiwmp * pmask(1,2,jk) + p2dpm(jk) = zbiwpm * pmask(2,1,jk) + p2dpp(jk) = zbiwpp * pmask(2,2,jk) + END DO + ENDIF + + END SUBROUTINE obs_int_h2d_bir + + SUBROUTINE obs_int_h2d_pol( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_pol *** + !! + !! ** Purpose : Polynomial interpolation (k2dint = 4) + !! + !! ** Method : The interpolation weights are computed by fitting a + !! polynomial function of the form + !! + !! P(i) = a1(i) + a2(i) * phi + a3(i) * plam + a4(i) * phi * plam + !! + !! through the model values at four surrounding grid pts (i=1,4). + !! As k2dint = 0 but with distance (ds) computed using a small- + !! angle approximation to the great-circle distance formula: + !! + !! ds(AB) = sqrt( ( phiB - phiA )^{2} + !! + ( ( lamB - lamA ) * cos( phiB ) )^{2} ) + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zplp + REAL(KIND=wp), DIMENSION(4,4) :: & + & zmat, & + & zmati + + !------------------------------------------------------------------------ + ! Polynomial interpolation + !------------------------------------------------------------------------ + zmat(1,1) = 1.0_wp + zmat(1,2) = 1.0_wp + zmat(1,3) = 1.0_wp + zmat(1,4) = 1.0_wp + zmat(2,1) = plammm + zmat(2,2) = plammp + zmat(2,3) = plampm + zmat(2,4) = plampp + zmat(3,1) = pphimm + zmat(3,2) = pphimp + zmat(3,3) = pphipm + zmat(3,4) = pphipp + zmat(4,1) = plammm * pphimm + zmat(4,2) = plammp * pphimp + zmat(4,3) = plampm * pphipm + zmat(4,4) = plampp * pphipp + + CALL lu_invmat( zmat, 4, zmati ) + + zplp = plam * pphi + DO jk = 1, kmax + p2dmm(jk) = ABS( zmati(1,1) + zmati(1,2) * plam & + & + zmati(1,3) * pphi + zmati(1,4) * zplp ) & + & * pmask(1,1,jk) + p2dmp(jk) = ABS( zmati(2,1) + zmati(2,2) * plam & + & + zmati(2,3) * pphi + zmati(2,4) * zplp ) & + & * pmask(1,2,jk) + p2dpm(jk) = ABS( zmati(3,1) + zmati(3,2) * plam & + & + zmati(3,3) * pphi + zmati(3,4) * zplp ) & + & * pmask(2,1,jk) + p2dpp(jk) = ABS( zmati(4,1) + zmati(4,2) * plam & + & + zmati(4,3) * pphi + zmati(4,4) * zplp ) & + & * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_pol + + SUBROUTINE bil_wgt( pphimm, pphimp, pphipm, pphipp, & + & plammm, plammp, plampm, plampp, & + & pbiwmm, pbiwmp, pbiwpm, pbiwpp, & + & pphi , plam, ldfail ) + !!------------------------------------------------------------------- + !! + !! *** ROUTINE bil_wgt *** + !! + !! ** Purpose : Compute the weights for a bilinear remapping + !! interpolation scheme. + !! + !! ** Method : This scheme is appropriate for bilinear interpolation + !! on a general quadrilateral grid. + !! This scheme is also used in OASIS. + !! + !! This routine is a derivative of the SCRIP software. + !! Copyright 1997, 1998 the Regents of the University + !! of California. See SCRIP_Copyright.txt. + !! + !! ** Action : + !! + !! References : Jones, P.: A user's guide for SCRIP: A Spherical + !! Coordinate Remapping and Interpolation Package. + !! Version 1.4. Los Alamos. + !! + !! http://www.acl.lanl.gov/climate/software/SCRIP/SCRIPmain.html + !! + !! History + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), INTENT(OUT) :: & + & pbiwmm, & ! Interpolation weights + & pbiwmp, & + & pbiwpm, & + & pbiwpp + LOGICAL, INTENT(out) :: & + & ldfail + + !! * Local declarations + INTEGER :: & + & jiter + INTEGER :: & + & itermax + REAL(KIND=wp) :: & + & zphi, & ! Geographical location of observation + & zlam, & + & zphimm, & ! Geographical location of surrounding + & zphimp, & ! model grid points + & zphipm, & + & zphipp, & + & zlammm, & + & zlammp, & + & zlampm, & + & zlampp, & + & zdth1, & + & zdth2, & + & zdth3, & + & zdthp, & + & zdph1, & + & zdph2, & + & zdph3, & + & zdphp, & + & zmat1, & + & zmat2, & + & zmat3, & + & zmat4, & + & zdeli, & + & zdelj, & + & ziguess, & + & zjguess, & + & zeps, & + & zdeterm, & + & z2pi, & + & zhpi + + ! Initialization + + ! Conversion to radians + + zphi = pphi * rad + zlam = plam * rad + zphimm = pphimm * rad + zphimp = pphimp * rad + zphipm = pphipm * rad + zphipp = pphipp * rad + zlammm = plammm * rad + zlammp = plammp * rad + zlampm = plampm * rad + zlampp = plampp * rad + + ldfail = .FALSE. + + zdth1 = zphipm - zphimm + zdth2 = zphimp - zphimm + zdth3 = zphipp - zphipm - zdth2 + + zdph1 = zlampm - zlammm + zdph2 = zlammp - zlammm + zdph3 = zlampp - zlampm + + z2pi = 2.0_wp * rpi + + IF ( zdph1 > 3.0_wp * rpi ) zdph1 = zdph1 - z2pi + IF ( zdph2 > 3.0_wp * rpi ) zdph2 = zdph2 - z2pi + IF ( zdph3 > 3.0_wp * rpi ) zdph3 = zdph3 - z2pi + IF ( zdph1 < -3.0_wp * rpi ) zdph1 = zdph1 + z2pi + IF ( zdph2 < -3.0_wp * rpi ) zdph2 = zdph2 + z2pi + IF ( zdph3 < -3.0_wp * rpi ) zdph3 = zdph3 + z2pi + + zdph3 = zdph3 - zdph2 + + ziguess = 0.5_wp + zjguess = 0.5_wp + + itermax = 100 + + IF ( wp == sp ) THEN + zeps = 1.0e-6_wp ! Single precision + ELSE + zeps = 1.0e-10_wp ! Double precision + ENDIF + + !------------------------------------------------------------------------ + ! Iterate to determine (i,j) in new coordinate system + !------------------------------------------------------------------------ + jiter_loop: DO jiter = 1, itermax + + zdthp = zphi - zphimm - zdth1 * ziguess - zdth2 * zjguess & + & - zdth3 * ziguess * zjguess + zdphp = zlam - zlammm + + zhpi = 0.5_wp * rpi + IF ( zdphp > 3.0_wp * zhpi ) zdphp = zdphp - z2pi + IF ( zdphp < -3.0_wp * zhpi ) zdphp = zdphp + z2pi + + zdphp = zdphp - zdph1 * ziguess - zdph2 * zjguess & + & - zdph3 * ziguess * zjguess + + zmat1 = zdth1 + zdth3 * zjguess + zmat2 = zdth2 + zdth3 * ziguess + zmat3 = zdph1 + zdph3 * zjguess + zmat4 = zdph2 + zdph3 * ziguess + + ! Matrix determinant + zdeterm = zmat1 * zmat4 - zmat2 * zmat3 + + zdeli = ( zdthp * zmat4 - zmat2 * zdphp) / zdeterm + zdelj = ( zmat1 * zdphp - zdthp * zmat3) / zdeterm + + IF ( ABS( zdeli ) < zeps .AND. ABS( zdelj ) < zeps ) EXIT jiter_loop + + ziguess = ziguess + zdeli + zjguess = zjguess + zdelj + + ! DJL prevent ziguess and zjguess from going outside the range + ! 0 to 1 + ! prevents interpolated value going wrong + ! for example sea ice concentration gt 1 + + IF ( ziguess < 0 ) ziguess = 0.0_wp + IF ( zjguess < 0 ) zjguess = 0.0_wp + IF ( ziguess > 1 ) ziguess = 1.0_wp + IF ( zjguess > 1 ) zjguess = 1.0_wp + + END DO jiter_loop + + IF ( jiter <= itermax ) THEN + + ! Successfully found i,j, now compute the weights + + pbiwmm = ( 1.0_wp - ziguess ) * ( 1.0_wp - zjguess ) + pbiwmp = ( 1.0_wp - ziguess ) * zjguess + pbiwpm = ziguess * ( 1.0_wp - zjguess ) + pbiwpp = ziguess * zjguess + + ELSEIF ( jiter > itermax ) THEN + + IF(lwp) THEN + + WRITE(numout,*)'Obs lat/lon : ',pphi, plam + WRITE(numout,*)'Grid lats : ',pphimm, pphimp, pphipm, pphipp + WRITE(numout,*)'Grid lons : ',plammm, plammp, plampm, plampp + WRITE(numout,*)'Current i,j : ',ziguess, zjguess + WRITE(numout,*)'jiter = ',jiter + WRITE(numout,*)'zeps = ',zeps + WRITE(numout,*)'zdeli, zdelj = ',zdeli, zdelj + WRITE(numout,*)' Iterations for i,j exceed max iteration count!' + WRITE(numout,*) + + ldfail = .TRUE. + + ENDIF + + ENDIF + + END SUBROUTINE bil_wgt + + SUBROUTINE lu_invmat( pmatin, kdim, pmatou ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_invmat *** + !! + !! ** Purpose : Invert a matrix using LU decomposition. + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !! ! 06-11 (NEMOVAR task force) Fix declaration of zd. + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim ! Array dimension + REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(IN) :: & + & pmatin + REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(OUT) :: & + & pmatou + + !! * Local declarations + INTEGER :: & + & ji, & + & jj + INTEGER, DIMENSION(kdim) :: & + & indx + REAL(KIND=wp), DIMENSION(kdim,kdim) :: & + & zmat + REAL(KIND=wp) :: & + & zd + + ! Invert the matrix + DO jj = 1, kdim + DO ji = 1, kdim + pmatou(ji,jj) = 0.0_wp + zmat(ji,jj) = pmatin(ji,jj) + END DO + pmatou(jj,jj) = 1.0_wp + END DO + CALL lu_decomp( zmat, kdim, kdim, indx, zd ) + DO jj = 1, kdim + CALL lu_backsb( zmat, kdim, kdim, indx, pmatou(1,jj) ) + END DO + + END SUBROUTINE lu_invmat + + SUBROUTINE lu_decomp( pmatin, kdim1, kdim2, kindex, pflt ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_decomp *** + !! + !! ** Purpose : Compute the LU decomposition of a matrix + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim1, & ! Array dimensions + & kdim2 + INTEGER, DIMENSION(kdim1), INTENT(OUT) :: & + & kindex + REAL(KIND=wp), INTENT(OUT) :: & + & pflt + REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(INOUT) :: & + & pmatin + + !! * Local declarations + INTEGER, PARAMETER :: & + & jpmax = 100 + REAL(KIND=wp), PARAMETER :: & + & pptiny = 1.0e-20_wp + REAL(KIND=wp), DIMENSION(jpmax) :: & + & zvv + INTEGER :: & + & ji, & + & jj, & + & jk + INTEGER :: & + & imax + REAL(KIND=wp) :: & + & zsum, & + & zdum, & + & zaamax + + imax = -1 + ! Main computation + pflt = 1.0_wp + DO ji = 1, kdim1 + zaamax = 0.0_wp + DO jj = 1, kdim1 + IF ( ABS( pmatin(ji,jj) ) > zaamax ) zaamax = ABS( pmatin(ji,jj) ) + END DO + IF ( zaamax == 0.0_wp ) THEN + CALL ctl_stop( 'singular matrix' ) + ENDIF + zvv(ji) = 1.0_wp / zaamax + END DO + DO jj = 1, kdim1 + DO ji = 1, jj-1 + zsum = pmatin(ji,jj) + DO jk = 1, ji-1 + zsum = zsum - pmatin(ji,jk) * pmatin(jk,jj) + END DO + pmatin(ji,jj) = zsum + END DO + zaamax = 0.0_wp + DO ji = jj, kdim1 + zsum = pmatin(ji,jj) + DO jk = 1, jj-1 + zsum = zsum - pmatin(ji,jk) * pmatin(jk,jj) + END DO + pmatin(ji,jj) = zsum + zdum = zvv(ji) * ABS( zsum ) + IF ( zdum >= zaamax ) THEN + imax = ji + zaamax = zdum + ENDIF + END DO + IF ( jj /= imax ) THEN + DO jk = 1, kdim1 + zdum = pmatin(imax,jk) + pmatin(imax,jk) = pmatin(jj,jk) + pmatin(jj,jk) = zdum + END DO + pflt = -pflt + zvv(imax) = zvv(jj) + ENDIF + kindex(jj) = imax + IF ( pmatin(jj,jj) == 0.0_wp ) pmatin(jj,jj) = pptiny + IF ( jj /= kdim1 ) THEN + zdum = 1.0_wp / pmatin(jj,jj) + DO ji = jj+1, kdim1 + pmatin(ji,jj) = pmatin(ji,jj) * zdum + END DO + ENDIF + END DO + + END SUBROUTINE lu_decomp + + SUBROUTINE lu_backsb( pmat, kdim1, kdim2, kindex, pvect ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_backsb *** + !! + !! ** Purpose : Back substitution + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim1, & ! Array dimensions + & kdim2 + INTEGER, DIMENSION(kdim1), INTENT(IN) :: & + & kindex + REAL(KIND=wp), DIMENSION(kdim1), INTENT(INOUT) :: & + & pvect + REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(IN) :: & + & pmat + + !! * Local declarations + INTEGER :: & + & ji, & + & jii, & + & jj, & + & jll + REAL(KIND=wp) :: & + & zsum + + ! Main computation + jii = 0 + DO ji = 1, kdim1 + jll = kindex(ji) + zsum = pvect(jll) + pvect(jll) = pvect(ji) + IF ( jii /= 0 ) THEN + DO jj = jii, ji-1 + zsum = zsum - pmat(ji,jj) * pvect(jj) + END DO + ELSEIF ( zsum /= 0.0_wp ) THEN + jii = ji + ENDIF + pvect(ji) = zsum + END DO + DO ji = kdim1, 1, -1 + zsum = pvect(ji) + DO jj = ji+1, kdim1 + zsum = zsum - pmat(ji,jj) * pvect(jj) + END DO + pvect(ji) = zsum / pmat(ji,ji) + END DO + + END SUBROUTINE lu_backsb \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/obsinter_z1d.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obsinter_z1d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..74a9d4af49061dca53e8408f2608801d29120bf3 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/obsinter_z1d.h90 @@ -0,0 +1,193 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obsinter_z1d.h90 13226 2020-07-02 14:24:31Z orioltp $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE obs_int_z1d( kpk, kkco, k1dint, kdep, & + & pobsdep, pobsk, pobs2k, & + & pobs, pdep, pobsmask ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_z1d *** + !! + !! ** Purpose : Vertical interpolation to the observation point. + !! + !! ** Method : If k1dint = 0 then use linear interpolation. + !! If k1dint = 1 then use cubic spline interpolation. + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 97-11 (A. Weaver, S. Ricci, N. Daget) + !! ! 06-03 (G. Smith) Conversion to F90 for use with NEMOVAR + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-01 (K. Mogensen) Use profile rather than single level + !!--------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kpk ! Number of vertical levels + INTEGER, INTENT(IN) :: k1dint ! 0 = linear; 1 = cubic spline interpolation + INTEGER, INTENT(IN) :: kdep ! Number of levels in profile + INTEGER, INTENT(IN), DIMENSION(kdep) :: & + & kkco ! Array indicies for interpolation + REAL(KIND=wp), INTENT(IN), DIMENSION(kdep) :: & + & pobsdep ! Depth of the observation + REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & + & pobsk, & ! Model profile at a given (lon,lat) + & pobs2k, & ! 2nd derivative of the interpolating function + & pdep, & ! Model depth array + & pobsmask ! Vertical mask + REAL(KIND=wp), INTENT(OUT), DIMENSION(kdep) :: & + & pobs ! Model equivalent at observation point + + !! * Local declarations + REAL(KIND=wp) :: z1dm ! Distance above and below obs to model grid points + REAL(KIND=wp) :: z1dp + REAL(KIND=wp) :: zsum ! Dummy variables for computation + REAL(KIND=wp) :: zsum2 + INTEGER :: jdep ! Observation depths loop variable + + !------------------------------------------------------------------------ + ! Loop over all observation depths + !------------------------------------------------------------------------ + + DO jdep = 1, kdep + + !--------------------------------------------------------------------- + ! Initialization + !--------------------------------------------------------------------- + z1dm = ( pdep(kkco(jdep)) - pobsdep(jdep) ) + z1dp = ( pobsdep(jdep) - pdep(kkco(jdep)-1) ) + + ! If kkco(jdep) is masked then set pobs(jdep) to the lowest value located above bathymetry + IF ( pobsmask(kkco(jdep)) == 0.0_wp ) THEN + pobs(jdep) = pobsk(kkco(jdep)-1) + ELSE + zsum = z1dm + z1dp + + IF ( k1dint == 0 ) THEN + + !----------------------------------------------------------------- + ! Linear interpolation + !----------------------------------------------------------------- + pobs(jdep) = ( z1dm * pobsk(kkco(jdep)-1) & + & + z1dp * pobsk(kkco(jdep) ) ) / zsum + + ELSEIF ( k1dint == 1 ) THEN + + !----------------------------------------------------------------- + ! Cubic spline interpolation + !----------------------------------------------------------------- + zsum2 = zsum * zsum + pobs(jdep) = ( z1dm * pobsk (kkco(jdep)-1) & + & + z1dp * pobsk (kkco(jdep) ) & + & + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) & + & + z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep) ) & + & ) / 6.0_wp & + & ) / zsum + + ENDIF + ENDIF + END DO + + END SUBROUTINE obs_int_z1d + + SUBROUTINE obs_int_z1d_spl( kpk, pobsk, pobs2k, & + & pdep, pobsmask ) + !!-------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_z1d_spl *** + !! + !! ** Purpose : Compute the local vector of vertical second-derivatives + !! of the interpolating function used with a cubic spline. + !! + !! ** Method : + !! + !! Top and bottom boundary conditions on the 2nd derivative are + !! set to zero. + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 01-11 (A. Weaver, S. Ricci, N. Daget) + !! ! 06-03 (G. Smith) Conversion to F90 for use with NEMOVAR + !! ! 06-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kpk ! Number of vertical levels + REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & + & pobsk, & ! Model profile at a given (lon,lat) + & pdep, & ! Model depth array + & pobsmask ! Vertical mask + REAL(KIND=wp), INTENT(OUT), DIMENSION(kpk) :: & + & pobs2k ! 2nd derivative of the interpolating function + + !! * Local declarations + INTEGER :: jk + REAL(KIND=wp) :: za + REAL(KIND=wp) :: zb + REAL(KIND=wp) :: zc + REAL(KIND=wp) :: zpa + REAL(KIND=wp) :: zkm + REAL(KIND=wp) :: zkp + REAL(KIND=wp) :: zk + REAL(KIND=wp), DIMENSION(kpk-1) :: & + & zs, & + & zp, & + & zu, & + & zv + + !----------------------------------------------------------------------- + ! Matrix initialisation + !----------------------------------------------------------------------- + zs(1) = 0.0_wp + zp(1) = 0.0_wp + zv(1) = -0.5_wp + DO jk = 2, kpk-1 + zs(jk) = ( pdep(jk ) - pdep(jk-1) ) & + & / ( pdep(jk+1) - pdep(jk-1) ) + zp(jk) = zs(jk) * zv(jk-1) + 2.0_wp + zv(jk) = ( zs(jk) - 1.0_wp ) / zp(jk) + END DO + + !----------------------------------------------------------------------- + ! Solution of the tridiagonal system + !----------------------------------------------------------------------- + + ! Top boundary condition + zu(1) = 0.0_wp + + DO jk = 2, kpk-1 + za = pdep(jk+1) - pdep(jk-1) + zb = pdep(jk+1) - pdep(jk ) + zc = pdep(jk ) - pdep(jk-1) + + zpa = 6.0_wp / ( zp(jk) * za ) + zkm = zpa / zc + zkp = zpa / zb + zk = - ( zkm + zkp ) + + zu(jk) = pobsk(jk+1) * zkp & + & + pobsk(jk ) * zk & + & + pobsk(jk-1) * zkm & + & + zu(jk-1) * ( -zs(jk) / zp(jk) ) + END DO + + !----------------------------------------------------------------------- + ! Second derivative + !----------------------------------------------------------------------- + pobs2k(kpk) = 0.0_wp + + ! Bottom boundary condition + DO jk = kpk-1, 1, -1 + pobs2k(jk) = zv(jk) * pobs2k(jk+1) + zu(jk) + IF ( pobsmask(jk+1) == 0.0_wp ) pobs2k(jk) = 0.0_wp + END DO + + END SUBROUTINE obs_int_z1d_spl \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..6541dc168ddd17631d7f6d3da6820bd8e74833df Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/ocealb.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ocealb.mod new file mode 100644 index 0000000000000000000000000000000000000000..003f4ca55250f7117737a65852756d483ef72b02 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ocealb.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/oscl1d.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/oscl1d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..30f50982f55c0bb862f73334e0219a6102f4621a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/oscl1d.h90 @@ -0,0 +1,292 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! OSCL1D.h90: "oscillation-indicators" for WENO interp. + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine oscli (npos,nvar,ndof,delx,& + & fdat,oscl,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX (constant) grid-cell spacing. LENGTH(DELX)==+1 . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! OSCL grid-cell oscil. dof.'s. OSCL is an array with + ! SIZE = +2 -by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: oscl(:,:,:) + + !------------------------------------------- variables ! + integer :: ivar,ipos + + if (npos.lt.3) then + !------------------------------- at least 3 grid-cells ! + do ipos = +1, npos-1 + do ivar = +1, nvar-0 + oscl(1,ivar,ipos) = +0.e0 + oscl(2,ivar,ipos) = +0.e0 + end do + end do + end if + + if (npos.lt.3) return + if (nvar.lt.1) return + if (ndof.lt.1) return + + if (size(delx).gt.+1) then + + !------------------------------- variable grid-spacing ! + + call osclv(npos,nvar,ndof,delx, & + & fdat,oscl,dmin) + + else + + !------------------------------- constant grid-spacing ! + + call osclc(npos,nvar,ndof,delx, & + & fdat,oscl,dmin) + + end if + + return + + end subroutine + + pure subroutine osclv (npos,nvar,ndof,delx,& + & fdat,oscl,dmin) + + ! + ! *this is the variable grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX (variable) grid-cell spacing. LENGTH(DELX)!=+1 . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! OSCL grid-cell oscil. dof.'s. OSCL is an array with + ! SIZE = +2 -by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: oscl(:,:,:) + + !------------------------------------------- variables ! + integer :: head,tail + integer :: ipos,ivar + real*8 :: hhll,hhcc,hhrr + real*8 :: hhmm,hhrc,hhlc + real*8 :: cmat(2,3) + + head = +1 ; tail = npos-1 + + !--------------------------------------- centred point ! + + do ipos = head+1, tail-1 + + hhll = max(delx(ipos-1),dmin) + hhcc = max(delx(ipos+0),dmin) + hhrr = max(delx(ipos+1),dmin) + + hhrc = hhrr + hhcc + hhlc = hhll + hhcc + hhmm = hhll + hhcc + hhrr + + cmat(1,1) = -(hhcc+2.e0*hhrr)/(hhlc*hhmm) + cmat(1,2) = -(hhll-hhrr)* & + & (3.e0*hhcc+2.e0*(hhll+hhrr))/& + & (hhlc*hhrc*hhmm) + cmat(1,3) = +(hhcc+2.e0*hhll)/(hhrc*hhmm) + + cmat(2,1) = +3.e0/(hhlc*hhmm) + cmat(2,2) = -3.e0*(2.e0*hhcc+hhll+hhrr)/& + & (hhlc*hhrc*hhmm) + cmat(2,3) = +3.e0/(hhrc*hhmm) + + do ivar = 1, nvar + + oscl(1,ivar,ipos) = +1.e0 * ( & + & + cmat(1,1)*fdat(1,ivar,ipos-1) & + & + cmat(1,2)*fdat(1,ivar,ipos+0) & + & + cmat(1,3)*fdat(1,ivar,ipos+1) ) + + oscl(2,ivar,ipos) = +2.e0 * ( & + & + cmat(2,1)*fdat(1,ivar,ipos-1) & + & + cmat(2,2)*fdat(1,ivar,ipos+0) & + & + cmat(2,3)*fdat(1,ivar,ipos+1) ) + + end do + + end do + + !-------------------------------------- lower endpoint ! + + hhll = max(delx(head+0),dmin) + hhcc = max(delx(head+1),dmin) + hhrr = max(delx(head+2),dmin) + + cmat(1,1) = -2.e0 / (hhll+hhcc) + cmat(1,2) = +2.e0 / (hhll+hhcc) + + do ivar = 1, nvar + + oscl(1,ivar,head) = & + & + cmat(1,1)*fdat(1,ivar,head+0) & + & + cmat(1,2)*fdat(1,ivar,head+1) + + oscl(2,ivar,head) = +0.e0 + + end do + + !-------------------------------------- upper endpoint ! + + hhll = max(delx(tail-2),dmin) + hhcc = max(delx(tail-1),dmin) + hhrr = max(delx(tail-0),dmin) + + cmat(1,2) = -2.e0 / (hhrr+hhcc) + cmat(1,3) = +2.e0 / (hhrr+hhcc) + + do ivar = 1, nvar + + oscl(1,ivar,tail) = & + & + cmat(1,2)*fdat(1,ivar,tail-1) & + & + cmat(1,3)*fdat(1,ivar,tail+0) + + oscl(2,ivar,tail) = +0.e0 + + end do + + return + + end subroutine + + pure subroutine osclc (npos,nvar,ndof,delx,& + & fdat,oscl,dmin) + + ! + ! *this is the constant grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX (constant) grid-cell spacing. LENGTH(DELX)==+1 . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! OSCL grid-cell oscil. dof.'s. OSCL is an array with + ! SIZE = +2 -by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(1) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: oscl(:,:,:) + + !------------------------------------------- variables ! + integer :: head,tail,ipos,ivar + + head = +1; tail = npos - 1 + + !-------------------------------------- centred points ! + + do ipos = 2, npos-2 + do ivar = 1, nvar-0 + + oscl(1,ivar,ipos) = & + & + .25d+0 * fdat(1,ivar,ipos+1) & + & - .25d+0 * fdat(1,ivar,ipos-1) + + oscl(2,ivar,ipos) = & + & + .25d+0 * fdat(1,ivar,ipos+1) & + & - .50d+0 * fdat(1,ivar,ipos+0) & + & + .25d+0 * fdat(1,ivar,ipos-1) + + end do + end do + + !-------------------------------------- lower endpoint ! + + do ivar = 1, nvar + + oscl(1,ivar,head) = & + & + .50d+0 * fdat(1,ivar,head+1) & + & - .50d+0 * fdat(1,ivar,head+0) + + oscl(2,ivar,head) = +0.e0 + + end do + + !-------------------------------------- upper endpoint ! + + do ivar = 1, nvar + + oscl(1,ivar,tail) = & + & + .50d+0 * fdat(1,ivar,tail+0) & + & - .50d+0 * fdat(1,ivar,tail-1) + + oscl(2,ivar,tail) = +0.e0 + + end do + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/p1e.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/p1e.h90 new file mode 100644 index 0000000000000000000000000000000000000000..39b639357f49aceba928005a09220803a9a00830 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/p1e.h90 @@ -0,0 +1,188 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! P1E.h90: set edge estimates via degree-1 polynomials. + ! + ! Darren Engwirda + ! 09-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine p1e(npos,nvar,ndof,delx, & + & fdat,bclo,bchi,edge, & + & dfdx,opts,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCLO boundary condition at lower endpoint. + ! BCHI boundary condition at upper endpoint. + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! OPTS method parameters. See RCON-OPTS for details . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + type (rcon_ends), intent(in) :: bclo(:) + type (rcon_ends), intent(in) :: bchi(:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + real*8 , intent( in) :: dmin + class(rcon_opts), intent(in) :: opts + + !------------------------------------------- variables ! + integer :: ipos,ivar,head,tail + real*8 :: dd10 + real*8 :: delh(-1:+0) + + head = +2; tail = npos-1 + + if (npos.lt.2) return + if (npos.eq.2) then + !----- default to reduced order if insufficient points ! + do ivar = 1,nvar + + edge(ivar,1) = fdat(1,ivar,1) + dfdx(ivar,1) = 0.e0 + + edge(ivar,2) = fdat(1,ivar,1) + dfdx(ivar,2) = 0.e0 + + end do + end if + + if (npos.le.2) return + + ! Reconstruct edge-centred 2nd-order polynomials. Com- ! + ! pute values/slopes at edges directly. Full-order ex- ! + ! trapolation at endpoints. + + if (size(delx).eq.+1) then + + do ipos = head , tail + + !--------------- reconstruction: constant grid-spacing ! + + dd10 = delx(+1) * 2.e0 + + do ivar = +1, nvar + + edge(ivar,ipos) = & + & + delx(+1) * & + & fdat(1,ivar,ipos-1) & + & + delx(+1) * & + & fdat(1,ivar,ipos+0) + + dfdx(ivar,ipos) = & + & - 2.0d+0 * & + & fdat(1,ivar,ipos-1) & + & + 2.0d+0 * & + & fdat(1,ivar,ipos+0) + + edge(ivar,ipos) = & + & edge(ivar,ipos) / dd10 + dfdx(ivar,ipos) = & + & dfdx(ivar,ipos) / dd10 + + end do + + end do + + else + + do ipos = head , tail + + !--------------- reconstruction: variable grid-spacing ! + + delh(-1) = & + & max(delx(ipos-1),dmin) + delh(+0) = & + & max(delx(ipos+0),dmin) + + dd10 = delh(-1)+delh(+0) + + do ivar = +1, nvar + + edge(ivar,ipos) = & + & + delh(+0) * & + & fdat(1,ivar,ipos-1) & + & + delh(-1) * & + & fdat(1,ivar,ipos+0) + + dfdx(ivar,ipos) = & + & - 2.0d+0 * & + & fdat(1,ivar,ipos-1) & + & + 2.0d+0 * & + & fdat(1,ivar,ipos+0) + + edge(ivar,ipos) = & + & edge(ivar,ipos) / dd10 + dfdx(ivar,ipos) = & + & dfdx(ivar,ipos) / dd10 + + end do + + end do + + end if + + !------------- 1st-order value/slope BC's at endpoints ! + + do ivar = +1, nvar + + edge(ivar,head-1) = & + & fdat(+1,ivar,head-1) + edge(ivar,tail+1) = & + & fdat(+1,ivar,tail+0) + + dfdx(ivar,head-1) = 0.e0 + dfdx(ivar,tail+1) = 0.e0 + + end do + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/p3e.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/p3e.h90 new file mode 100644 index 0000000000000000000000000000000000000000..6becd63358c1a4c9d1538386b65f59e91d164aea --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/p3e.h90 @@ -0,0 +1,276 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! P3E.h90: set edge estimates via degree-3 polynomials. + ! + ! Darren Engwirda + ! 09-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine p3e(npos,nvar,ndof,delx, & + & fdat,bclo,bchi,edge, & + & dfdx,opts,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCLO boundary condition at lower endpoint. + ! BCHI boundary condition at upper endpoint. + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! OPTS method parameters. See RCON-OPTS for details . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + type (rcon_ends), intent(in) :: bclo(:) + type (rcon_ends), intent(in) :: bchi(:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + real*8 , intent( in) :: dmin + class(rcon_opts), intent(in) :: opts + + !------------------------------------------- variables ! + integer :: ipos,ivar,idof,head,tail + logical :: okay + real*8 :: xhat,fEPS + real*8 :: delh(-2:+1) + real*8 :: xmap(-2:+2) + real*8 :: fhat(+4, nvar) + real*8 :: ivec(+4,-2:+2) + real*8 :: cmat(+4,+4) + + integer, parameter :: NSIZ = +4 + real*8 , parameter :: ZERO = 1.e-14 + + head = +3 ; tail = npos - 2 + + if (npos.le.4) then + !----- default to reduced order if insufficient points ! + call p1e (npos,nvar,ndof, & + & delx,fdat,bclo, & + & bchi,edge,dfdx, & + & opts,dmin) + end if + + if (npos.le.4) return + + !------ impose value/slope B.C.'s about lower endpoint ! + + call pbc(npos,nvar,ndof,delx, & + & fdat,bclo,edge,dfdx, & + & -1 ,dmin) + + !------ impose value/slope B.C.'s about upper endpoint ! + + call pbc(npos,nvar,ndof,delx, & + & fdat,bchi,edge,dfdx, & + & +1 ,dmin) + + ! Reconstruct edge-centred 4th-order polynomials. Com- ! + ! pute values/slopes at edges directly. Mid.-order ex- ! + ! trapolation at endpoints. ! + + if (size(delx).eq.+1) then + + do ipos = head , tail + + !--------------- reconstruction: constant grid-spacing ! + + do ivar = 1, nvar + + edge(ivar,ipos) = ( & + & - 1.e0 * & + & fdat(1,ivar,ipos-2) & + & + 7.e0 * & + & fdat(1,ivar,ipos-1) & + & + 7.e0 * & + & fdat(1,ivar,ipos+0) & + & - 1.e0 * & + & fdat(1,ivar,ipos+1) ) / 12.e0 + + dfdx(ivar,ipos) = ( & + & + 1.e0 * & + & fdat(1,ivar,ipos-2) & + & - 15.e0 * & + & fdat(1,ivar,ipos-1) & + & + 15.e0 * & + & fdat(1,ivar,ipos+0) & + & - 1.e0 * & + & fdat(1,ivar,ipos+1) ) / 12.e0 + + dfdx(ivar,ipos) = & + & dfdx(ivar,ipos) / delx(+1) + + end do + + end do + + else + + fEPS = ZERO * dmin + + do ipos = head , tail + + !--------------- reconstruction: variable grid-spacing ! + + delh(-2) = delx(ipos-2) + delh(-1) = delx(ipos-1) + delh(+0) = delx(ipos+0) + delh(+1) = delx(ipos+1) + + xhat = .5d0 * max(delh(-1),dmin) + & + & .5d0 * max(delh(+0),dmin) + + xmap(-2) = -( delh(-2) & + & + delh(-1) ) / xhat + xmap(-1) = - delh(-1) / xhat + xmap(+0) = + 0.e0 + xmap(+1) = + delh(+0) / xhat + xmap(+2) = +( delh(+0) & + & + delh(+1) ) / xhat + + !--------------------------- calc. integral basis vec. ! + + do idof = -2, +2 + + ivec(1,idof) = & + & xmap(idof) ** 1 / 1.0d+0 + ivec(2,idof) = & + & xmap(idof) ** 2 / 2.0d+0 + ivec(3,idof) = & + & xmap(idof) ** 3 / 3.0d+0 + ivec(4,idof) = & + & xmap(idof) ** 4 / 4.0d+0 + + end do + + !--------------------------- linear system: lhs matrix ! + + do idof = +1, +4 + + cmat(1,idof) = ivec(idof,-1) & + & - ivec(idof,-2) + cmat(2,idof) = ivec(idof,+0) & + & - ivec(idof,-1) + cmat(3,idof) = ivec(idof,+1) & + & - ivec(idof,+0) + cmat(4,idof) = ivec(idof,+2) & + & - ivec(idof,+1) + + end do + + !--------------------------- linear system: rhs vector ! + + do ivar = +1, nvar + + fhat(+1,ivar) = & + & delx(ipos-2) * & + & fdat(+1,ivar,ipos-2) / xhat + fhat(+2,ivar) = & + & delx(ipos-1) * & + & fdat(+1,ivar,ipos-1) / xhat + fhat(+3,ivar) = & + & delx(ipos+0) * & + & fdat(+1,ivar,ipos+0) / xhat + fhat(+4,ivar) = & + & delx(ipos+1) * & + & fdat(+1,ivar,ipos+1) / xhat + + end do + + !------------------------- factor/solve linear systems ! + + call slv_4x4(cmat,NSIZ,fhat, & + & NSIZ,nvar,fEPS, & + & okay) + + if (okay .eqv. .true.) then + + do ivar = +1, nvar + + edge(ivar,ipos) = fhat(1,ivar) + + dfdx(ivar,ipos) = fhat(2,ivar) & + & / xhat + + end do + + else + + !------------------------- fallback if system singular ! + +# ifdef __PPR_WARNMAT__ + + write(*,*) & + & "WARNING::P3E - matrix-is-singular!" + +# endif + + do ivar = +1, nvar + + edge(ivar,ipos) = & + & fdat(1,ivar,ipos-1) * 0.5d+0 + & + & fdat(1,ivar,ipos-0) * 0.5d+0 + + dfdx(ivar,ipos) = & + & fdat(1,ivar,ipos-0) * 1.0d+0 - & + & fdat(1,ivar,ipos-1) * 1.0d+0 + + dfdx(ivar,ipos) = & + & dfdx(ivar,ipos) / xhat + + end do + + end if + + end do + + end if + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/p5e.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/p5e.h90 new file mode 100644 index 0000000000000000000000000000000000000000..fe4b446f7c1beec2e8a120c8902510a805d3c421 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/p5e.h90 @@ -0,0 +1,312 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! P5E.h90: set edge estimates via degree-5 polynomials. + ! + ! Darren Engwirda + ! 25-Mar-2019 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine p5e(npos,nvar,ndof,delx, & + & fdat,bclo,bchi,edge, & + & dfdx,opts,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCLO boundary condition at lower endpoint. + ! BCHI boundary condition at upper endpoint. + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! OPTS method parameters. See RCON-OPTS for details . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + type (rcon_ends), intent(in) :: bclo(:) + type (rcon_ends), intent(in) :: bchi(:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + real*8 , intent( in) :: dmin + class(rcon_opts), intent(in) :: opts + + !------------------------------------------- variables ! + integer :: ipos,ivar,idof,head,tail + logical :: okay + real*8 :: xhat,fEPS + real*8 :: delh(-3:+2) + real*8 :: xmap(-3:+3) + real*8 :: fhat(+6, nvar) + real*8 :: ivec(+6,-3:+3) + real*8 :: cmat(+6,+6) + + integer, parameter :: NSIZ = +6 + real*8 , parameter :: ZERO = 1.e-14 + + head = +4 ; tail = npos - 3 + + if (npos.le.6) then + !----- default to reduced order if insufficient points ! + call p3e (npos,nvar,ndof, & + & delx,fdat,bclo, & + & bchi,edge,dfdx, & + & opts,dmin) + end if + + if (npos.le.6) return + + !------ impose value/slope B.C.'s about lower endpoint ! + + call pbc(npos,nvar,ndof,delx, & + & fdat,bclo,edge,dfdx, & + & -1 ,dmin) + + !------ impose value/slope B.C.'s about upper endpoint ! + + call pbc(npos,nvar,ndof,delx, & + & fdat,bchi,edge,dfdx, & + & +1 ,dmin) + + ! Reconstruct edge-centred 6th-order polynomials. Com- ! + ! pute values/slopes at edges directly. Mid.-order ex- ! + ! trapolation at endpoints. ! + + if (size(delx).eq.+1) then + + do ipos = head , tail + + !--------------- reconstruction: constant grid-spacing ! + + do ivar = 1, nvar + + edge(ivar,ipos) = & + & + ( 1.e0 / 60.e0) * & + & fdat(1,ivar,ipos-3) & + & - ( 8.e0 / 60.e0) * & + & fdat(1,ivar,ipos-2) & + & + (37.e0 / 60.e0) * & + & fdat(1,ivar,ipos-1) & + & + (37.e0 / 60.e0) * & + & fdat(1,ivar,ipos+0) & + & - ( 8.e0 / 60.e0) * & + & fdat(1,ivar,ipos+1) & + & + ( 1.e0 / 60.e0) * & + & fdat(1,ivar,ipos+2) + + dfdx(ivar,ipos) = & + & - ( 1.e0 / 90.e0) * & + & fdat(1,ivar,ipos-3) & + & + ( 5.e0 / 36.e0) * & + & fdat(1,ivar,ipos-2) & + & - (49.e0 / 36.e0) * & + & fdat(1,ivar,ipos-1) & + & + (49.e0 / 36.e0) * & + & fdat(1,ivar,ipos+0) & + & - ( 5.e0 / 36.e0) * & + & fdat(1,ivar,ipos+1) & + & + ( 1.e0 / 90.e0) * & + & fdat(1,ivar,ipos+2) + + dfdx(ivar,ipos) = & + dfdx(ivar,ipos) / delx(+1) + + end do + + end do + + else + + fEPS = ZERO * dmin + + do ipos = head , tail + + !--------------- reconstruction: variable grid-spacing ! + + delh(-3) = & + & max(delx(ipos-3),dmin) + delh(-2) = & + & max(delx(ipos-2),dmin) + delh(-1) = & + & max(delx(ipos-1),dmin) + delh(+0) = & + & max(delx(ipos+0),dmin) + delh(+1) = & + & max(delx(ipos+1),dmin) + delh(+2) = & + & max(delx(ipos+2),dmin) + + xhat = .5d0 * delh(-1) + & + & .5d0 * delh(+0) + + xmap(-3) = -( delh(-3) & + & + delh(-2) & + & + delh(-1) ) / xhat + xmap(-2) = -( delh(-2) & + & + delh(-1) ) / xhat + xmap(-1) = - delh(-1) / xhat + xmap(+0) = + 0.e0 + xmap(+1) = + delh(+0) / xhat + xmap(+2) = +( delh(+0) & + & + delh(+1) ) / xhat + xmap(+3) = +( delh(+0) & + & + delh(+1) & + & + delh(+2) ) / xhat + + !--------------------------- calc. integral basis vec. ! + + do idof = -3, +3 + + ivec(1,idof) = & + & xmap(idof) ** 1 / 1.0d+0 + ivec(2,idof) = & + & xmap(idof) ** 2 / 2.0d+0 + ivec(3,idof) = & + & xmap(idof) ** 3 / 3.0d+0 + ivec(4,idof) = & + & xmap(idof) ** 4 / 4.0d+0 + ivec(5,idof) = & + & xmap(idof) ** 5 / 5.0d+0 + ivec(6,idof) = & + & xmap(idof) ** 6 / 6.0d+0 + + end do + + !--------------------------- linear system: lhs matrix ! + + do idof = +1, +6 + + cmat(1,idof) = ivec(idof,-2) & + & - ivec(idof,-3) + cmat(2,idof) = ivec(idof,-1) & + & - ivec(idof,-2) + cmat(3,idof) = ivec(idof,+0) & + & - ivec(idof,-1) + cmat(4,idof) = ivec(idof,+1) & + & - ivec(idof,+0) + cmat(5,idof) = ivec(idof,+2) & + & - ivec(idof,+1) + cmat(6,idof) = ivec(idof,+3) & + & - ivec(idof,+2) + + end do + + !--------------------------- linear system: rhs vector ! + + do ivar = +1, nvar + + fhat(+1,ivar) = & + & delx(ipos-3) * & + & fdat(+1,ivar,ipos-3) / xhat + fhat(+2,ivar) = & + & delx(ipos-2) * & + & fdat(+1,ivar,ipos-2) / xhat + fhat(+3,ivar) = & + & delx(ipos-1) * & + & fdat(+1,ivar,ipos-1) / xhat + fhat(+4,ivar) = & + & delx(ipos+0) * & + & fdat(+1,ivar,ipos+0) / xhat + fhat(+5,ivar) = & + & delx(ipos+1) * & + & fdat(+1,ivar,ipos+1) / xhat + fhat(+6,ivar) = & + & delx(ipos+2) * & + & fdat(+1,ivar,ipos+2) / xhat + + end do + + !------------------------- factor/solve linear systems ! + + call slv_6x6(cmat,NSIZ,fhat, & + & NSIZ,nvar,fEPS, & + & okay) + + if (okay .eqv. .true.) then + + do ivar = +1, nvar + + edge(ivar,ipos) = fhat(1,ivar) + + dfdx(ivar,ipos) = fhat(2,ivar) & + & / xhat + + end do + + else + + !------------------------- fallback if system singular ! + +# ifdef __PPR_WARNMAT__ + + write(*,*) & + & "WARNING::P5E - matrix-is-singular!" + +# endif + + do ivar = +1, nvar + + edge(ivar,ipos) = & + & fdat(1,ivar,ipos-1) * 0.5d+0 + & + & fdat(1,ivar,ipos-0) * 0.5d+0 + + dfdx(ivar,ipos) = & + & fdat(1,ivar,ipos-0) * 0.5d+0 - & + & fdat(1,ivar,ipos-1) * 0.5d+0 + + dfdx(ivar,ipos) = & + & dfdx(ivar,ipos) / xhat + + end do + + end if + + end do + + end if + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/par_kind.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/par_kind.mod new file mode 100644 index 0000000000000000000000000000000000000000..9c2f7d7d3f892471d9dfdfd2520814139a1bae70 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/par_kind.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/par_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/par_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..db5760b957a543303e8bef72ebc40a01930db773 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/par_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/pbc.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/pbc.h90 new file mode 100644 index 0000000000000000000000000000000000000000..1d09e3a9bc810bec8824ca176c579f7117e94339 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/pbc.h90 @@ -0,0 +1,827 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! PBC.h90: setup polynomial B.C.'s at domain endpoints. + ! + ! Darren Engwirda + ! 09-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine pbc(npos,nvar,ndof,delx, & + & fdat,bcon,edge,dfdx, & + & iend,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCON boundary condition data for endpoint . + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! IEND domain endpoint, IEND < +0 for lower end-point + ! and IEND > +0 for upper endpoint . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + integer, intent( in) :: iend + real*8 , intent( in) :: dmin + type(rcon_ends), intent(in) :: bcon(:) + + !------------------------------------------- variables ! + integer :: ivar,nlse,nval,nslp + + nlse = 0 ; nval = 0 ; nslp = 0 + + do ivar = +1, nvar + + select case (bcon(ivar)%bcopt) + !------------------------------------------- find BC's ! + case(bcon_loose) + nlse = nlse + 1 + + case(bcon_value) + nval = nval + 1 + + case(bcon_slope) + nslp = nslp + 1 + + end select + + end do + + !---------------------------- setup "lower" conditions ! + + if (iend.lt.+0) then + + if (nlse.gt.+0) then + !---------------------------- setup "unset" conditions ! + call lbc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_loose , & + & edge,dfdx,dmin) + + end if + + if (nval.gt.+0) then + !---------------------------- setup "value" conditions ! + call lbc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_value , & + & edge,dfdx,dmin) + + end if + + if (nslp.gt.+0) then + !---------------------------- setup "slope" conditions ! + call lbc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_slope , & + & edge,dfdx,dmin) + + end if + + end if + + !---------------------------- setup "upper" conditions ! + + if (iend.gt.+0) then + + if (nlse.gt.+0) then + !---------------------------- setup "unset" conditions ! + call ubc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_loose , & + & edge,dfdx,dmin) + + end if + + if (nval.gt.+0) then + !---------------------------- setup "value" conditions ! + call ubc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_value , & + & edge,dfdx,dmin) + + end if + + if (nslp.gt.+0) then + !---------------------------- setup "slope" conditions ! + call ubc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_slope , & + & edge,dfdx,dmin) + + end if + + end if + + return + + end subroutine + + ! LBC: impose a single B.C.-type at the lower endpoint ! + + subroutine lbc(npos,nvar,ndof,delx, & + & fdat,bcon,bopt,edge, & + & dfdx,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCON boundary condition data for endpoint . + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + integer, intent( in) :: bopt + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + real*8 , intent( in) :: dmin + type(rcon_ends), intent(in) :: bcon(:) + + !------------------------------------------- variables ! + integer :: ivar,idof,isel, & + & head,tail,nsel + logical :: okay + real*8 :: xhat + real*8 :: delh(-1:+1) + real*8 :: xmap(-1:+2) + real*8 :: bvec(+3,-1:+2) + real*8 :: gvec(+3,-1:+2) + real*8 :: cmat(+3,+3) + real*8 :: fhat(+3, nvar) + real*8 :: eval(-1:+2) + real*8 :: gval(-1:+2) + + integer, parameter :: NSIZ = +3 + real*8 , parameter :: ZERO = +1.e-14 + + head = +2; tail = npos - 2 + + if (size(delx).gt.+1) then + + !------------------ mean grid spacing about ii-th cell ! + + xhat = max(delx(head),dmin) * 0.5d+0 + + !------------------ grid spacing for all stencil cells ! + + delh(-1) = delx(head-1) + delh(+0) = delx(head+0) + delh(+1) = delx(head+1) + + else + + !------------------ mean grid spacing about ii-th cell ! + + xhat = max(delx( +1),dmin) * 0.5d+0 + + !------------------ grid spacing for all stencil cells ! + + delh(-1) = delx( +1) + delh(+0) = delx( +1) + delh(+1) = delx( +1) + + end if + + !---------- local coordinate mapping for stencil edges ! + + xmap(-1) =-(delh(-1) + & + & delh(+0)*0.5d0)/xhat + xmap(+0) = -1.e0 + xmap(+1) = +1.e0 + xmap(+2) = (delh(+1) + & + & delh(+0)*0.5d0)/xhat + + !------------ linear system: lhs reconstruction matrix ! + + select case(bopt ) + case( bcon_loose ) + + call bfun1d(-1,+3,xmap(-1),bvec(:,-1)) + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + call bfun1d(-1,+3,xmap(+2),bvec(:,+2)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+0) & + & - bvec(idof,-1) + cmat(2,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + cmat(3,idof) = bvec(idof,+2) & + & - bvec(idof,+1) + + end do + + case( bcon_value ) + + call bfun1d(+0,+3,xmap(-1),gvec(:,-1)) + + call bfun1d(-1,+3,xmap(-1),bvec(:,-1)) + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+0) & + & - bvec(idof,-1) + cmat(2,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + + cmat(3,idof) = gvec(idof,-1) + + end do + + case( bcon_slope ) + + call bfun1d(+1,+3,xmap(-1),gvec(:,-1)) + + call bfun1d(-1,+3,xmap(-1),bvec(:,-1)) + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+0) & + & - bvec(idof,-1) + cmat(2,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + + cmat(3,idof) = gvec(idof,-1) + + end do + + end select + + !------------ linear system: rhs reconstruction vector ! + + isel = 0 ; nsel = 0 + + select case( bopt ) + case ( bcon_loose ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_loose) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(-1) * & + & fdat(1,ivar,head-1) / xhat + fhat(2,isel) = delh(+0) * & + & fdat(1,ivar,head+0) / xhat + fhat(3,isel) = delh(+1) * & + & fdat(1,ivar,head+1) / xhat + + end if + + end do + + case ( bcon_value ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_value) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(-1) * & + & fdat(1,ivar,head-1) / xhat + fhat(2,isel) = delh(+0) * & + & fdat(1,ivar,head+0) / xhat + + fhat(3,isel) = bcon(ivar)%value + + end if + + end do + + case ( bcon_slope ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_slope) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(-1) * & + & fdat(1,ivar,head-1) / xhat + fhat(2,isel) = delh(+0) * & + & fdat(1,ivar,head+0) / xhat + + fhat(3,isel) = & + & bcon(ivar)%slope * xhat + + end if + + end do + + end select + + !------------------------- factor/solve linear systems ! + + call slv_3x3(cmat,NSIZ,fhat , & + & NSIZ,nvar, & + & ZERO*dmin,okay) + + if (okay .eqv..false.) then + +# ifdef __PPR_WARNMAT__ + + write(*,*) & + & "WARNING::LBC-matrix-is-singular!" + +# endif + + end if + + if (okay .eqv. .true.) then + + !------------- extrapolate values/slopes at lower edge ! + + isel = +0 + + call bfun1d(+0,+3,xmap(-1),bvec(:,-1)) + call bfun1d(+0,+3,xmap(+0),bvec(:,+0)) + call bfun1d(+0,+3,xmap(+1),bvec(:,+1)) + + call bfun1d(+1,+3,xmap(-1),gvec(:,-1)) + call bfun1d(+1,+3,xmap(+0),gvec(:,+0)) + call bfun1d(+1,+3,xmap(+1),gvec(:,+1)) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bopt) then + + isel = isel + 1 + + eval(-1) = dot_product( & + & bvec(:,-1),fhat(:,isel)) + eval(+0) = dot_product( & + & bvec(:,+0),fhat(:,isel)) + eval(+1) = dot_product( & + & bvec(:,+1),fhat(:,isel)) + + gval(-1) = dot_product( & + & gvec(:,-1),fhat(:,isel)) + gval(+0) = dot_product( & + & gvec(:,+0),fhat(:,isel)) + gval(+1) = dot_product( & + & gvec(:,+1),fhat(:,isel)) + + edge(ivar,head-1) = eval(-1) + edge(ivar,head+0) = eval(+0) + edge(ivar,head+1) = eval(+1) + + dfdx(ivar,head-1) = gval(-1) & + & / xhat + dfdx(ivar,head+0) = gval(+0) & + & / xhat + dfdx(ivar,head+1) = gval(+1) & + & / xhat + + end if + + end do + + else + + !------------- low-order if re-con. matrix is singular ! + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bopt) then + + eval(-1) = & + & fdat(1,ivar,head-1) * 1.e0 + eval(+0) = & + & fdat(1,ivar,head-1) * .5d0 + & + & fdat(1,ivar,head+0) * .5d0 + eval(+1) = & + & fdat(1,ivar,head+0) * .5d0 + & + & fdat(1,ivar,head+1) * .5d0 + + gval(-1) = & + & fdat(1,ivar,head+0) * .5d0 - & + & fdat(1,ivar,head-1) * .5d0 + gval(+0) = & + & fdat(1,ivar,head+0) * .5d0 - & + & fdat(1,ivar,head-1) * .5d0 + gval(+1) = & + & fdat(1,ivar,head+1) * .5d0 - & + & fdat(1,ivar,head+0) * .5d0 + + edge(ivar,head-1) = eval(-1) + edge(ivar,head+0) = eval(+0) + edge(ivar,head+1) = eval(+1) + + dfdx(ivar,head-1) = gval(-1) & + & / xhat + dfdx(ivar,head+0) = gval(+0) & + & / xhat + dfdx(ivar,head+1) = gval(+1) & + & / xhat + + end if + + end do + + end if + + return + + end subroutine + + ! UBC: impose a single B.C.-type at the upper endpoint ! + + subroutine ubc(npos,nvar,ndof,delx, & + & fdat,bcon,bopt,edge, & + & dfdx,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCON boundary condition data for endpoint . + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + integer, intent( in) :: bopt + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + real*8 , intent( in) :: dmin + type(rcon_ends), intent(in) :: bcon(:) + + !------------------------------------------- variables ! + integer :: ivar,idof,isel, & + & head,tail,nsel + logical :: okay + real*8 :: xhat + real*8 :: delh(-1:+1) + real*8 :: xmap(-1:+2) + real*8 :: bvec(+3,-1:+2) + real*8 :: gvec(+3,-1:+2) + real*8 :: cmat(+3,+3) + real*8 :: fhat(+3, nvar) + real*8 :: eval(-1:+2) + real*8 :: gval(-1:+2) + + integer, parameter :: NSIZ = +3 + real*8 , parameter :: ZERO = +1.e-14 + + head = +2; tail = npos - 2 + + if (size(delx).gt.+1) then + + !------------------ mean grid spacing about ii-th cell ! + + xhat = max(delx(tail),dmin) * 0.5d+0 + + !------------------ grid spacing for all stencil cells ! + + delh(-1) = delx(tail-1) + delh(+0) = delx(tail+0) + delh(+1) = delx(tail+1) + + else + + !------------------ mean grid spacing about ii-th cell ! + + xhat = max(delx( +1),dmin) * 0.5d+0 + + !------------------ grid spacing for all stencil cells ! + + delh(-1) = delx( +1) + delh(+0) = delx( +1) + delh(+1) = delx( +1) + + end if + + !---------- local coordinate mapping for stencil edges ! + + xmap(-1) =-(delh(-1) + & + & delh(+0)*0.5d0)/xhat + xmap(+0) = -1.e0 + xmap(+1) = +1.e0 + xmap(+2) = (delh(+1) + & + & delh(+0)*0.5d0)/xhat + + !------------ linear system: lhs reconstruction matrix ! + + select case(bopt ) + case( bcon_loose ) + + call bfun1d(-1,+3,xmap(-1),bvec(:,-1)) + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + call bfun1d(-1,+3,xmap(+2),bvec(:,+2)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+0) & + & - bvec(idof,-1) + cmat(2,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + cmat(3,idof) = bvec(idof,+2) & + & - bvec(idof,+1) + + end do + + case( bcon_value ) + + call bfun1d(+0,+3,xmap(+2),gvec(:,+2)) + + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + call bfun1d(-1,+3,xmap(+2),bvec(:,+2)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + cmat(2,idof) = bvec(idof,+2) & + & - bvec(idof,+1) + + cmat(3,idof) = gvec(idof,+2) + + end do + + case( bcon_slope ) + + call bfun1d(+1,+3,xmap(+2),gvec(:,+2)) + + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + call bfun1d(-1,+3,xmap(+2),bvec(:,+2)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + cmat(2,idof) = bvec(idof,+2) & + & - bvec(idof,+1) + + cmat(3,idof) = gvec(idof,+2) + + end do + + end select + + !------------ linear system: rhs reconstruction vector ! + + isel = 0 ; nsel = 0 + + select case( bopt ) + case ( bcon_loose ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_loose) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(-1) * & + & fdat(1,ivar,tail-1) / xhat + fhat(2,isel) = delh(+0) * & + & fdat(1,ivar,tail+0) / xhat + fhat(3,isel) = delh(+1) * & + & fdat(1,ivar,tail+1) / xhat + + end if + + end do + + case ( bcon_value ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_value) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(+0) * & + & fdat(1,ivar,tail+0) / xhat + fhat(2,isel) = delh(+1) * & + & fdat(1,ivar,tail+1) / xhat + + fhat(3,isel) = bcon(ivar)%value + + end if + + end do + + case ( bcon_slope ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_slope) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(+0) * & + & fdat(1,ivar,tail+0) / xhat + fhat(2,isel) = delh(+1) * & + & fdat(1,ivar,tail+1) / xhat + + fhat(3,isel) = & + & bcon(ivar)%slope * xhat + + end if + + end do + + end select + + !------------------------- factor/solve linear systems ! + + call slv_3x3(cmat,NSIZ,fhat , & + & NSIZ,nvar, & + & ZERO*dmin,okay) + + if (okay .eqv..false.) then + +# ifdef __PPR_WARNMAT__ + + write(*,*) & + & "WARNING::UBC-matrix-is-singular!" + +# endif + + end if + + if (okay .eqv. .true.) then + + !------------- extrapolate values/slopes at lower edge ! + + isel = +0 + + call bfun1d(+0,+3,xmap(+0),bvec(:,+0)) + call bfun1d(+0,+3,xmap(+1),bvec(:,+1)) + call bfun1d(+0,+3,xmap(+2),bvec(:,+2)) + + call bfun1d(+1,+3,xmap(+0),gvec(:,+0)) + call bfun1d(+1,+3,xmap(+1),gvec(:,+1)) + call bfun1d(+1,+3,xmap(+2),gvec(:,+2)) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bopt) then + + isel = isel + 1 + + eval(+0) = dot_product( & + & bvec(:,+0),fhat(:,isel)) + eval(+1) = dot_product( & + & bvec(:,+1),fhat(:,isel)) + eval(+2) = dot_product( & + & bvec(:,+2),fhat(:,isel)) + + gval(+0) = dot_product( & + & gvec(:,+0),fhat(:,isel)) + gval(+1) = dot_product( & + & gvec(:,+1),fhat(:,isel)) + gval(+2) = dot_product( & + & gvec(:,+2),fhat(:,isel)) + + edge(ivar,tail+0) = eval(+0) + edge(ivar,tail+1) = eval(+1) + edge(ivar,tail+2) = eval(+2) + + dfdx(ivar,tail+0) = gval(+0) & + & / xhat + dfdx(ivar,tail+1) = gval(+1) & + & / xhat + dfdx(ivar,tail+2) = gval(+2) & + & / xhat + + end if + + end do + + else + + !------------- low-order if re-con. matrix is singular ! + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bopt) then + + eval(+0) = & + & fdat(1,ivar,tail-1) * .5d0 + & + & fdat(1,ivar,tail+0) * .5d0 + eval(+1) = & + & fdat(1,ivar,tail+0) * .5d0 + & + & fdat(1,ivar,tail+1) * .5d0 + eval(+2) = & + & fdat(1,ivar,tail+1) * 1.e0 + + gval(+0) = & + & fdat(1,ivar,tail+0) * .5d0 - & + & fdat(1,ivar,tail-1) * .5d0 + gval(+1) = & + & fdat(1,ivar,tail+1) * .5d0 - & + & fdat(1,ivar,tail+0) * .5d0 + gval(+2) = & + & fdat(1,ivar,tail+1) * .5d0 - & + & fdat(1,ivar,tail+0) * .5d0 + + edge(ivar,tail+0) = eval(+0) + edge(ivar,tail+1) = eval(+1) + edge(ivar,tail+2) = eval(+2) + + dfdx(ivar,tail+0) = gval(+0) & + & / xhat + dfdx(ivar,tail+1) = gval(+1) & + & / xhat + dfdx(ivar,tail+2) = gval(+2) & + & / xhat + + end if + + end do + + end if + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/pcm.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/pcm.h90 new file mode 100644 index 0000000000000000000000000000000000000000..1028e77436b29e38a5686c25c83f85df3629bec7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/pcm.h90 @@ -0,0 +1,76 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! PCM.h90: 1d piecewise constant reconstruction . + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine pcm(npos,nvar,ndof,fdat, & + & fhat) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + + !------------------------------------------- variables ! + integer:: ipos,ivar,idof + + do ipos = +1, npos - 1 + do ivar = +1, nvar + 0 + do idof = +1, ndof + 0 + + fhat(idof,ivar,ipos) = fdat(idof,ivar,ipos) + + end do + end do + end do + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/phycst.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/phycst.mod new file mode 100644 index 0000000000000000000000000000000000000000..10bed7ae3ed903227809c83dd9e38b8f18b28284 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/phycst.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/plm.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/plm.h90 new file mode 100644 index 0000000000000000000000000000000000000000..3ecd33008326148f1ef3b766e5c6361e815c2111 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/plm.h90 @@ -0,0 +1,451 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! PLM.h90: a 1d, slope-limited piecewise linear method. + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine plm(npos,nvar,ndof,delx, & + & fdat,fhat,dmin,ilim) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! ILIM cell slope-limiting selection . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar + integer, intent( in) :: ndof,ilim + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(:) + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + + if (size(delx).gt.+1) then + + !------------------------------- variable grid-spacing ! + + call plmv(npos,nvar,ndof,delx,& + & fdat,fhat,& + & dmin,ilim ) + + else + + !------------------------------- constant grid-spacing ! + + call plmc(npos,nvar,ndof,delx,& + & fdat,fhat,& + & dmin,ilim ) + + end if + + return + + end subroutine + + !------------------------- assemble PLM reconstruction ! + + pure subroutine plmv(npos,nvar,ndof,delx, & + & fdat,fhat,dmin,ilim) + + ! + ! *this is the variable grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! ILIM cell slope-limiting selection . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar + integer, intent( in) :: ndof,ilim + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(:) + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + + !------------------------------------------- variables ! + integer :: ipos,ivar,head,tail + real*8 :: dfds(-1:+1) + + head = +1; tail = npos - 1 + + if (npos.eq.2) then + !----------------------- reduce order if small stencil ! + do ivar = +1, nvar + fhat(1,ivar,1) = & + & fdat(1,ivar,1) + fhat(2,ivar,1) = 0.e+0 + end do + end if + + if (npos.le.2) return + + !-------------------------------------- lower-endpoint ! + + do ivar = +1 , nvar-0 + + call plsv( & + & fdat(1,ivar,head+0) , & + & delx(head+0), & + & fdat(1,ivar,head+0) , & + & delx(head+0), & + & fdat(1,ivar,head+1) , & + & delx(head+1), dfds) + + fhat(1,ivar,head) = & + & fdat(1,ivar,head) + fhat(2,ivar,head) = dfds(0) + + end do + + !-------------------------------------- upper-endpoint ! + + do ivar = +1 , nvar-0 + + call plsv( & + & fdat(1,ivar,tail-1) , & + & delx(tail-1), & + & fdat(1,ivar,tail+0) , & + & delx(tail+0), & + & fdat(1,ivar,tail+0) , & + & delx(tail+0), dfds) + + fhat(1,ivar,tail) = & + & fdat(1,ivar,tail) + fhat(2,ivar,tail) = dfds(0) + + end do + + !-------------------------------------- interior cells ! + + do ipos = +2 , npos-2 + do ivar = +1 , nvar-0 + + call plsv( & + & fdat(1,ivar,ipos-1) , & + & delx(ipos-1), & + & fdat(1,ivar,ipos+0) , & + & delx(ipos+0), & + & fdat(1,ivar,ipos+1) , & + & delx(ipos+1), dfds) + + fhat(1,ivar,ipos) = & + & fdat(1,ivar,ipos) + fhat(2,ivar,ipos) = dfds(0) + + end do + end do + + return + + end subroutine + + !------------------------- assemble PLM reconstruction ! + + pure subroutine plmc(npos,nvar,ndof,delx, & + & fdat,fhat,dmin,ilim) + + ! + ! *this is the constant grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! ILIM cell slope-limiting selection . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar + integer, intent( in) :: ndof,ilim + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(1) + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + + !------------------------------------------- variables ! + integer :: ipos,ivar,head,tail + real*8 :: dfds(-1:+1) + + head = +1; tail = npos - 1 + + if (npos.eq.2) then + !----------------------- reduce order if small stencil ! + do ivar = +1, nvar + fhat(1,ivar,1) = & + & fdat(1,ivar,1) + fhat(2,ivar,1) = 0.e+0 + end do + end if + + if (npos.le.2) return + + !-------------------------------------- lower-endpoint ! + + do ivar = +1 , nvar-0 + + call plsc( & + & fdat(1,ivar,head+0) , & + & fdat(1,ivar,head+0) , & + & fdat(1,ivar,head+1) , & + & dfds) + + fhat(1,ivar,head) = & + & fdat(1,ivar,head) + fhat(2,ivar,head) = dfds(0) + + end do + + !-------------------------------------- upper-endpoint ! + + do ivar = +1 , nvar-0 + + call plsc( & + & fdat(1,ivar,tail-1) , & + & fdat(1,ivar,tail+0) , & + & fdat(1,ivar,tail+0) , & + & dfds) + + fhat(1,ivar,tail) = & + & fdat(1,ivar,tail) + fhat(2,ivar,tail) = dfds(0) + + end do + + !-------------------------------------- interior cells ! + + do ipos = +2 , npos-2 + do ivar = +1 , nvar-0 + + call plsc( & + & fdat(1,ivar,ipos-1) , & + & fdat(1,ivar,ipos+0) , & + & fdat(1,ivar,ipos+1) , & + & dfds) + + fhat(1,ivar,ipos) = & + & fdat(1,ivar,ipos) + fhat(2,ivar,ipos) = dfds(0) + + end do + end do + + return + + end subroutine + + !------------------------------- assemble PLM "slopes" ! + + pure subroutine plsv(ffll,hhll,ff00,hh00,& + & ffrr,hhrr,dfds) + + ! + ! *this is the variable grid-spacing variant . + ! + ! FFLL left -biased grid-cell mean. + ! HHLL left -biased grid-cell spac. + ! FF00 centred grid-cell mean. + ! HH00 centred grid-cell spac. + ! FFRR right-biased grid-cell mean. + ! HHRR right-biased grid-cell spac. + ! DFDS piecewise linear gradients in local co-ord.'s. + ! DFDS(+0) is a centred, slope-limited estimate, + ! DFDS(-1), DFDS(+1) are left- and right-biased + ! estimates (unlimited). + ! + + implicit none + + !------------------------------------------- arguments ! + real*8 , intent( in) :: ffll,ff00,ffrr + real*8 , intent( in) :: hhll,hh00,hhrr + real*8 , intent(out) :: dfds(-1:+1) + + !------------------------------------------- variables ! + real*8 :: fell,ferr,scal + + real*8 , parameter :: ZERO = 1.e-14 + + !---------------------------- 2nd-order approximations ! + + dfds(-1) = ff00-ffll + dfds(+1) = ffrr-ff00 + + if (dfds(-1) * & + & dfds(+1) .gt. 0.0d+0) then + + !---------------------------- calc. ll//rr edge values ! + + fell = (hh00*ffll+hhll*ff00) & + & / (hhll+hh00) + ferr = (hhrr*ff00+hh00*ffrr) & + & / (hh00+hhrr) + + !---------------------------- calc. centred derivative ! + + dfds(+0) = & + & 0.5d+0 * (ferr - fell) + + !---------------------------- monotonic slope-limiting ! + + scal = min(abs(dfds(-1)), & + & abs(dfds(+1))) & + & / max(abs(dfds(+0)), & + ZERO) + scal = min(scal,+1.0d+0) + + dfds(+0) = scal * dfds(+0) + + else + + !---------------------------- flatten if local extrema ! + + dfds(+0) = +0.0d+0 + + end if + + !---------------------------- scale onto local co-ord. ! + + dfds(-1) = dfds(-1) & + & / (hhll + hh00) * hh00 + dfds(+1) = dfds(+1) & + & / (hh00 + hhrr) * hh00 + + return + + end subroutine + + !------------------------------- assemble PLM "slopes" ! + + pure subroutine plsc(ffll,ff00,ffrr,dfds) + + ! + ! *this is the constant grid-spacing variant . + ! + ! FFLL left -biased grid-cell mean. + ! FF00 centred grid-cell mean. + ! FFRR right-biased grid-cell mean. + ! DFDS piecewise linear gradients in local co-ord.'s. + ! DFDS(+0) is a centred, slope-limited estimate, + ! DFDS(-1), DFDS(+1) are left- and right-biased + ! estimates (unlimited). + ! + + implicit none + + !------------------------------------------- arguments ! + real*8 , intent( in) :: ffll,ff00,ffrr + real*8 , intent(out) :: dfds(-1:+1) + + !------------------------------------------- variables ! + real*8 :: fell,ferr,scal + + real*8 , parameter :: ZERO = 1.e-14 + + !---------------------------- 2nd-order approximations ! + + dfds(-1) = ff00-ffll + dfds(+1) = ffrr-ff00 + + if (dfds(-1) * & + & dfds(+1) .gt. 0.0d+0) then + + !---------------------------- calc. ll//rr edge values ! + + fell = (ffll+ff00) * .5d+0 + ferr = (ff00+ffrr) * .5d+0 + + !---------------------------- calc. centred derivative ! + + dfds(+0) = & + & 0.5d+0 * (ferr - fell) + + !---------------------------- monotonic slope-limiting ! + + scal = min(abs(dfds(-1)), & + & abs(dfds(+1))) & + & / max(abs(dfds(+0)), & + ZERO) + scal = min(scal,+1.0d+0) + + dfds(+0) = scal * dfds(+0) + + else + + !---------------------------- flatten if local extrema ! + + dfds(+0) = +0.0d+0 + + end if + + !---------------------------- scale onto local co-ord. ! + + dfds(-1) = + 0.5d+0 * dfds(-1) + dfds(+1) = + 0.5d+0 * dfds(+1) + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/ppm.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ppm.h90 new file mode 100644 index 0000000000000000000000000000000000000000..f8158111cfd1c1e9b6a285e4ed357fe433e51124 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ppm.h90 @@ -0,0 +1,372 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! PPM.h90: 1d slope-limited, piecewise parabolic recon. + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + ! P. Colella and PR. Woodward, The Piecewise Parabolic + ! Method (PPM) for gas-dynamical simulations., J. Comp. + ! Phys., 54 (1), 1984, 174-201, + ! https://doi.org/10.1016/0021-9991(84)90143-8 + ! + + pure subroutine ppm(npos,nvar,ndof,delx, & + & fdat,fhat,edge,oscl, & + & dmin,ilim,wlim,halo) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! OSCL grid-cell oscil. dof.'s. OSCL is an array with + ! SIZE = +2 -by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! ILIM cell slope-limiting selection . + ! WLIM wall slope-limiting selection . + ! HALO width of re-con. stencil, symmetric about mid. . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,nvar,ndof + real*8 , intent(in) :: dmin + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent(in) :: oscl(:,:,:) + real*8 , intent(in) :: delx(:) + real*8 , intent(in) :: fdat(:,:,:) + real*8 , intent(in) :: edge(:,:) + integer, intent(in) :: ilim,wlim,halo + + !------------------------------------------- variables ! + integer :: ipos,ivar,iill,iirr,head,tail + real*8 :: ff00,ffll,ffrr,hh00,hhll,hhrr + integer :: mono + real*8 :: fell,ferr + real*8 :: dfds(-1:+1) + real*8 :: wval(+1:+2) + real*8 :: uhat(+1:+3) + real*8 :: lhat(+1:+3) + + head = +1; tail = npos - 1 + + if (npos.eq.2) then + !----- default to reduced order if insufficient points ! + do ivar = +1, nvar + fhat(1,ivar,+1) = & + & fdat(1,ivar,+1) + fhat(2,ivar,+1) = 0.e0 + fhat(3,ivar,+1) = 0.e0 + end do + end if + + if (npos.le.2) return + + !------------------- reconstruct function on each cell ! + + uhat = +0.e+0 + lhat = +0.e+0 + + do ipos = +1 , npos-1 + + iill = max(head,ipos-1) + iirr = min(tail,ipos+1) + + do ivar = +1 , nvar-0 + + !----------------------------- cell mean + edge values ! + + ff00 = fdat(1,ivar,ipos) + ffll = fdat(1,ivar,iill) + ffrr = fdat(1,ivar,iirr) + + fell = edge(ivar,ipos+0) + ferr = edge(ivar,ipos+1) + + !----------------------------- calc. LL/00/RR gradient ! + + if (size(delx).gt.+1) then + + hh00 = delx(ipos) + hhll = delx(iill) + hhrr = delx(iirr) + + call plsv (ffll,hhll,ff00, & + & hh00,ffrr,hhrr, & + & dfds) + else + + call plsc (ffll,ff00,ffrr, & + & dfds) + + end if + + !----------------------------- calc. cell-wise profile ! + + select case(ilim) + case (null_limit) + + !----------------------------- calc. unlimited profile ! + + call ppmfn(ff00,ffll,ffrr, & + & fell,ferr,dfds, & + & uhat,lhat,mono) + + !----------------------------- pref. unlimited profile ! + + wval(1) = +1.e+0 + wval(2) = +0.e+0 + + case (mono_limit) + + !----------------------------- calc. monotonic profile ! + + call ppmfn(ff00,ffll,ffrr, & + & fell,ferr,dfds, & + & uhat,lhat,mono) + + !----------------------------- pref. monotonic profile ! + + wval(1) = +0.e+0 + wval(2) = +1.e+0 + + case (weno_limit) + + !----------------------------- calc. unlimited profile ! + + call ppmfn(ff00,ffll,ffrr, & + & fell,ferr,dfds, & + & uhat,lhat,mono) + + if (mono.gt.+0) then + + !----------------------------- calc. WENO-type weights ! + + call wenoi(npos,delx,oscl, & + & ipos,ivar,halo, & + & wlim,wval) + + else + + !----------------------------- pref. unlimited profile ! + + wval(1) = +1.e+0 + wval(2) = +0.e+0 + + end if + + end select + + !----------------------------- blend "null" and "mono" ! + + fhat(1,ivar,ipos) = & + & wval(1) * uhat(1) + & + & wval(2) * lhat(1) + fhat(2,ivar,ipos) = & + & wval(1) * uhat(2) + & + & wval(2) * lhat(2) + fhat(3,ivar,ipos) = & + & wval(1) * uhat(3) + & + & wval(2) * lhat(3) + + end do + + end do + + return + + end subroutine + + !--------- assemble piecewise parabolic reconstruction ! + + pure subroutine ppmfn(ff00,ffll,ffrr,fell,& + & ferr,dfds,uhat,lhat,& + & mono) + + ! + ! FF00 centred grid-cell mean. + ! FFLL left -biased grid-cell mean. + ! FFRR right-biased grid-cell mean. + ! FELL left -biased edge interp. + ! FERR right-biased edge interp. + ! DFDS piecewise linear gradients in local co-ord.'s. + ! DFDS(+0) is a centred, slope-limited estimate, + ! DFDS(-1), DFDS(+1) are left- and right-biased + ! estimates (unlimited). + ! UHAT unlimited PPM reconstruction coefficients . + ! LHAT monotonic PPM reconstruction coefficients . + ! MONO slope-limiting indicator, MONO > +0 if some + ! limiting has occured . + ! + + implicit none + + !------------------------------------------- arguments ! + real*8 , intent(in) :: ff00 + real*8 , intent(in) :: ffll,ffrr + real*8 , intent(inout) :: fell,ferr + real*8 , intent(in) :: dfds(-1:+1) + real*8 , intent(out) :: uhat(+1:+3) + real*8 , intent(out) :: lhat(+1:+3) + integer, intent(out) :: mono + + !------------------------------------------- variables ! + real*8 :: turn + + mono = 0 + + !-------------------------------- "null" slope-limiter ! + + uhat( 1 ) = & + & + (3.0d+0 / 2.0d+0) * ff00 & + & - (1.0d+0 / 4.0d+0) *(ferr+fell) + uhat( 2 ) = & + & + (1.0d+0 / 2.0d+0) *(ferr-fell) + uhat( 3 ) = & + & - (3.0d+0 / 2.0d+0) * ff00 & + & + (3.0d+0 / 4.0d+0) *(ferr+fell) + + !-------------------------------- "mono" slope-limiter ! + + if((ffrr - ff00) * & + & (ff00 - ffll) .lt. 0.e+0) then + + !----------------------------------- "flatten" extrema ! + + mono = +1 + + lhat(1) = ff00 + lhat(2) = 0.e0 + lhat(3) = 0.e0 + + return + + end if + + !----------------------------------- limit edge values ! + + if((ffll - fell) * & + & (fell - ff00) .le. 0.e+0) then + + mono = +1 + + fell = ff00 - dfds(0) + + end if + + if((ffrr - ferr) * & + & (ferr - ff00) .le. 0.e+0) then + + mono = +1 + + ferr = ff00 + dfds(0) + + end if + + !----------------------------------- update ppm coeff. ! + + lhat( 1 ) = & + & + (3.0d+0 / 2.0d+0) * ff00 & + & - (1.0d+0 / 4.0d+0) *(ferr+fell) + lhat( 2 ) = & + & + (1.0d+0 / 2.0d+0) *(ferr-fell) + lhat( 3 ) = & + & - (3.0d+0 / 2.0d+0) * ff00 & + & + (3.0d+0 / 4.0d+0) *(ferr+fell) + + !----------------------------------- limit cell values ! + + if (abs(lhat(3)) .gt. & + & abs(lhat(2))*.5d+0) then + + turn = -0.5d+0 * lhat(2) & + & / lhat(3) + + if ((turn .ge. -1.e+0)& + & .and.(turn .le. +0.e+0)) then + + mono = +2 + + !--------------------------- push TURN onto lower edge ! + + ferr = +3.0d+0 * ff00 & + & -2.0d+0 * fell + + lhat( 1 ) = & + & + (3.0d+0 / 2.0d+0) * ff00 & + & - (1.0d+0 / 4.0d+0) *(ferr+fell) + lhat( 2 ) = & + & + (1.0d+0 / 2.0d+0) *(ferr-fell) + lhat( 3 ) = & + & - (3.0d+0 / 2.0d+0) * ff00 & + & + (3.0d+0 / 4.0d+0) *(ferr+fell) + + else & + & if ((turn .gt. +0.e+0)& + & .and.(turn .le. +1.e+0)) then + + mono = +2 + + !--------------------------- push TURN onto upper edge ! + + fell = +3.0d+0 * ff00 & + & -2.0d+0 * ferr + + lhat( 1 ) = & + & + (3.0d+0 / 2.0d+0) * ff00 & + & - (1.0d+0 / 4.0d+0) *(ferr+fell) + lhat( 2 ) = & + & + (1.0d+0 / 2.0d+0) *(ferr-fell) + lhat( 3 ) = & + & - (3.0d+0 / 2.0d+0) * ff00 & + & + (3.0d+0 / 4.0d+0) *(ferr+fell) + + end if + + end if + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/ppr_1d.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ppr_1d.mod new file mode 100644 index 0000000000000000000000000000000000000000..bab39727d339f0699d1fbec49b9a8aad5c6f95db Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/ppr_1d.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/pqm.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/pqm.h90 new file mode 100644 index 0000000000000000000000000000000000000000..c834c3daa5886871c672841bd99239ce62c09ce2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/pqm.h90 @@ -0,0 +1,578 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! PQM.h90: a 1d slope-limited, piecewise quartic recon. + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + ! White, L. and Adcroft, A., A high-order finite volume + ! remapping scheme for nonuniform grids: The piecewise + ! quartic method (PQM), J. Comp. Phys., 227 (15), 2008, + ! 7394-7422, https://doi.org/10.1016/j.jcp.2008.04.026. + ! + + pure subroutine pqm(npos,nvar,ndof,delx, & + & fdat,fhat,edge,dfdx, & + & oscl,dmin,ilim,wlim, & + & halo) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! OSCL grid-cell oscil. dof.'s. OSCL is an array with + ! SIZE = +2 -by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! ILIM cell slope-limiting selection . + ! WLIM wall slope-limiting selection . + ! HALO width of re-con. stencil, symmetric about mid. . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,nvar,ndof + integer, intent(in) :: ilim,wlim,halo + real*8 , intent(in) :: dmin + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent(in) :: oscl(:,:,:) + real*8 , intent(in) :: delx(:) + real*8 , intent(in) :: fdat(:,:,:) + real*8 , intent(in) :: edge(:,:) + real*8 , intent(in) :: dfdx(:,:) + + !------------------------------------------- variables ! + integer :: ipos,ivar,iill,iirr,head,tail + real*8 :: ff00,ffll,ffrr,hh00,hhll,hhrr + real*8 :: xhat + integer :: mono + real*8 :: fell,ferr + real*8 :: dell,derr + real*8 :: dfds(-1:+1) + real*8 :: uhat(+1:+5) + real*8 :: lhat(+1:+5) + real*8 :: wval(+1:+2) + + head = +1; tail = npos - 1 + + if (npos.le.2) then + !----- default to reduced order if insufficient points ! + do ivar = +1, nvar + fhat(1,ivar,+1) = fdat(1,ivar,+1) + fhat(2,ivar,+1) = 0.e0 + fhat(3,ivar,+1) = 0.e0 + fhat(4,ivar,+1) = 0.e0 + fhat(5,ivar,+1) = 0.e0 + end do + end if + + if (npos.le.2) return + + !------------------- reconstruct function on each cell ! + + do ipos = +1 , npos-1 + + iill = max(head,ipos-1) + iirr = min(tail,ipos+1) + + do ivar = +1 , nvar-0 + + !----------------------------- cell mean + edge values ! + + ff00 = fdat(1,ivar,ipos) + ffll = fdat(1,ivar,iill) + ffrr = fdat(1,ivar,iirr) + + fell = edge(ivar,ipos+0) + ferr = edge(ivar,ipos+1) + + !----------------------------- calc. LL/00/RR gradient ! + + if (size(delx).gt.+1) then + + hh00 = delx(ipos) + hhll = delx(iill) + hhrr = delx(iirr) + + xhat = delx(ipos+0)*.5d+0 + + call plsv (ffll,hhll,ff00, & + & hh00,ffrr,hhrr, & + & dfds) + else + + xhat = delx( +1)*.5d+0 + + call plsc (ffll,ff00,ffrr, & + & dfds) + + end if + + dell = dfdx (ivar,ipos+0) + dell = dell * xhat + + derr = dfdx (ivar,ipos+1) + derr = derr * xhat + + !----------------------------- calc. cell-wise profile ! + + select case(ilim) + case (null_limit) + + !----------------------------- calc. unlimited profile ! + + call pqmfn(ff00,ffll,ffrr, & + & fell,ferr,dell, & + & derr,dfds,uhat, & + & lhat,mono) + + !----------------------------- pref. unlimited profile ! + + wval(1) = +1.e+0 + wval(2) = +0.e+0 + + case (mono_limit) + + !----------------------------- calc. monotonic profile ! + + call pqmfn(ff00,ffll,ffrr, & + & fell,ferr,dell, & + & derr,dfds,uhat, & + & lhat,mono) + + !----------------------------- pref. monotonic profile ! + + wval(1) = +0.e+0 + wval(2) = +1.e+0 + + case (weno_limit) + + !----------------------------- calc. monotonic profile ! + + call pqmfn(ff00,ffll,ffrr, & + & fell,ferr,dell, & + & derr,dfds,uhat, & + & lhat,mono) + + if (mono.gt.+0) then + + !----------------------------- calc. WENO-type weights ! + + call wenoi(npos,delx,oscl, & + & ipos,ivar,halo, & + & wlim,wval) + + else + + !----------------------------- pref. unlimited profile ! + + wval(1) = +1.e+0 + wval(2) = +0.e+0 + + end if + + end select + + !----------------------------- blend "null" and "mono" ! + + fhat(1,ivar,ipos) = & + & wval(1) * uhat(1) + & + & wval(2) * lhat(1) + fhat(2,ivar,ipos) = & + & wval(1) * uhat(2) + & + & wval(2) * lhat(2) + fhat(3,ivar,ipos) = & + & wval(1) * uhat(3) + & + & wval(2) * lhat(3) + fhat(4,ivar,ipos) = & + & wval(1) * uhat(4) + & + & wval(2) * lhat(4) + fhat(5,ivar,ipos) = & + & wval(1) * uhat(5) + & + & wval(2) * lhat(5) + + end do + + end do + + return + + end subroutine + + !----------- assemble piecewise quartic reconstruction ! + + pure subroutine pqmfn(ff00,ffll,ffrr,fell, & + & ferr,dell,derr,dfds, & + & uhat,lhat,mono) + + ! + ! FF00 centred grid-cell mean. + ! FFLL left -biased grid-cell mean. + ! FFRR right-biased grid-cell mean. + ! FELL left -biased edge interp. + ! FERR right-biased edge interp. + ! DELL left -biased edge df//dx. + ! DERR right-biased edge df//dx. + ! DFDS piecewise linear gradients in local co-ord.'s. + ! DFDS(+0) is a centred, slope-limited estimate, + ! DFDS(-1), DFDS(+1) are left- and right-biased + ! estimates (unlimited). + ! UHAT unlimited PPM reconstruction coefficients . + ! LHAT monotonic PPM reconstruction coefficients . + ! MONO slope-limiting indicator, MONO > +0 if some + ! limiting has occured . + ! + + implicit none + + !------------------------------------------- arguments ! + real*8 , intent(in) :: ff00 + real*8 , intent(in) :: ffll,ffrr + real*8 , intent(inout) :: fell,ferr + real*8 , intent(inout) :: dell,derr + real*8 , intent(in) :: dfds(-1:+1) + real*8 , intent(out) :: uhat(+1:+5) + real*8 , intent(out) :: lhat(+1:+5) + integer, intent(out) :: mono + + !------------------------------------------- variables ! + integer :: turn + real*8 :: grad, iflx(+1:+2) + logical :: haveroot + + !-------------------------------- "null" slope-limiter ! + + mono = 0 + + uhat(1) = & + & + (30.e+0 / 16.e+0) * ff00 & + & - ( 7.e+0 / 16.e+0) *(ferr+fell) & + & + ( 1.e+0 / 16.e+0) *(derr-dell) + uhat(2) = & + & + ( 3.e+0 / 4.e+0) *(ferr-fell) & + & - ( 1.e+0 / 4.e+0) *(derr+dell) + uhat(3) = & + & - (30.e+0 / 8.e+0) * ff00 & + & + (15.e+0 / 8.e+0) *(ferr+fell) & + & - ( 3.e+0 / 8.e+0) *(derr-dell) + uhat(4) = & + & - ( 1.e+0 / 4.e+0) *(ferr-fell & + & -derr-dell) + uhat(5) = & + & + (30.e+0 / 16.e+0) * ff00 & + & - (15.e+0 / 16.e+0) *(ferr+fell) & + & + ( 5.e+0 / 16.e+0) *(derr-dell) + + !-------------------------------- "mono" slope-limiter ! + + if((ffrr - ff00) * & + & (ff00 - ffll) .le. 0.e+0) then + + !----------------------------------- "flatten" extrema ! + + mono = +1 + + lhat(1) = ff00 + lhat(2) = 0.e0 + lhat(3) = 0.e0 + lhat(4) = 0.e0 + lhat(5) = 0.e0 + + return + + end if + + !----------------------------------- limit edge values ! + + if((ffll - fell) * & + & (fell - ff00) .le. 0.e+0) then + + mono = +1 + + fell = ff00 - dfds(0) + + end if + + if (dell * dfds(0) .lt. 0.e+0) then + + mono = +1 + + dell = dfds(0) + + end if + + if((ffrr - ferr) * & + & (ferr - ff00) .le. 0.e+0) then + + mono = +1 + + ferr = ff00 + dfds(0) + + end if + + if (derr * dfds(0) .lt. 0.e+0) then + + mono = +1 + + derr = dfds(0) + + end if + + !----------------------------------- limit cell values ! + + lhat(1) = & + & + (30.e+0 / 16.e+0) * ff00 & + & - ( 7.e+0 / 16.e+0) *(ferr+fell) & + & + ( 1.e+0 / 16.e+0) *(derr-dell) + lhat(2) = & + & + ( 3.e+0 / 4.e+0) *(ferr-fell) & + & - ( 1.e+0 / 4.e+0) *(derr+dell) + lhat(3) = & + & - (30.e+0 / 8.e+0) * ff00 & + & + (15.e+0 / 8.e+0) *(ferr+fell) & + & - ( 3.e+0 / 8.e+0) *(derr-dell) + lhat(4) = & + & - ( 1.e+0 / 4.e+0) *(ferr-fell & + & -derr-dell) + lhat(5) = & + & + (30.e+0 / 16.e+0) * ff00 & + & - (15.e+0 / 16.e+0) *(ferr+fell) & + & + ( 5.e+0 / 16.e+0) *(derr-dell) + + !------------------ calc. inflexion via 2nd-derivative ! + + call roots_2(12.e+0 * lhat(5), & + & 6.e+0 * lhat(4), & + & 2.e+0 * lhat(3), & + & iflx , haveroot ) + + if (haveroot) then + + turn = +0 + + if ( ( iflx(1) .gt. -1.e+0 ) & + & .and. ( iflx(1) .lt. +1.e+0 ) ) then + + !------------------ check for non-monotonic inflection ! + + grad = lhat(2) & + &+ (iflx(1)**1) * 2.e+0* lhat(3) & + &+ (iflx(1)**2) * 3.e+0* lhat(4) & + &+ (iflx(1)**3) * 4.e+0* lhat(5) + + if (grad * dfds(0) .lt. 0.e+0) then + + if (abs(dfds(-1)) & + & .lt. abs(dfds(+1)) ) then + + turn = -1 ! modify L + + else + + turn = +1 ! modify R + + end if + + end if + + end if + + if ( ( iflx(2) .gt. -1.e+0 ) & + & .and. ( iflx(2) .lt. +1.e+0 ) ) then + + !------------------ check for non-monotonic inflection ! + + grad = lhat(2) & + &+ (iflx(2)**1) * 2.e+0* lhat(3) & + &+ (iflx(2)**2) * 3.e+0* lhat(4) & + &+ (iflx(2)**3) * 4.e+0* lhat(5) + + if (grad * dfds(0) .lt. 0.e+0) then + + if (abs(dfds(-1)) & + & .lt. abs(dfds(+1)) ) then + + turn = -1 ! modify L + + else + + turn = +1 ! modify R + + end if + + end if + + end if + + !------------------ pop non-monotone inflexion to edge ! + + if (turn .eq. -1) then + + !------------------ pop inflection points onto -1 edge ! + + mono = +2 + + derr = & + &- ( 5.e+0 / 1.e+0) * ff00 & + &+ ( 3.e+0 / 1.e+0) * ferr & + &+ ( 2.e+0 / 1.e+0) * fell + dell = & + &+ ( 5.e+0 / 3.e+0) * ff00 & + &- ( 1.e+0 / 3.e+0) * ferr & + &- ( 4.e+0 / 3.e+0) * fell + + if (dell*dfds(+0) .lt. 0.e+0) then + + dell = 0.e+0 + + ferr = & + &+ ( 5.e+0 / 1.e+0) * ff00 & + &- ( 4.e+0 / 1.e+0) * fell + derr = & + &+ (10.e+0 / 1.e+0) * ff00 & + &- (10.e+0 / 1.e+0) * fell + + else & + & if (derr*dfds(+0) .lt. 0.e+0) then + + derr = 0.e+0 + + fell = & + &+ ( 5.e+0 / 2.e+0) * ff00 & + &- ( 3.e+0 / 2.e+0) * ferr + dell = & + &- ( 5.e+0 / 3.e+0) * ff00 & + &+ ( 5.e+0 / 3.e+0) * ferr + + end if + + lhat(1) = & + &+ (30.e+0 / 16.e+0) * ff00 & + &- ( 7.e+0 / 16.e+0) *(ferr+fell) & + &+ ( 1.e+0 / 16.e+0) *(derr-dell) + lhat(2) = & + &+ ( 3.e+0 / 4.e+0) *(ferr-fell) & + &- ( 1.e+0 / 4.e+0) *(derr+dell) + lhat(3) = & + &- (30.e+0 / 8.e+0) * ff00 & + &+ (15.e+0 / 8.e+0) *(ferr+fell) & + &- ( 3.e+0 / 8.e+0) *(derr-dell) + lhat(4) = & + &- ( 1.e+0 / 4.e+0) *(ferr-fell & + & -derr-dell) + lhat(5) = & + &+ (30.e+0 / 16.e+0) * ff00 & + &- (15.e+0 / 16.e+0) *(ferr+fell) & + &+ ( 5.e+0 / 16.e+0) *(derr-dell) + + end if + + if (turn .eq. +1) then + + !------------------ pop inflection points onto -1 edge ! + + mono = +2 + + derr = & + &- ( 5.e+0 / 3.e+0) * ff00 & + &+ ( 4.e+0 / 3.e+0) * ferr & + &+ ( 1.e+0 / 3.e+0) * fell + dell = & + &+ ( 5.e+0 / 1.e+0) * ff00 & + &- ( 2.e+0 / 1.e+0) * ferr & + &- ( 3.e+0 / 1.e+0) * fell + + if (dell*dfds(+0) .lt. 0.e+0) then + + dell = 0.e+0 + + ferr = & + &+ ( 5.e+0 / 2.e+0) * ff00 & + &- ( 3.e+0 / 2.e+0) * fell + derr = & + &+ ( 5.e+0 / 3.e+0) * ff00 & + &- ( 5.e+0 / 3.e+0) * fell + + else & + & if (derr*dfds(+0) .lt. 0.e+0) then + + derr = 0.e+0 + + fell = & + &+ ( 5.e+0 / 1.e+0) * ff00 & + &- ( 4.e+0 / 1.e+0) * ferr + dell = & + &- (10.e+0 / 1.e+0) * ff00 & + &+ (10.e+0 / 1.e+0) * ferr + + end if + + lhat(1) = & + &+ (30.e+0 / 16.e+0) * ff00 & + &- ( 7.e+0 / 16.e+0) *(ferr+fell) & + &+ ( 1.e+0 / 16.e+0) *(derr-dell) + lhat(2) = & + &+ ( 3.e+0 / 4.e+0) *(ferr-fell) & + &- ( 1.e+0 / 4.e+0) *(derr+dell) + lhat(3) = & + &- (30.e+0 / 8.e+0) * ff00 & + &+ (15.e+0 / 8.e+0) *(ferr+fell) & + &- ( 3.e+0 / 8.e+0) *(derr-dell) + lhat(4) = & + &- ( 1.e+0 / 4.e+0) *(ferr-fell & + & -derr-dell) + lhat(5) = & + &+ (30.e+0 / 16.e+0) * ff00 & + &- (15.e+0 / 16.e+0) *(ferr+fell) & + &+ ( 5.e+0 / 16.e+0) *(derr-dell) + + end if + + end if ! haveroot + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/prtctl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/prtctl.mod new file mode 100644 index 0000000000000000000000000000000000000000..b5621fcc3ec5832159b720f99ee3e0d12429d8e2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/prtctl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/rcon1d.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/rcon1d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..343ebadaf7bad8e68b6a5cffb38cacd6957207a8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/rcon1d.h90 @@ -0,0 +1,202 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! RCON1D.h90: conservative, polynomial reconstructions. + ! + ! Darren Engwirda + ! 07-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine rcon1d(npos,nvar,ndof,delx,fdat, & + & bclo,bchi,fhat,work,opts, & + & tCPU) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCLO boundary condition at lower endpoint. + ! BCHI boundary condition at upper endpoint. + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! WORK method work-space. See RCON-WORK for details . + ! OPTS method parameters. See RCON-OPTS for details . + ! TCPU method tcpu-timer. + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + class(rcon_work), intent(inout):: work + class(rcon_opts), intent(in) :: opts + real*8 , intent( in) :: delx(:) + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + type (rcon_ends), intent(in) :: bclo(:) + type (rcon_ends), intent(in) :: bchi(:) + type (rmap_tics), & + & intent(inout) , optional :: tCPU + + !------------------------------------------- variables ! + integer :: halo,ipos + real*8 :: dmin,dmid + +# ifdef __PPR_TIMER__ + integer(kind=8) :: ttic,ttoc,rate +# endif + + if (ndof.lt.1) return + if (npos.lt.2) return + if (nvar.lt.1) return + + !-------------------------- compute min grid-tolerance ! + + dmid = delx(1) + + if (size(delx).gt.+1) then + + do ipos = 2, npos-1 + dmid = & + & dmid + delx (ipos) + end do + + dmid = dmid /(npos-1) + + end if + + dmin = +1.0d-14 * dmid + + !-------------------------- compute edge values/slopes ! + + + if ( (opts%cell_meth.eq.ppm_method) & + & .or. (opts%cell_meth.eq.pqm_method) ) then + + select case (opts%edge_meth) + case(p1e_method) + !------------------------------------ 2nd-order method ! + halo = +1 + call p1e(npos,nvar,ndof, & + & delx,fdat, & + & bclo,bchi, & + & work%edge_func, & + & work%edge_dfdx, & + & opts,dmin) + + case(p3e_method) + !------------------------------------ 4th-order method ! + halo = +2 + call p3e(npos,nvar,ndof, & + & delx,fdat, & + & bclo,bchi, & + & work%edge_func, & + & work%edge_dfdx, & + & opts,dmin) + + case(p5e_method) + !------------------------------------ 6th-order method ! + halo = +3 + call p5e(npos,nvar,ndof, & + & delx,fdat, & + & bclo,bchi, & + & work%edge_func, & + & work%edge_dfdx, & + & opts,dmin) + + end select + + end if + + + !-------------------------- compute oscil. derivatives ! + + + if (opts%cell_lims.eq.weno_limit) then + + call oscli(npos,nvar,ndof, & + & delx,fdat, & + & work%cell_oscl, & + & dmin) + + end if + + + !-------------------------- compute grid-cell profiles ! + + + select case (opts%cell_meth) + case(pcm_method) + !------------------------------------ 1st-order method ! + call pcm(npos,nvar,ndof, & + & fdat,fhat) + + case(plm_method) + !------------------------------------ 2nd-order method ! + call plm(npos,nvar,ndof, & + & delx,fdat,fhat, & + & dmin,& + & opts%cell_lims) + + case(ppm_method) + !------------------------------------ 3rd-order method ! + call ppm(npos,nvar,ndof, & + & delx,fdat,fhat, & + & work%edge_func, & + & work%cell_oscl, & + & dmin,& + & opts%cell_lims, & + & opts%wall_lims, & + & halo ) + + case(pqm_method) + !------------------------------------ 5th-order method ! + call pqm(npos,nvar,ndof, & + & delx,fdat,fhat, & + & work%edge_func, & + & work%edge_dfdx, & + & work%cell_oscl, & + & dmin,& + & opts%cell_lims, & + & opts%wall_lims, & + & halo ) + + end select + + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/restart.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/restart.mod new file mode 100644 index 0000000000000000000000000000000000000000..4ad5b3d4eb2e34ea5334f6f222a2714dbfe4d91b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/restart.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/restcom.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/restcom.mod new file mode 100644 index 0000000000000000000000000000000000000000..19023d38df2c499512aad67342790001c1fb1a01 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/restcom.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/rmap1d.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/rmap1d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..fa3486e8b022199df66f9d71fb53aa52e3515c41 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/rmap1d.h90 @@ -0,0 +1,481 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! RMAP1D.h90: high-order integral re-mapping operators. + ! + ! Darren Engwirda + ! 31-Mar-2019 + ! ​de2363 [at] columbia [dot] edu + ! + ! + + subroutine rmap1d(npos,nnew,nvar,ndof,xpos, & + & xnew,fdat,fnew,bclo,bcup, & + & work,opts,tCPU) + + ! + ! NPOS no. edges in old grid. + ! NNEW no. edges in new grid. + ! NVAR no. discrete variables to remap. + ! NDOF no. degrees-of-freedom per cell. + ! XPOS old grid edge positions. XPOS is a length NPOS + ! array . + ! XNEW new grid edge positions. XNEW is a length NNEW + ! array . + ! FDAT grid-cell moments on old grid. FNEW has SIZE = + ! NDOF-by-NVAR-by-NNEW-1 . + ! FNEW grid-cell moments on new grid. FNEW has SIZE = + ! NDOF-by-NVAR-by-NNEW-1 . + ! BCLO boundary condition at lower endpoint . + ! BCHI boundary condition at upper endpoint . + ! WORK method work-space. See RCON-WORK for details . + ! OPTS method parameters. See RCON-OPTS for details . + ! TCPU method tcpu-timer. + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nnew + integer, intent( in) :: nvar,ndof + class(rmap_work), intent(inout):: work + class(rmap_opts), intent(inout):: opts + real*8 , intent( in) :: xpos(:) + real*8 , intent( in) :: xnew(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: fnew(:,:,:) + type (rcon_ends), intent(in) :: bclo(:) + type (rcon_ends), intent(in) :: bcup(:) + type (rmap_tics), & + & intent(inout) , optional :: tCPU + + real*8 , parameter :: RTOL = +1.e-14 + + !------------------------------------------- variables ! + integer :: ipos + real*8 :: diff,spac,same,xtol + real*8 :: delx(1) + logical :: uniform + +# ifdef __PPR_TIMER__ + integer(kind=8) :: ttic,ttoc,rate +# endif + + if (ndof.lt.1) return + if (npos.lt.2) return + if (nnew.lt.2) return + if (nvar.lt.1) return + + !------------- calc. grid-spacing and check uniformity ! + + same = (xpos(npos)& + - xpos( +1)) / (npos-1) + + uniform = .true. + + xtol = same * RTOL + + do ipos = +1 , npos-1, +1 + + spac = xpos(ipos+1) & + & - xpos(ipos+0) + + diff = abs(spac - same) + + if (diff.gt.xtol) then + + uniform = .false. + + end if + + work% & + & cell_spac(ipos) = spac + + end do + + !uniform = .false. + + !------------- reconstruct FHAT over all cells in XPOS ! + + if (.not. uniform) then + + !------------------------------------ variable spacing ! + call rcon1d(npos,nvar,ndof, & + & work%cell_spac, & + & fdat,bclo,bcup, & + & work%cell_func, & + & work,opts,tCPU) + + else + + !------------------------------------ constant spacing ! + delx(1) = work%cell_spac(1) + + call rcon1d(npos,nvar,ndof, & + & delx, & + & fdat,bclo,bcup, & + & work%cell_func, & + & work,opts,tCPU) + + end if + + !------------- remap FDAT from XPOS to XNEW using FHAT ! + + + select case(opts%cell_meth) + case(pcm_method) + !------------------------------------ 1st-order method ! + call imap1d(npos,nnew,nvar, & + & ndof, +1, & + & xpos,xnew, & + & work%cell_func, & + & fdat,fnew,xtol) + + case(plm_method) + !------------------------------------ 2nd-order method ! + call imap1d(npos,nnew,nvar, & + & ndof, +2, & + & xpos,xnew, & + & work%cell_func, & + & fdat,fnew,xtol) + + case(ppm_method) + !------------------------------------ 3rd-order method ! + call imap1d(npos,nnew,nvar, & + & ndof, +3, & + & xpos,xnew, & + & work%cell_func, & + & fdat,fnew,xtol) + + case(pqm_method) + !------------------------------------ 5th-order method ! + call imap1d(npos,nnew,nvar, & + & ndof, +5, & + & xpos,xnew, & + & work%cell_func, & + & fdat,fnew,xtol) + + end select + + + return + + end subroutine + + !------------ IMAP1D: 1-dimensional degree-k remapping ! + + pure subroutine imap1d(npos,nnew,nvar,ndof, & + & mdof,xpos,xnew,fhat, & + & fdat,fnew,XTOL) + + ! + ! NPOS no. edges in old grid. + ! NNEW no. edges in new grid. + ! NVAR no. discrete variables to remap. + ! NDOF no. degrees-of-freedom per cell. + ! MDOF no. degrees-of-freedom per FHAT. + ! XPOS old grid edge positions. XPOS is a length NPOS + ! array . + ! XNEW new grid edge positions. XNEW is a length NNEW + ! array . + ! FHAT reconstruction over old grid. FHAT has SIZE = + ! MDOF-by-NVAR-by-NPOS-1 . + ! FDAT grid-cell moments on old grid. FDAT has SIZE = + ! NDOF-by-NVAR-by-NPOS-1 . + ! FNEW grid-cell moments on new grid. FNEW has SIZE = + ! NDOF-by-NVAR-by-NNEW-1 . + ! XTOL min. grid-cell thickness . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nnew + integer, intent( in) :: nvar + integer, intent( in) :: ndof,mdof + real*8 , intent( in) :: xpos(:) + real*8 , intent( in) :: xnew(:) + real*8 , intent( in) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: fnew(:,:,:) + real*8 , intent( in) :: XTOL + + !------------------------------------------- variables ! + integer :: kpos,ipos,ivar,idof + integer :: pos0,pos1,vmin,vmax + real*8 :: xmid,xhat,khat,stmp + real*8 :: xxlo,xxhi,sslo,sshi,intf + real*8 :: vvlo( +1:+5) + real*8 :: vvhi( +1:+5) + real*8 :: ivec( +1:+5) + real*8 :: sdat( +1:nvar) + real*8 :: snew( +1:nvar) + real*8 :: serr( +1:nvar) + integer :: kmin( +1:nvar) + integer :: kmax( +1:nvar) + + integer, parameter :: INTB = -1 ! integral basis + + !------------------------------------- initializations ! + + vvlo(+1:+5) = 0.e0 + vvhi(+1:+5) = 0.e0 + + !------------- remap FDAT from XPOS to XNEW using FHAT ! + + kmin = +1 ; kmax = +1 + pos0 = +1 ; pos1 = +1 + + do kpos = +1, nnew-1 + + !------ first cell in XPOS overlapping with XNEW(KPOS) ! + + pos1 = max(pos1,1) + + do pos0 = pos1, npos-1 + + if (xpos(pos0+1)& + & .gt. xnew(kpos+0)) exit + + end do + + !------ final cell in XPOS overlapping with XNEW(KPOS) ! + + do pos1 = pos0, npos-1 + + if (xpos(pos1+0)& + & .ge. xnew(kpos+1)) exit + + end do + + pos1 = pos1 - 1 + + !------------- integrate FHAT across overlapping cells ! + + khat = xnew(kpos+1) & + & - xnew(kpos+0) + khat = max (khat , XTOL) + + do idof = +1,ndof + do ivar = +1,nvar + + fnew(idof,ivar,kpos) = 0.e0 + + end do + end do + + do ipos = pos0, pos1 + + !------------------------------- integration endpoints ! + + xxlo = max (xpos(ipos+0) , & + & xnew(kpos+0)) + xxhi = min (xpos(ipos+1) , & + & xnew(kpos+1)) + + !------------------------------- local endpoint coords ! + + xmid = xpos(ipos+1) * .5d0 & + & + xpos(ipos+0) * .5d0 + xhat = xpos(ipos+1) * .5d0 & + & - xpos(ipos+0) * .5d0 + + sslo = & + & (xxlo-xmid) / max(xhat,XTOL) + sshi = & + & (xxhi-xmid) / max(xhat,XTOL) + + !------------------------------- integral basis vector ! + + call bfun1d(INTB,mdof, & + sslo,vvlo) + call bfun1d(INTB,mdof, & + sshi,vvhi) + + ivec = vvhi - vvlo + + !--------- integrate FHAT across the overlap XXLO:XXHI ! + + do ivar = +1, nvar + + intf = dot_product ( & + & ivec(+1:mdof), & + & fhat(+1:mdof,ivar,ipos-0) ) + + intf = intf * xhat + + !--------- accumulate integral contributions from IPOS ! + + fnew( +1,ivar,kpos) = & + & fnew( +1,ivar,kpos) + intf + + end do + + end do + + !------------------------------- finalise KPOS profile ! + + do ivar = +1, nvar + + fnew( +1,ivar,kpos) = & + & fnew( +1,ivar,kpos) / khat + + !--------- keep track of MIN/MAX for defect correction ! + + vmax = kmax(ivar) + vmin = kmin(ivar) + + if(fnew(1,ivar,kpos) & + & .gt.fnew(1,ivar,vmax) ) then + + kmax(ivar) = kpos + + else & + & if(fnew(1,ivar,kpos) & + & .lt.fnew(1,ivar,vmin) ) then + + kmin(ivar) = kpos + + end if + + end do + + end do + + !--------- defect corrections: Kahan/Babuska/Neumaier. ! + + ! Carefully compute column sums, leading to a defect + ! wrt. column-wise conservation. Use KBN approach to + ! account for FP roundoff. + + sdat = 0.e0; serr = 0.e0 + do ipos = +1, npos-1 + do ivar = +1, nvar-0 + + !------------------------------- integrate old profile ! + + xhat = xpos(ipos+1) & + & - xpos(ipos+0) + + intf = xhat*fdat(1,ivar,ipos) + + stmp = sdat(ivar) + intf + + if (abs(sdat(ivar)) & + & .ge. abs(intf)) then + + serr(ivar) = & + & serr(ivar) + ((sdat(ivar)-stmp)+intf) + + else + + serr(ivar) = & + & serr(ivar) + ((intf-stmp)+sdat(ivar)) + + end if + + sdat(ivar) = stmp + + end do + end do + + sdat = sdat + serr + + snew = 0.e0; serr = 0.e0 + do ipos = +1, nnew-1 + do ivar = +1, nvar-0 + + !------------------------------- integrate new profile ! + + khat = xnew(ipos+1) & + & - xnew(ipos+0) + + intf = khat*fnew(1,ivar,ipos) + + stmp = snew(ivar) + intf + + if (abs(snew(ivar)) & + & .ge. abs(intf)) then + + serr(ivar) = & + & serr(ivar) + ((snew(ivar)-stmp)+intf) + + else + + serr(ivar) = & + & serr(ivar) + ((intf-stmp)+snew(ivar)) + + end if + + snew(ivar) = stmp + + end do + end do + + snew = snew + serr + serr = sdat - snew + + !--------- defect corrections: nudge away from extrema ! + + ! Add a correction to remapped state to impose exact + ! conservation. Via sign(correction), nudge min/max. + ! cell means, such that monotonicity is not violated + ! near extrema... + + do ivar = +1, nvar-0 + + if (serr(ivar) .gt. 0.e0) then + + vmin = kmin(ivar) + + fnew(1,ivar,vmin) = & + & fnew(1,ivar,vmin) + & + & serr(ivar)/(xnew(vmin+1)-xnew(vmin+0)) + + else & + & if (serr(ivar) .lt. 0.e0) then + + vmax = kmax(ivar) + + fnew(1,ivar,vmax) = & + & fnew(1,ivar,vmax) + & + & serr(ivar)/(xnew(vmax+1)-xnew(vmax+0)) + + end if + + end do + + !------------------------------- new profile now final ! + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/root1d.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/root1d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..1d21cf8fb2423e86d961ee7f7e8e216be1655d69 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/root1d.h90 @@ -0,0 +1,110 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! ROOT1D.h90: find the "roots" of degree-k polynomials. + ! + ! Darren Engwirda + ! 25-Mar-2019 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine roots_2(aa,bb,cc,xx,haveroot) + + ! + ! solve:: aa * xx**2 + bb * xx**1 + cc = +0.0 . + ! + + implicit none + + !------------------------------------------- arguments ! + real*8 , intent( in) :: aa,bb,cc + real*8 , intent(out) :: xx(1:2) + logical, intent(out) :: haveroot + + !------------------------------------------- variables ! + real*8 :: sq,ia,a0,b0,c0,x0 + + real*8, parameter :: rt = +1.e-14 + + a0 = abs(aa) + b0 = abs(bb) + c0 = abs(cc) + + sq = bb * bb - 4.0d+0 * aa * cc + + if (sq .ge. 0.0d+0) then + + sq = sqrt (sq) + + xx(1) = - bb + sq + xx(2) = - bb - sq + + x0 = max(abs(xx(1)), & + & abs(xx(2))) + + if (a0 .gt. (rt*x0)) then + + !-------------------------------------- degree-2 roots ! + + haveroot = .true. + + ia = 0.5d+0 / aa + + xx(1) = xx(1) * ia + xx(2) = xx(2) * ia + + else & + & if (b0 .gt. (rt*c0)) then + + !-------------------------------------- degree-1 roots ! + + haveroot = .true. + + xx(1) = - cc / bb + xx(2) = - cc / bb + + else + + haveroot = .false. + + end if + + else + + haveroot = .false. + + end if + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbc_ice.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbc_ice.mod new file mode 100644 index 0000000000000000000000000000000000000000..e952258ccc36df15a44bb4bfd63fe20384127912 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbc_ice.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbc_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbc_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..18124848e6a24a790b502cc1d9ee0c73340e4186 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbc_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbc_phy.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbc_phy.mod new file mode 100644 index 0000000000000000000000000000000000000000..9cb580917f1eb9b51f4d19a2cfc6893ff35528f5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbc_phy.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcabl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcabl.mod new file mode 100644 index 0000000000000000000000000000000000000000..7e846e6f2fcebb1ed96446e2fc818de69ea274e7 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcabl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcapr.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcapr.mod new file mode 100644 index 0000000000000000000000000000000000000000..c27b54b03b59672d1c87e233c4b86a80c2845004 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcapr.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk.mod new file mode 100644 index 0000000000000000000000000000000000000000..39c9bbd937c5cbd3a2349eed790e38d1ef43a590 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_andreas.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_andreas.mod new file mode 100644 index 0000000000000000000000000000000000000000..11bcc3574dc4af8aab0e4436d3bf1ffcfe1e0b16 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_andreas.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_coare3p0.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_coare3p0.mod new file mode 100644 index 0000000000000000000000000000000000000000..a80ead32ed7e59d320b632094c59f580480f4de2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_coare3p0.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_coare3p6.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_coare3p6.mod new file mode 100644 index 0000000000000000000000000000000000000000..b48e7cde22eb6689fe7e19a797ca630084b7bdd0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_coare3p6.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ecmwf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ecmwf.mod new file mode 100644 index 0000000000000000000000000000000000000000..a5a585caea3bed8be6f2e203690f5bfa24213e21 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ecmwf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_an05.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_an05.mod new file mode 100644 index 0000000000000000000000000000000000000000..c4c819eeb7d83658c574cba39d43e51b32467473 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_an05.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_cdn.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_cdn.mod new file mode 100644 index 0000000000000000000000000000000000000000..c6202aecf153c109f3bf86d4e14e61fb996eabe7 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_cdn.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_lg15.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_lg15.mod new file mode 100644 index 0000000000000000000000000000000000000000..880e34d72e74c08a49754592c2ad644a7a56e4c1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_lg15.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_lu12.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_lu12.mod new file mode 100644 index 0000000000000000000000000000000000000000..57b91c9661deb80c3df89679f6d30a793424566a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ice_lu12.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ncar.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ncar.mod new file mode 100644 index 0000000000000000000000000000000000000000..59bdbf3575107363d598bf3ce83975e14fc96700 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_algo_ncar.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_skin_coare.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_skin_coare.mod new file mode 100644 index 0000000000000000000000000000000000000000..73d03f053be5ae3d1bde5def1e6be7641d331437 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_skin_coare.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_skin_ecmwf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_skin_ecmwf.mod new file mode 100644 index 0000000000000000000000000000000000000000..70233074eecbdab49701bdfcc67ab61a372215fc Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcblk_skin_ecmwf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcclo.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcclo.mod new file mode 100644 index 0000000000000000000000000000000000000000..6420fef941f49f75ab88204b13dec72fabe53652 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcclo.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbccpl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbccpl.mod new file mode 100644 index 0000000000000000000000000000000000000000..588dddb69e900aebcb0103c99801929ffbfc7edb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbccpl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcdcy.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcdcy.mod new file mode 100644 index 0000000000000000000000000000000000000000..7720814d60d472212ac80ce6137ff80977f8d662 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcdcy.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcflx.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcflx.mod new file mode 100644 index 0000000000000000000000000000000000000000..aa339f4493eaa983f8e59fe0ec1d5f688b866e5f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcflx.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcfwb.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcfwb.mod new file mode 100644 index 0000000000000000000000000000000000000000..2cd843b434f9ac1982de4a4eab32d35f63d43939 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcfwb.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcice_cice.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcice_cice.mod new file mode 100644 index 0000000000000000000000000000000000000000..cbd326f49d2c6c946ddbfd1753f74751e8645d18 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcice_cice.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcice_if.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcice_if.mod new file mode 100644 index 0000000000000000000000000000000000000000..c400b20d06f4f521387c167e3ca871d5154eb83b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcice_if.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcmod.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcmod.mod new file mode 100644 index 0000000000000000000000000000000000000000..28319b8f48223afee18ba30817a2bf1a5aff8a02 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcmod.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcrnf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcrnf.mod new file mode 100644 index 0000000000000000000000000000000000000000..d7a011890b0b03fe643e41083c3a88d9825db08a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcrnf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcssm.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcssm.mod new file mode 100644 index 0000000000000000000000000000000000000000..399ea3307ca11ae2ee035879d1599a3d2f3e0eff Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcssm.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcssr.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcssr.mod new file mode 100644 index 0000000000000000000000000000000000000000..69018ca8c2c4833fa910b7d2a9c052be1fd66240 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcssr.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcwave.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcwave.mod new file mode 100644 index 0000000000000000000000000000000000000000..e9221ded5e7fd8fd519d9d211f12d26ae56a9b24 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sbcwave.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/single_precision_substitute.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/single_precision_substitute.h90 new file mode 100644 index 0000000000000000000000000000000000000000..02e78ecb11e60e4ab596a382882f4bf55028e654 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/single_precision_substitute.h90 @@ -0,0 +1,8 @@ +#if defined key_single +# define CASTSP(x) REAL(x,sp) +# define CASTDP(x) REAL(x,dp) +#else +# define CASTSP(x) x +# define CASTDP(x) x +#endif + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/solfrac_mod.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/solfrac_mod.mod new file mode 100644 index 0000000000000000000000000000000000000000..dbc9591d307b2e60c8953a5a487f6f770fc2335b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/solfrac_mod.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/sshwzv.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sshwzv.mod new file mode 100644 index 0000000000000000000000000000000000000000..543743cffdf4bfb47de8db5ef4cc10b02c30b2fd Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/sshwzv.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/step.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/step.mod new file mode 100644 index 0000000000000000000000000000000000000000..e9cabf6339444a280d2d5aa81b59f7922981033e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/step.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/step_diu.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/step_diu.mod new file mode 100644 index 0000000000000000000000000000000000000000..3c829a09e4cd6993768fde0c011864c69805f504 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/step_diu.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/step_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/step_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..871283fbbbed97a3aa559e88b5341061b0fad869 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/step_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/stopar.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/stopar.mod new file mode 100644 index 0000000000000000000000000000000000000000..f9576727fad698dfa621b4a24d60fde7a3fbcd89 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/stopar.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/stopts.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/stopts.mod new file mode 100644 index 0000000000000000000000000000000000000000..34ac69baa548305bd58476430b8b3d9c0c5554c7 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/stopts.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/storng.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/storng.mod new file mode 100644 index 0000000000000000000000000000000000000000..d594a528f67a29befee72d2133bacbadab6e2351 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/storng.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/stpctl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/stpctl.mod new file mode 100644 index 0000000000000000000000000000000000000000..045086168b045ac45869ae1eeeda2bcdac5eaf54 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/stpctl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/stpmlf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/stpmlf.mod new file mode 100644 index 0000000000000000000000000000000000000000..4e56f9b4aadded5e0c7973296751396117cbae74 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/stpmlf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/str_c_to_for.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/str_c_to_for.h90 new file mode 100644 index 0000000000000000000000000000000000000000..97f8ef1f17e4b340aefa7a9995de95b2f553e901 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/str_c_to_for.h90 @@ -0,0 +1,39 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: str_c_to_for.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE str_c_to_for( cd_str ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE str_c_to_for *** + !! + !! ** Purpose : Loop over a string and replace all non-printable + !! ASCII characters with spaces assuming English + !! characters only + !! + !! ** Method : Loop over a string and replace all non-printable + !! ASCII characters with spaces assuming English + !! characters only + !! + !! ** Action : + !! + !! History : + !! ! : 06-05 (K. Mogensen) Original + !! ! : 06-05 (A. Vidard) Cleaning up + !! ! : 06-10 (A. Weaver) More cleaning + !!--------------------------------------------------------------------- + !! * Arguments + CHARACTER(LEN=*), INTENT(INOUT) :: cd_str + + !! * Local declarations + INTEGER :: & + & ji + + DO ji = 1, LEN( cd_str ) + IF ( ( IACHAR( cd_str(ji:ji) ) > 128 ) & + & .OR.( IACHAR( cd_str(ji:ji) ) < 32 ) ) cd_str(ji:ji) = ' ' + END DO + + END SUBROUTINE str_c_to_for \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/stringop.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/stringop.mod new file mode 100644 index 0000000000000000000000000000000000000000..fa3e3eac65ec98b737a270ab37689644e9b1d036 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/stringop.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/tide.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/tide.h90 new file mode 100644 index 0000000000000000000000000000000000000000..fb03c0973657d87ddd8df563ae1647d34e364860 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/tide.h90 @@ -0,0 +1,172 @@ +!!===================================================================== + !! *** Include file tide.h90 *** + !!====================================================================== + !! History : 3.2 ! 2007 (O. Le Galloudec) Original code + !! ! 2019 (S. Mueller, N. Bruneau) Alternative parameter set + !!---------------------------------------------------------------------- + !! + !! ** Purpose : Inclusion of alternative variants of tidal-constituent + !! parameter definitions during code preprocessing: the default + !! variant includes the 34 constituents available in the FES2014 + !! version of the Finite Element Solution - Global Tide data + !! product + !! (https://www.aviso.altimetry.fr/en/data/products/auxiliary-products/global-tide-fes.html); + !! also available is the default parameter set available in + !! previous NEMO versions + !! + !! ** References : + !! S58) Schureman, P. (1958): Manual of Harmonic Analysis and + !! Prediction of Tides (Revised (1940) Edition (Reprinted 1958 + !! with corrections). Reprinted June 2001). U.S. Department of + !! Commerce, Coast and Geodetic Survey Special Publication + !! No. 98. Washington DC, United States Government Printing + !! Office. 317 pp. DOI: 10.25607/OBP-155. + !! CT71) Cartwright, D. E. and Tayler, R. J. (1971): New computations of + !! the Tide-generating Potential. Geophys. J. R. astr. Soc. 23, + !! pp. 45-74. DOI: 10.1111/j.1365-246X.1971.tb01803.x + !! CE73) Cartwright, D. E. and Edden, A. C. (1973): Corrected Tables of + !! Tidal Harmonics. Geophys. J. R. astr. Soc. 33, + !! pp. 253-264. DOI: 10.1111/j.1365-246X.1973.tb03420.x + !! FES2014) FES (Finite element Solution) - Global + !! tide. https://www.aviso.altimetry.fr/en/data/products/auxiliary-products/global-tide-fes.html + !! + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2019) + !! $Id: tide.h90 14502 2021-02-18 18:48:54Z smueller $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +#ifndef TIDE_VAR_0 + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Name | Equilibrium | nt | ns | nh | np | np1 | Phase | nxi | nnu0 | nnu1 | nnu2 | R | Nodal | Equilibrium | Parameters source | Notes | + ! | | tide | | | | | | shift | | | | | | correction | tide | | | + ! | | | | | | | | | | | | | | formula | source/comment | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Long-period tidal constituents | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 1) = tide( 'Mf' , 0.042054_wp , 0 , 2 , 1 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) ! CE73 | S54 (Table 2, A6) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 2) = tide( 'Mm' , 0.022187_wp , 0 , 1 , 0 , -1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) ! CE73 | S54 (Table 2, A2) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 3) = tide( 'Ssa' , 0.019572_wp , 0 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B6) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 4) = tide( 'Mtm' , 0.008052_wp , 0 , 3 , 0 , -1 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) ! CE73 | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm); S54 | | + ! | | | | | | | | | | | | | | | | (Table 2, A7) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 5) = tide( 'Msf' , 0.003677_wp , 0 , 2 , -2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) ! CE73 | S54 (Table 2, A5) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 6) = tide( 'Msqm' , 0.001287_wp , 0 , 4 , -2 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) ! CE73 | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm); S54 | | + ! | | | | | | | | | | | | | | | | (Table 2, A12) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 7) = tide( 'Sa' , 0.000000_wp , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! Meteorological | S54 (Table 2, B64) | | + ! | | | | | | | | | | | | | | | tide only | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Diurnal tidal constituents | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 8) = tide( 'K1' , 0.142486_wp , 1 , 0 , 1 , 0 , 0 , -90 , 0 , 0 , -1 , 0 , 0 , 227 ) ! CE73, sign | S54 (Table 2) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 9) = tide( 'O1' , 0.101316_wp , 1 , -2 , 1 , 0 , 0 , 90 , 2 , -1 , 0 , 0 , 0 , 75 ) ! CE73 | S54 (Table 2, A14) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(10) = tide( 'P1' , 0.047152_wp , 1 , 0 , -1 , 0 , 0 , 90 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B14) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(11) = tide( 'Q1' , 0.019396_wp , 1 , -3 , 1 , 1 , 0 , 90 , 2 , -1 , 0 , 0 , 0 , 75 ) ! CE73 | S54 (Table 2, A15) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(12) = tide( 'J1' , 0.007967_wp , 1 , 1 , 1 , -1 , 0 , -90 , 0 , -1 , 0 , 0 , 0 , 76 ) ! CE73, sign | S54 (Table 2, A24) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(13) = tide( 'S1' , 0.000000_wp , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! Meteorological | S54 (Table 2, B71) | | + ! | | | | | | | | | | | | | | | tide only | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Semidiurnal tidal constituents | + ! +--------+-------------+-----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(14) = tide( 'M2' , 0.244081_wp , 2 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A39) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(15) = tide( 'S2' , 0.110242_wp , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B39) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(16) = tide( 'N2' , 0.046732_wp , 2 , -3 , 2 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A40) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(17) = tide( 'K2' , 0.030905_wp , 2 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , -2 , 0 , 235 ) ! CE73 | S54 (Table 2) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(18) = tide( 'nu2' , 0.008877_wp , 2 , -3 , 4 , -1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A43) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(19) = tide( 'mu2' , 0.007463_wp , 2 , -4 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A45) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(20) = tide( '2N2' , 0.006184_wp , 2 , -4 , 2 , 2 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A42) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(21) = tide( 'L2' , 0.006899_wp , 2 , -1 , 2 , -1 , 0 , 180 , 2 , -2 , 0 , 0 , -1 , 215 ) ! CE73, sign | S54 (Table 2) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(22) = tide( 'T2' , 0.006655_wp , 2 , 0 , -1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B40) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(23) = tide( 'eps2' , 0.001804_wp , 2 , -5 , 4 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(24) = tide( 'lam2' , 0.001800_wp , 2 , -1 , 0 , 1 , 0 , 180 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73, sign | S54 (Table 2, A44) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(25) = tide( 'R2' , 0.000952_wp , 2 , 0 , 1 , 0 , -1 , 180 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73, sign | S54 (Table 2, B41) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Terdiurnal tidal constituents | + ! +--------+-------------+-----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(26) = tide( 'M3' , 0.003192_wp , 3 , -3 , 3 , 0 , 0 , 0 , 3 , -3 , 0 , 0 , 0 , 149 ) ! CT71, sign | S54 (Table 2, A82) | Note 2 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Compound tides | + ! +--------+-------------+-----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(27) = tide( 'MKS2' , 0.000000_wp , 2 , -2 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , -2 , 0 , 4 ) ! Compound tide | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(28) = tide( 'MN4' , 0.000000_wp , 4 , -5 , 4 , 1 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) ! Compound tide | S54 (Table 2a) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(29) = tide( 'MS4' , 0.000000_wp , 4 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! Compound tide | FES2014 (prediction | Note 3 | + ! | | | | | | | | | | | | | | | | algorithm); S54 | | + ! | | | | | | | | | | | | | | | | (Table 2a) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Overtides | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(30) = tide( 'M4' , 0.000000_wp , 4 , -4 , 4 , 0 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(31) = tide( 'N4' , 0.000000_wp , 4 , -6 , 4 , 2 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) ! Overtide | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(32) = tide( 'S4' , 0.000000_wp , 4 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(33) = tide( 'M6' , 0.000000_wp , 6 , -6 , 6 , 0 , 0 , 0 , 6 , -6 , 0 , 0 , 0 , 18 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(34) = tide( 'M8' , 0.000000_wp , 8 , -8 , 8 , 0 , 0 , 0 , 8 , -8 , 0 , 0 , 0 , 20 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! Note 1: the negative sign of the equilibrium-tide value derived from CE73 has been changed to accomodate the phase shift from Table 2 of S54. + ! Note 2: the negative sign of the equilibrium-tide value derived from CT71 has been changed to accomodate the phase shift from Table 2 of S54. + ! Note 3: the nodal correction factor formulas from FES2014 and S54 differ; here, the version from FES2014 has been selected. +#else + ! !! name_tide , equitide , nt , ns , nh , np , np1 , shift , nksi , nnu0 , nnu1 , nnu2 , R , formula !! + ! !! ! ! ! ! ! ! ! ! ! ! ! ! ! !! + tide_components( 1) = tide( 'M2' , 0.242297 , 2 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components( 2) = tide( 'N2' , 0.046313 , 2 , -3 , 2 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components( 3) = tide( '2N2' , 0.006184 , 2 , -4 , 2 , 2 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components( 4) = tide( 'S2' , 0.113572 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) + tide_components( 5) = tide( 'K2' , 0.030875 , 2 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , -2 , 0 , 235 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components( 6) = tide( 'K1' , 0.142408 , 1 , 0 , 1 , 0 , 0 , -90 , 0 , 0 , -1 , 0 , 0 , 227 ) + tide_components( 7) = tide( 'O1' , 0.101266 , 1 , -2 , 1 , 0 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) + tide_components( 8) = tide( 'Q1' , 0.019387 , 1 , -3 , 1 , 1 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) + tide_components( 9) = tide( 'P1' , 0.047129 , 1 , 0 , -1 , 0 , 0 , +90 , 0 , 0 , 0 , 0 , 0 , 0 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components(10) = tide( 'M4' , 0.000000 , 4 , -4 , 4 , 0 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components(11) = tide( 'Mf' , 0.042017 , 0 , 2 , 0 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + tide_components(12) = tide( 'Mm' , 0.022191 , 0 , 1 , 0 , -1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) + tide_components(13) = tide( 'Msqm' , 0.000667 , 0 , 4 , -2 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + tide_components(14) = tide( 'Mtm' , 0.008049 , 0 , 3 , 0 , -1 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components(15) = tide( 'S1' , 0.000000 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) + tide_components(16) = tide( 'MU2' , 0.005841 , 2 , -4 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components(17) = tide( 'NU2' , 0.009094 , 2 , -3 , 4 , -1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components(18) = tide( 'L2' , 0.006694 , 2 , -1 , 2 , -1 , 0 , +180 , 2 , -2 , 0 , 0 , 0 , 215 ) + tide_components(19) = tide( 'T2' , 0.006614 , 2 , 0 , -1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) +#endif \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/tide_mod.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/tide_mod.mod new file mode 100644 index 0000000000000000000000000000000000000000..cbf983d634b9ecf956d6337b8e990f6899505cba Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/tide_mod.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/timing.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/timing.mod new file mode 100644 index 0000000000000000000000000000000000000000..513074a260cbe02a1d4549b7eacc04fc43040f9a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/timing.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv.mod new file mode 100644 index 0000000000000000000000000000000000000000..a9b2b4cc4f0c6f8a20b557210807ac0abe8078bf Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_cen.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_cen.mod new file mode 100644 index 0000000000000000000000000000000000000000..c4017846aefbd3622116da24fad59bba185a398d Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_cen.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_cen_lf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_cen_lf.mod new file mode 100644 index 0000000000000000000000000000000000000000..2887b8993053e507afce8b6518e5fd5855713d77 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_cen_lf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_fct.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_fct.mod new file mode 100644 index 0000000000000000000000000000000000000000..5e95d6aa598a1f2e14cb40991c16baef99795c83 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_fct.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_mus.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_mus.mod new file mode 100644 index 0000000000000000000000000000000000000000..0eb6db686038622c79a9122da71c37d0869b0537 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_mus.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_qck.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_qck.mod new file mode 100644 index 0000000000000000000000000000000000000000..8d20a12f30f0fa2eec838f12456fccd513fab992 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_qck.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_qck_lf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_qck_lf.mod new file mode 100644 index 0000000000000000000000000000000000000000..28222c5b277e19794f36c6b4f5b12a200b76ef17 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_qck_lf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_ubs.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_ubs.mod new file mode 100644 index 0000000000000000000000000000000000000000..bc148067cc137cabca1edd45647083d8d049e88b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_ubs.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_ubs_lf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_ubs_lf.mod new file mode 100644 index 0000000000000000000000000000000000000000..b7a63e0cf18e95ced824b2a1939d11febbd4aeb6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traadv_ubs_lf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traatf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traatf.mod new file mode 100644 index 0000000000000000000000000000000000000000..dfafb2c9a840902882ad88ca56cc101600851292 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traatf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traatf_qco.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traatf_qco.mod new file mode 100644 index 0000000000000000000000000000000000000000..fac06fb8db1a5043ed2856f58091df3be9a99dd5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traatf_qco.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trabbc.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trabbc.mod new file mode 100644 index 0000000000000000000000000000000000000000..cc9108701dcd40044e72ec9c43ccd25b9a69130f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trabbc.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trabbl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trabbl.mod new file mode 100644 index 0000000000000000000000000000000000000000..b0ee48d7a580ca5ce9088b1bbd9a91669f393830 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trabbl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/tradmp.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/tradmp.mod new file mode 100644 index 0000000000000000000000000000000000000000..5670b421d81a7ede6489ae5f2f26b7adee21f0fb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/tradmp.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traisf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traisf.mod new file mode 100644 index 0000000000000000000000000000000000000000..e2667cf5fefd9ac8631352c09119fb7fcf381e0c Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traisf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf.mod new file mode 100644 index 0000000000000000000000000000000000000000..32288b7700cac70bf842a7b9b2d6e28420d80acb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf_iso.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf_iso.mod new file mode 100644 index 0000000000000000000000000000000000000000..78f0fcb6cc429a33ab612099933bcd40bcce0267 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf_iso.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf_lap_blp.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf_lap_blp.mod new file mode 100644 index 0000000000000000000000000000000000000000..b5cad42f218364f4e5c4b72dcbe8e7533673e1d4 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf_lap_blp.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf_triad.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf_triad.mod new file mode 100644 index 0000000000000000000000000000000000000000..ad00c233859232de570a4d6d700ab66af59bd06e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traldf_triad.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/tramle.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/tramle.mod new file mode 100644 index 0000000000000000000000000000000000000000..1320f96f3a3d161d799cb489bf0573cedbd0f056 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/tramle.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/tranpc.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/tranpc.mod new file mode 100644 index 0000000000000000000000000000000000000000..d74ee8d0c1700118327d227ef123fff356a2fd72 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/tranpc.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/traqsr.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traqsr.mod new file mode 100644 index 0000000000000000000000000000000000000000..c7cfe726b4cdd12c0b8a0ef497aec940be4c2cbb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/traqsr.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trasbc.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trasbc.mod new file mode 100644 index 0000000000000000000000000000000000000000..8bd0a3e198ea0d044ed14cf3c12a5175605ef118 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trasbc.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trazdf.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trazdf.mod new file mode 100644 index 0000000000000000000000000000000000000000..af3e9108d9c2de88834f6009dbbc720fceee6652 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trazdf.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trc_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trc_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..5c515d9f5d804dfd7e361e36d5b44f42a067ac8a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trc_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trd_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trd_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..912ff482415bed164c9e61d816c60a912aca91d9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trd_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trddyn.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trddyn.mod new file mode 100644 index 0000000000000000000000000000000000000000..0fcdffaffb02f8f4abc9d2a8549c6724cc602adb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trddyn.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdglo.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdglo.mod new file mode 100644 index 0000000000000000000000000000000000000000..59cffa918e49d1483082bb99dbeebba756e91f95 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdglo.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdini.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdini.mod new file mode 100644 index 0000000000000000000000000000000000000000..018b0f3f65caa5ca952d543770e61ec37a1cc408 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdini.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdken.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdken.mod new file mode 100644 index 0000000000000000000000000000000000000000..f74ea0b5acccfdc9de0a19271853a1091629c885 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdken.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdmxl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdmxl.mod new file mode 100644 index 0000000000000000000000000000000000000000..ad578b60336ec981215b090c8da505bd148f7649 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdmxl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdmxl_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdmxl_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..0f3faf62e783f46e734b2309534b40cab3e80fe3 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdmxl_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdmxl_rst.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdmxl_rst.mod new file mode 100644 index 0000000000000000000000000000000000000000..35b314df813fc169b8eb3b6ea862fcfcbd12515b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdmxl_rst.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdpen.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdpen.mod new file mode 100644 index 0000000000000000000000000000000000000000..1159632a24aae7f263382ad9469981a9991b8f38 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdpen.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdtra.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdtra.mod new file mode 100644 index 0000000000000000000000000000000000000000..2f5d26ffef8b37821e133fb2826af00143e83a24 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdtra.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdtrc.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdtrc.mod new file mode 100644 index 0000000000000000000000000000000000000000..350931169dbceb3d37925a139c208c27fa5e86a5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdtrc.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdvor.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdvor.mod new file mode 100644 index 0000000000000000000000000000000000000000..621043b2347edf2f324ec881f59a86bce54290eb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdvor.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdvor_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdvor_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..88564c23edca57596dfd28ea9d93228528bee24b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/trdvor_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_fmask.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_fmask.mod new file mode 100644 index 0000000000000000000000000000000000000000..4a9e4cf0f077a9a6d322739f2faab81f4a280973 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_fmask.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_hgr.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_hgr.mod new file mode 100644 index 0000000000000000000000000000000000000000..a01750d32b29abb06394c9c70550275ce2cf3f1b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_hgr.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_istate.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_istate.mod new file mode 100644 index 0000000000000000000000000000000000000000..2e62010bdd77f8f59142a1e90213efe9ce2f9cc9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_istate.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_nam.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_nam.mod new file mode 100644 index 0000000000000000000000000000000000000000..c5698bf36c1db3b09fbe8e2569acbf77244e44ad Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_nam.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_sbc.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_sbc.mod new file mode 100644 index 0000000000000000000000000000000000000000..9e8c2b54a7ccc90a5da8a1fb3e9ea626acb83bc2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_sbc.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_zgr.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_zgr.mod new file mode 100644 index 0000000000000000000000000000000000000000..841fffa08b5761ffda1cad7cc5e1ba579a34abf8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/usrdef_zgr.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/util1d.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/util1d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..6b4353ba76ee5c76aaf0541e8f191770ba0ecfd1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/util1d.h90 @@ -0,0 +1,127 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! UTIL1D.h90: util. func. for 1-dim. grid manipulation. + ! + ! Darren Engwirda + ! 31-Mar-2019 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine linspace(xxll,xxuu,npos,xpos) + + ! + ! XXLL lower-bound grid position. + ! NNEW upper-bound grid position. + ! NPOS no. edges in the grid. + ! XPOS array of grid edges. XPOS has length NPOS . + ! + + implicit none + + real*8 , intent(in) :: xxll,xxuu + integer, intent(in) :: npos + real*8 , intent(out) :: xpos(:) + + integer :: ipos + real*8 :: xdel + + xpos( 1) = xxll + xpos(npos) = xxuu + + xdel = (xxuu-xxll) / (npos - 1) + + do ipos = +2, npos-1 + + xpos(ipos) = (ipos-1) * xdel + + end do + + return + + end subroutine + + subroutine rndspace(xxll,xxuu,npos,xpos, & + & frac) + + ! + ! XXLL lower-bound grid position. + ! NNEW upper-bound grid position. + ! NPOS no. edges in the grid. + ! XPOS array of grid edges. XPOS has length NPOS . + ! FRAC fractional perturbation of cell, OPTIONAL . + ! + + implicit none + + real*8 , intent(in) :: xxll,xxuu + integer, intent(in) :: npos + real*8 , intent(out) :: xpos(:) + real*8 , intent(in), optional :: frac + + integer :: ipos + real*8 :: xdel,rand,move + + if (present(frac)) then + move = +frac + else + move = 0.33d0 + end if + + xpos( 1) = xxll + xpos(npos) = xxuu + + xdel = (xxuu-xxll) / (npos - 1) + + do ipos = +2, npos-1 + + xpos(ipos) = (ipos-1) * xdel + + end do + + do ipos = +2, npos-1 + + call random_number (rand) + + rand = 2.e0 * (rand-.5d0) + + move = rand * move + + xpos(ipos) = & + & xpos(ipos) + move * xdel + + end do + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/weno1d.h90 b/cfgs/ORCA2_OCE_MIXED/BLD/inc/weno1d.h90 new file mode 100644 index 0000000000000000000000000000000000000000..d74c76faa23d142eba27ced7929cb5dc4e017c46 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/inc/weno1d.h90 @@ -0,0 +1,415 @@ + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! WENO1D.h90: WENO-style slope-limiting for 1d reconst. + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine wenoi (npos,delx,oscl,ipos, & + & ivar,halo,& + & wlim,wval ) + + ! + ! NPOS no. edges over grid. + ! DELX grid-cell spacing array. SIZE(DELX) == +1 if + ! the grid is uniformly spaced . + ! OSCL cell-centred oscillation-detectors, where OSCL + ! has SIZE = +2-by-NVAR-by-NPOS-1. OSCL is given + ! by calls to OSCLI(). + ! IPOS grid-cell index for which to calc. weights . + ! IVAR state-var index for which to calc/ weights . + ! HALO width of recon. stencil, symmetric about IPOS . + ! WLIM limiter treatment at endpoints, monotonic or + ! otherwise . + ! WVAL WENO weights vector, such that FHAT = WVAL(1) * + ! UHAT + WVAL(2) * LHAT, where UHAT and LHAT are + ! the unlimited and monotonic grid-cell profiles + ! respectively . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,halo + integer, intent(in) :: ipos,ivar + integer, intent(in) :: wlim + real*8 , intent(in) :: delx(:) + real*8 , intent(in) :: oscl(:,:,:) + real*8 , intent(out) :: wval(2) + + !------------------------------------------- variables ! + real*8 :: omin,omax,wsum + + real*8 , parameter :: ZERO = +1.e-16 + + if (size(delx).gt.+1) then + + !------------------- use variable grid spacing variant ! + + call wenov(npos,delx,oscl, & + & ipos,ivar,halo, & + & wlim,omin,omax) + + else + + !------------------- use constant grid spacing variant ! + + call wenoc(npos,delx,oscl, & + & ipos,ivar,halo, & + & wlim,omin,omax) + + end if + + !------------------ compute WENO-style profile weights ! + + omax = omax + ZERO + omin = omin + ZERO + + if (halo .ge. +3) then + + wval(1) = +1.0d+7 / omax ** 3 + wval(2) = +1.0d+0 / omin ** 3 + + else & + & if (halo .le. +2) then + + wval(1) = +1.0d+5 / omax ** 3 + wval(2) = +1.0d+0 / omin ** 3 + + end if + + wsum = wval(1) + wval(2) + ZERO + wval(1) = wval(1) / wsum + ! wval(2) = wval(2) / wsum + wval(2) =-wval(1) + 1.e0 ! wval(2)/wsum but robust ! + + return + + end subroutine + + pure subroutine wenov (npos,delx,oscl,ipos, & + & ivar,halo,& + & wlim,omin,omax) + + ! + ! *this is the variable grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! DELX grid-cell spacing array. SIZE(DELX) == +1 if + ! the grid is uniformly spaced . + ! OSCL cell-centred oscillation-detectors, where OSCL + ! has SIZE = +2-by-NVAR-by-NPOS-1. OSCL is given + ! by calls to OSCLI(). + ! IPOS grid-cell index for which to calc. weights . + ! IVAR state-var index for which to calc/ weights . + ! HALO width of recon. stencil, symmetric about IPOS . + ! WLIM limiter treatment at endpoints, monotonic or + ! otherwise . + ! OMIN min. and max. oscillation indicators over the + ! OMAX local re-con. stencil . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,halo + integer, intent(in) :: ipos,ivar + integer, intent(in) :: wlim + real*8 , intent(in) :: delx(:) + real*8 , intent(in) :: oscl(:,:,:) + real*8 , intent(out) :: omin,omax + + !------------------------------------------- variables ! + integer :: hpos + integer :: head,tail + integer :: imin,imax + real*8 :: deli,delh + real*8 :: hh00,hsqr + real*8 :: dfx1,dfx2 + real*8 :: oval + + !------------------- calc. lower//upper stencil bounds ! + + head = 1; tail = npos - 1 + + if(wlim.eq.mono_limit) then + + !---------------------- deactivate WENO at boundaries ! + + if (ipos-halo.lt.head) then + + omax = 1.e0 + omin = 0.e0 ; return + + end if + + if (ipos+halo.gt.tail) then + + omax = 1.e0 + omin = 0.e0 ; return + + end if + + end if + + !---------------------- truncate stencil at boundaries ! + + imin = max(ipos-halo,head) + imax = min(ipos+halo,tail) + + !------------------ find min/max indicators on stencil ! + + dfx1 = oscl(1,ivar,ipos) + dfx2 = oscl(2,ivar,ipos) + + hh00 = delx(ipos+0)**1 + hsqr = delx(ipos+0)**2 + + oval =(hh00 * dfx1)**2 & + & +(hsqr * dfx2)**2 + + omin = oval + omax = oval + + !---------------------------------------- "lower" part ! + + delh = 0.e0 + + do hpos = ipos-1, imin, -1 + + !------------------ calc. derivatives centred on IPOS. ! + + deli = delx(hpos+0) & + & + delx(hpos+1) + + delh = delh + deli*.5d0 + + dfx1 = oscl(1,ivar,hpos) + dfx2 = oscl(2,ivar,hpos) + + dfx1 = dfx1 + dfx2*delh + + !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! + + oval = (hh00 * dfx1)**2 & + & + (hsqr * dfx2)**2 + + if (oval .lt. omin) then + omin = oval + else & + & if (oval .gt. omax) then + omax = oval + end if + + end do + + !---------------------------------------- "upper" part ! + + delh = 0.e0 + + do hpos = ipos+1, imax, +1 + + !------------------ calc. derivatives centred on IPOS. ! + + deli = delx(hpos+0) & + & + delx(hpos-1) + + delh = delh - deli*.5d0 + + dfx1 = oscl(1,ivar,hpos) + dfx2 = oscl(2,ivar,hpos) + + dfx1 = dfx1 + dfx2*delh + + !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! + + oval = (hh00 * dfx1)**2 & + & + (hsqr * dfx2)**2 + + if (oval .lt. omin) then + omin = oval + else & + & if (oval .gt. omax) then + omax = oval + end if + + end do + + return + + end subroutine + + pure subroutine wenoc (npos,delx,oscl,ipos, & + & ivar,halo,& + & wlim,omin,omax) + + ! + ! *this is the constant grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! DELX grid-cell spacing array. SIZE(DELX) == +1 if + ! the grid is uniformly spaced . + ! OSCL cell-centred oscillation-detectors, where OSCL + ! has SIZE = +2-by-NVAR-by-NPOS-1. OSCL is given + ! by calls to OSCLI(). + ! IPOS grid-cell index for which to calc. weights . + ! IVAR state-var index for which to calc/ weights . + ! HALO width of recon. stencil, symmetric about IPOS . + ! WLIM limiter treatment at endpoints, monotonic or + ! otherwise . + ! OMIN min. and max. oscillation indicators over the + ! OMAX local re-con. stencil . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,halo + integer, intent(in) :: ipos,ivar + integer, intent(in) :: wlim + real*8 , intent(in) :: delx(1) + real*8 , intent(in) :: oscl(:,:,:) + real*8 , intent(out) :: omin,omax + + !------------------------------------------- variables ! + integer :: hpos + integer :: head,tail + integer :: imin,imax + real*8 :: delh + real*8 :: dfx1,dfx2 + real*8 :: oval + + !------------------- calc. lower//upper stencil bounds ! + + head = 1; tail = npos - 1 + + if(wlim.eq.mono_limit) then + + !---------------------- deactivate WENO at boundaries ! + + if (ipos-halo.lt.head) then + + omax = 1.e0 + omin = 0.e0 ; return + + end if + + if (ipos+halo.gt.tail) then + + omax = 1.e0 + omin = 0.e0 ; return + + end if + + end if + + !---------------------- truncate stencil at boundaries ! + + imin = max(ipos-halo,head) + imax = min(ipos+halo,tail) + + !------------------ find min/max indicators on stencil ! + + dfx1 = oscl(1,ivar,ipos) + dfx2 = oscl(2,ivar,ipos) + + oval = (2.e0**1*dfx1)**2 & + & + (2.e0**2*dfx2)**2 + + omin = oval + omax = oval + + !---------------------------------------- "lower" part ! + + delh = 0.e0 + + do hpos = ipos-1, imin, -1 + + !------------------ calc. derivatives centred on IPOS. ! + + delh = delh + 2.e0 + + dfx1 = oscl(1,ivar,hpos) + dfx2 = oscl(2,ivar,hpos) + + dfx1 = dfx1 + dfx2*delh + + !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! + + oval = (2.e0**1*dfx1)**2 & + & + (2.e0**2*dfx2)**2 + + if (oval .lt. omin) then + omin = oval + else & + & if (oval .gt. omax) then + omax = oval + end if + + end do + + !---------------------------------------- "upper" part ! + + delh = 0.e0 + + do hpos = ipos+1, imax, +1 + + !------------------ calc. derivatives centred on IPOS. ! + + delh = delh - 2.e0 + + dfx1 = oscl(1,ivar,hpos) + dfx2 = oscl(2,ivar,hpos) + + dfx1 = dfx1 + dfx2*delh + + !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! + + oval = (2.e0**1*dfx1)**2 & + & + (2.e0**2*dfx2)**2 + + if (oval .lt. omin) then + omin = oval + else & + & if (oval .gt. omax) then + omax = oval + end if + + end do + + return + + end subroutine + + + diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/wet_dry.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/wet_dry.mod new file mode 100644 index 0000000000000000000000000000000000000000..2bd4d2926470f7052c8ff3dbb3264c8a64512ade Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/wet_dry.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdf_oce.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdf_oce.mod new file mode 100644 index 0000000000000000000000000000000000000000..b68676cfbda58f683b6a579058e41b8a89664d31 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdf_oce.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfddm.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfddm.mod new file mode 100644 index 0000000000000000000000000000000000000000..bc22fd2fecd61a13e9642f778fe65c90a6b74c3b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfddm.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfdrg.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfdrg.mod new file mode 100644 index 0000000000000000000000000000000000000000..0774cb3de1e399b82ed9358b68c10ac534a92b53 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfdrg.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfevd.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfevd.mod new file mode 100644 index 0000000000000000000000000000000000000000..3fefb085be5f53afb3d9c1e1490b69ff0190465f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfevd.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfgls.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfgls.mod new file mode 100644 index 0000000000000000000000000000000000000000..b186d8c5b8bcc2da1c8cb41571d1182c332c1dc3 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfgls.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfiwm.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfiwm.mod new file mode 100644 index 0000000000000000000000000000000000000000..f4c3f4f6c25392b5e3f6022f2461b61a424e242a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfiwm.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfmfc.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfmfc.mod new file mode 100644 index 0000000000000000000000000000000000000000..2b86addd9de75edf96114b21ee33c8c97834ff42 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfmfc.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfmxl.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfmxl.mod new file mode 100644 index 0000000000000000000000000000000000000000..09f3b341b7485ff17d47555f037b379c83eef48d Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfmxl.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfosm.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfosm.mod new file mode 100644 index 0000000000000000000000000000000000000000..4f8f250a3b626ce4f4eec4f9d51772efcbba09f1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfosm.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfphy.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfphy.mod new file mode 100644 index 0000000000000000000000000000000000000000..9f24bdaa08014f8b3edcbe159e4f0b3a32ba598b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfphy.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfric.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfric.mod new file mode 100644 index 0000000000000000000000000000000000000000..822ef53bd9afd370380509f70c2c61f4faa495f4 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfric.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfsh2.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfsh2.mod new file mode 100644 index 0000000000000000000000000000000000000000..4e5b428f5577affcc4d0b8ea3a1df6b508210ad5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfsh2.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfswm.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfswm.mod new file mode 100644 index 0000000000000000000000000000000000000000..115a20510797b83ca4fc1423577f31d296d7b08a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdfswm.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdftke.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdftke.mod new file mode 100644 index 0000000000000000000000000000000000000000..60664b05c68ca5e3254c84fe98c32614b302e51b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zdftke.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/inc/zpshde.mod b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zpshde.mod new file mode 100644 index 0000000000000000000000000000000000000000..147eb53b41e116bf4a46473a5137115de0ab3451 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/inc/zpshde.mod differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/abl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/abl.o new file mode 100644 index 0000000000000000000000000000000000000000..e9248b2353a5cad968bee056452d44ccfa2c2f76 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/abl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/asmbkg.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/asmbkg.o new file mode 100644 index 0000000000000000000000000000000000000000..0e49404a2dca20410719d0a85e2607c51278d660 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/asmbkg.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/asminc.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/asminc.o new file mode 100644 index 0000000000000000000000000000000000000000..d90c96b0037ddfdba1a05f6fe5b0aeee75bd2691 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/asminc.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/asmpar.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/asmpar.o new file mode 100644 index 0000000000000000000000000000000000000000..cc0fa5a54cda9e73e9a0a3de1801bff9c4e79ff5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/asmpar.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdy_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdy_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..7ac6fd9bcb800b33d6169481b534033352aea166 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdy_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydta.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydta.o new file mode 100644 index 0000000000000000000000000000000000000000..bddda37071d3c7e1d6ced8e1d14fdcc268f04bb5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydta.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydyn.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydyn.o new file mode 100644 index 0000000000000000000000000000000000000000..8816715f39d1c5bdbcfbf05ae74d5f9e40d8f3d2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydyn.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydyn2d.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydyn2d.o new file mode 100644 index 0000000000000000000000000000000000000000..8fa6c5ebec23c4242609fca3d5eeb6880b4d04b8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydyn2d.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydyn3d.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydyn3d.o new file mode 100644 index 0000000000000000000000000000000000000000..d27a86f4e9fd646d2042a6c262fcef8d710760a3 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdydyn3d.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdyice.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdyice.o new file mode 100644 index 0000000000000000000000000000000000000000..125468bd6dedc3b138d17f4db5d56363cc01ea34 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdyice.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdyini.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdyini.o new file mode 100644 index 0000000000000000000000000000000000000000..50dbbe04591fc30da755ea0685633604101837df Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdyini.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdylib.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdylib.o new file mode 100644 index 0000000000000000000000000000000000000000..b321dad10750f677fee635d2e37b60c625537bb5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdylib.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdytides.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdytides.o new file mode 100644 index 0000000000000000000000000000000000000000..c476c1e5b3df1bdf797b352bf15b3d8b300b5c10 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdytides.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdytra.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdytra.o new file mode 100644 index 0000000000000000000000000000000000000000..36817e4296b5f609a49a2b61dbe2cebfb4507e37 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdytra.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdyvol.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdyvol.o new file mode 100644 index 0000000000000000000000000000000000000000..2fdf802f04cd371e732c70b18ebd37187de86d11 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/bdyvol.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/c1d.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/c1d.o new file mode 100644 index 0000000000000000000000000000000000000000..a765fa609414179bf6b372b9823545981a15863e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/c1d.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/calendar.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/calendar.o new file mode 100644 index 0000000000000000000000000000000000000000..a6251a7537adbfe43fb2f43e7522c98b91f00cbb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/calendar.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/closea.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/closea.o new file mode 100644 index 0000000000000000000000000000000000000000..961f2c02e0c94b6314ea55a02456a14db7d53c94 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/closea.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/cpl_oasis3.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/cpl_oasis3.o new file mode 100644 index 0000000000000000000000000000000000000000..30d893b17488641b4251580477a81d02946b04fa Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/cpl_oasis3.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/crs.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crs.o new file mode 100644 index 0000000000000000000000000000000000000000..6a9fe9fb1d72b74f86f538760b9670664a30f1b1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crs.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsdom.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsdom.o new file mode 100644 index 0000000000000000000000000000000000000000..a88b2e35aa0fa818eac66e4f6265fc0dab3ce2de Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsdom.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsdomwri.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsdomwri.o new file mode 100644 index 0000000000000000000000000000000000000000..e41c4010b46107833ff2c521129d0fb88a99e637 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsdomwri.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsfld.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsfld.o new file mode 100644 index 0000000000000000000000000000000000000000..ddd8523a447f32eec750bd766870fec97c4d1077 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsfld.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsini.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsini.o new file mode 100644 index 0000000000000000000000000000000000000000..30cecc6010c7c1cc7957b6edb4133524e2232385 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crsini.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/crslbclnk.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crslbclnk.o new file mode 100644 index 0000000000000000000000000000000000000000..6c745bf5ec45f019e44df02677c18bc3ee319213 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/crslbclnk.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/cyclone.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/cyclone.o new file mode 100644 index 0000000000000000000000000000000000000000..eec92ecbe4852758c578ac3f043ea0be0f2a1be9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/cyclone.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/daymod.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/daymod.o new file mode 100644 index 0000000000000000000000000000000000000000..2eb34c4a8d8dc14859f28da33384abdcc614d63e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/daymod.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/defprec.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/defprec.o new file mode 100644 index 0000000000000000000000000000000000000000..9da47893dadc5d20bc4975c7d9610bc9259d9583 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/defprec.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/depth_e3.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/depth_e3.o new file mode 100644 index 0000000000000000000000000000000000000000..0a1fb1ab1cb4d72b94e6f6f1e5bbda2d5caf8bf0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/depth_e3.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dia25h.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dia25h.o new file mode 100644 index 0000000000000000000000000000000000000000..06ac562ae1d8173ed007ab2ed2c2b94992179b48 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dia25h.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diaar5.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diaar5.o new file mode 100644 index 0000000000000000000000000000000000000000..34737f6490cd838d08a113fdec0845f05c3eeb5b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diaar5.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diacfl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diacfl.o new file mode 100644 index 0000000000000000000000000000000000000000..19ef49b262dcccf320949c97955886e9df6a330a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diacfl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diadct.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diadct.o new file mode 100644 index 0000000000000000000000000000000000000000..0f0106f51a173c28be66a6d353dc6052db054330 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diadct.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diadetide.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diadetide.o new file mode 100644 index 0000000000000000000000000000000000000000..b9ba8b8cdf7fc6f479feaaf38ce7bfc1f5249db7 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diadetide.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diahsb.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diahsb.o new file mode 100644 index 0000000000000000000000000000000000000000..5c04bd97ae24e6f20e5990243ad0e35c699351ef Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diahsb.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diahth.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diahth.o new file mode 100644 index 0000000000000000000000000000000000000000..a582d41205b35d41cc0e7558865bf8858c0baede Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diahth.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diamlr.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diamlr.o new file mode 100644 index 0000000000000000000000000000000000000000..1ee4fd1fc9da9ec2d3ddd53962340a1c6e2860db Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diamlr.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dianam.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dianam.o new file mode 100644 index 0000000000000000000000000000000000000000..7eb025b37fe98f729d708df6fa251ddba123b99e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dianam.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diaobs.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diaobs.o new file mode 100644 index 0000000000000000000000000000000000000000..1afa68aa08cdc39a18e1b344fbed0ed1df07e29c Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diaobs.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diaptr.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diaptr.o new file mode 100644 index 0000000000000000000000000000000000000000..69f61610b6964ccee441761e3e967e3f04fa4df5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diaptr.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diawri.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diawri.o new file mode 100644 index 0000000000000000000000000000000000000000..26fb9662cebb3e432b4fb656c45c12731fbd9818 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diawri.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diu_bulk.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diu_bulk.o new file mode 100644 index 0000000000000000000000000000000000000000..9e11f1d0f1957d3d96fa0fa25c7b2ef17ca6255f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diu_bulk.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diu_coolskin.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diu_coolskin.o new file mode 100644 index 0000000000000000000000000000000000000000..1f66b7313f2eff4ee470edd3ecbaccb4c44f1abb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diu_coolskin.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/diu_layers.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diu_layers.o new file mode 100644 index 0000000000000000000000000000000000000000..f9b1c60ed55e8a82fa912f2f4a9a678d29477384 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/diu_layers.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/divhor.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/divhor.o new file mode 100644 index 0000000000000000000000000000000000000000..00c36353fe4230e6ae88827cdc32598c172db08b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/divhor.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dom_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dom_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..6beb5348599288e15f289eb0f38c2537ceda8f54 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dom_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/domain.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domain.o new file mode 100644 index 0000000000000000000000000000000000000000..977c989cc0e34e24ca44bef97c7da0ec31789411 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domain.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/domhgr.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domhgr.o new file mode 100644 index 0000000000000000000000000000000000000000..971a5aa8e499b9cb088ca48268f4989c9754cd16 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domhgr.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dommsk.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dommsk.o new file mode 100644 index 0000000000000000000000000000000000000000..2d1e5238d4e748159e6a5f6489fbdd1c4dba51b9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dommsk.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/domqco.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domqco.o new file mode 100644 index 0000000000000000000000000000000000000000..e7453f686cb03c8dc2e4d16943645d266f609561 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domqco.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/domtile.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domtile.o new file mode 100644 index 0000000000000000000000000000000000000000..8d069ec9c4f83c6d9bb5cbbb631666f80083cbdc Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domtile.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/domutl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domutl.o new file mode 100644 index 0000000000000000000000000000000000000000..0ad1d206d3824b995fd9451db65d4f593c08dd1b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domutl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/domvvl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domvvl.o new file mode 100644 index 0000000000000000000000000000000000000000..25ee08db9a0e3d766018f9f8ff93769f60993861 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domvvl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/domwri.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domwri.o new file mode 100644 index 0000000000000000000000000000000000000000..05dd0c8f936881731c145e5fb7faec1e5b4257cf Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domwri.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/domzgr.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domzgr.o new file mode 100644 index 0000000000000000000000000000000000000000..e8478aaef9b2945d8a4a63b333b5ae13c22a55ac Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/domzgr.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dtatsd.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dtatsd.o new file mode 100644 index 0000000000000000000000000000000000000000..e8803271ed5a9ada7fc2d3025d2d4b2a502dbbe0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dtatsd.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dtauvd.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dtauvd.o new file mode 100644 index 0000000000000000000000000000000000000000..9d8b041c1492db21eb0b172aac0eaf28e97248cd Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dtauvd.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynadv.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynadv.o new file mode 100644 index 0000000000000000000000000000000000000000..d61a8559821b7decbaf2c4122557bd28e4a9ada3 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynadv.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynadv_cen2.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynadv_cen2.o new file mode 100644 index 0000000000000000000000000000000000000000..838a68a6294c0f721c1fb0799145c8fc8dd97392 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynadv_cen2.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynadv_ubs.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynadv_ubs.o new file mode 100644 index 0000000000000000000000000000000000000000..a82aa27c4fe97958d5ebf5093ee1a7c128f890ed Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynadv_ubs.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynatf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynatf.o new file mode 100644 index 0000000000000000000000000000000000000000..a83d63de129ac4e24fecca1af5fd11243f03e423 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynatf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynatf_qco.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynatf_qco.o new file mode 100644 index 0000000000000000000000000000000000000000..bfe97f4baaf9faeaf67d33ffede7d7b01b03bad0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynatf_qco.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dyndmp.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dyndmp.o new file mode 100644 index 0000000000000000000000000000000000000000..2744831bdf77881c2a00f735addadcfc3b54a1fc Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dyndmp.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynhpg.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynhpg.o new file mode 100644 index 0000000000000000000000000000000000000000..8bcdc15e693a767e1c9ac93a7cfb69d9dd42dbb4 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynhpg.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynkeg.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynkeg.o new file mode 100644 index 0000000000000000000000000000000000000000..d34afd739fb90f88559dcc86c61509b31933b41b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynkeg.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf.o new file mode 100644 index 0000000000000000000000000000000000000000..9fc0f07c04bedf3738b906ad00df9144734857f7 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_iso.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_iso.o new file mode 100644 index 0000000000000000000000000000000000000000..08583eb45eea6bd1e69d08d3e0bcf427e402cf96 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_iso.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_iso_lf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_iso_lf.o new file mode 100644 index 0000000000000000000000000000000000000000..2cc258989934007a2a7802b8ad4bd9ca279f4534 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_iso_lf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_lap_blp.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_lap_blp.o new file mode 100644 index 0000000000000000000000000000000000000000..6615ac59715f928dc9fe6b5f16059512ac8a65ec Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_lap_blp.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_lap_blp_lf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_lap_blp_lf.o new file mode 100644 index 0000000000000000000000000000000000000000..273d90959a9eb3fbfba77553bd5bb00f314c2bb8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynldf_lap_blp_lf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynspg.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynspg.o new file mode 100644 index 0000000000000000000000000000000000000000..d70046949b1d94db2cbc528f18797682671ec286 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynspg.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynspg_exp.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynspg_exp.o new file mode 100644 index 0000000000000000000000000000000000000000..268f76da1fa186717810cb2c81f1452ad6b1249d Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynspg_exp.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynspg_ts.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynspg_ts.o new file mode 100644 index 0000000000000000000000000000000000000000..4e491c9edf60d4af18b042d7c4fae3d0fa1215a6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynspg_ts.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynvor.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynvor.o new file mode 100644 index 0000000000000000000000000000000000000000..9f20978f5998855c81eea5d06855769b080b6731 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynvor.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynzad.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynzad.o new file mode 100644 index 0000000000000000000000000000000000000000..91014c72a4177eed4400565893f82b4f1e4d4eb0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynzad.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynzdf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynzdf.o new file mode 100644 index 0000000000000000000000000000000000000000..df849b21b736ef04695e50add0f5e0f4f0bb33cd Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/dynzdf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/eosbn2.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/eosbn2.o new file mode 100644 index 0000000000000000000000000000000000000000..dc86e5591da43ee767a723c7643fd9e717cd1b76 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/eosbn2.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/errioipsl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/errioipsl.o new file mode 100644 index 0000000000000000000000000000000000000000..2f0e72c0c03b4afc863d17efa23d78f388f10022 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/errioipsl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/exampl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/exampl.o new file mode 100644 index 0000000000000000000000000000000000000000..897a26189841fee6bb555277fba8b2ae825410b6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/exampl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/fldread.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/fldread.o new file mode 100644 index 0000000000000000000000000000000000000000..0d0f32e1bee7d5d36fb3d421802a53c8613b402c Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/fldread.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/flincom.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/flincom.o new file mode 100644 index 0000000000000000000000000000000000000000..48782aafa67a18891faa03815dc4e921c43d4d65 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/flincom.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/fliocom.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/fliocom.o new file mode 100644 index 0000000000000000000000000000000000000000..223dc931a255f0ae12ce1701dc3f20aedff60741 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/fliocom.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/flo4rk.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/flo4rk.o new file mode 100644 index 0000000000000000000000000000000000000000..bee4aef1bbe434074b1684ad69dc2d4fbb4f88fc Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/flo4rk.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/flo_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/flo_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..e33cc51aeb9139b2c7f8b8cc544d3a18ec8aa68a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/flo_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/floats.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/floats.o new file mode 100644 index 0000000000000000000000000000000000000000..56e561525ac3865dcdd2fad91e754a773a552fdd Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/floats.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/floblk.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/floblk.o new file mode 100644 index 0000000000000000000000000000000000000000..287f34aa237d208d8191e885a250e371d438ec89 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/floblk.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/flodom.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/flodom.o new file mode 100644 index 0000000000000000000000000000000000000000..4d714062877c3f0cfcdb681f6f662fa414e8474b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/flodom.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/florst.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/florst.o new file mode 100644 index 0000000000000000000000000000000000000000..32479db4465ee4b4cfca2d536151aa06f773ad1b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/florst.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/flowri.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/flowri.o new file mode 100644 index 0000000000000000000000000000000000000000..23a90332c51049894c26f8c0c53f0ff6f73abde1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/flowri.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/geo2ocean.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/geo2ocean.o new file mode 100644 index 0000000000000000000000000000000000000000..49d658b934a4053db3ff32f71815b2d0d84c173a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/geo2ocean.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/getincom.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/getincom.o new file mode 100644 index 0000000000000000000000000000000000000000..0fc683e760dda4ceec2cb5ce799f8c452be266e3 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/getincom.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/halo_mng.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/halo_mng.o new file mode 100644 index 0000000000000000000000000000000000000000..5f667c1121ddebb9f8446834f19ccf4058c52de9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/halo_mng.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/histcom.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/histcom.o new file mode 100644 index 0000000000000000000000000000000000000000..196a194406e523438ee6e55617de79cfafcdfbd2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/histcom.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/icb_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icb_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..ad223954dc999214c37130bb19e4b52f567add92 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icb_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbclv.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbclv.o new file mode 100644 index 0000000000000000000000000000000000000000..310dd501f873663b9869166c0ffc786a3c178e09 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbclv.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbdia.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbdia.o new file mode 100644 index 0000000000000000000000000000000000000000..63fcbd24e2a1142ea736b95606c7c448e1e628f1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbdia.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbdyn.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbdyn.o new file mode 100644 index 0000000000000000000000000000000000000000..d455ae10985fbc8f76e18504738e9ab5d2a02fd9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbdyn.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbini.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbini.o new file mode 100644 index 0000000000000000000000000000000000000000..d79a1839825aee3bf01bd84e0efb5a0ebd4d350b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbini.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/icblbc.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icblbc.o new file mode 100644 index 0000000000000000000000000000000000000000..fea2839a4f2739b8ad812a176b5f8f7723c19b6f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icblbc.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbrst.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbrst.o new file mode 100644 index 0000000000000000000000000000000000000000..88fa568dddab2b81ba2ecbe28957ed22f41f6842 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbrst.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbstp.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbstp.o new file mode 100644 index 0000000000000000000000000000000000000000..022ee298de9e812ac76e9d7837fe1cd9f9542e4a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbstp.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbthm.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbthm.o new file mode 100644 index 0000000000000000000000000000000000000000..827159ccad2964dda48edf7a5d1c3dffbf1f2d39 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbthm.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbtrj.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbtrj.o new file mode 100644 index 0000000000000000000000000000000000000000..f1518fe2cb49205b350ce04b8d6cbfec63ec93c5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbtrj.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbutl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbutl.o new file mode 100644 index 0000000000000000000000000000000000000000..688c0205109bec5f970578342e9db594fac38064 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/icbutl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/in_out_manager.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/in_out_manager.o new file mode 100644 index 0000000000000000000000000000000000000000..2aaad2c3b9afd456514a93d06915658b31797102 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/in_out_manager.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/ioipsl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ioipsl.o new file mode 100644 index 0000000000000000000000000000000000000000..8013842271d20cf0df85c23ad7d720ebefc86230 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ioipsl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/iom.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/iom.o new file mode 100644 index 0000000000000000000000000000000000000000..e146891423c50f1f19815bc18ddbf158a71dbd19 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/iom.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/iom_def.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/iom_def.o new file mode 100644 index 0000000000000000000000000000000000000000..d904f58b77b7845630a6629ec5423e371cc42f51 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/iom_def.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/iom_nf90.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/iom_nf90.o new file mode 100644 index 0000000000000000000000000000000000000000..c44b4f9fda1fdc32bab0544abe541d46ad01b3b4 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/iom_nf90.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isf_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isf_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..2ee12665fd71cbede8392d05bb6f39bb1e101bae Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isf_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcav.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcav.o new file mode 100644 index 0000000000000000000000000000000000000000..2414257eb792fd89bd31a0b51518de3d2daa40e1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcav.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcavgam.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcavgam.o new file mode 100644 index 0000000000000000000000000000000000000000..a993281d8cf7fb0721876eb02709125361945155 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcavgam.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcavmlt.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcavmlt.o new file mode 100644 index 0000000000000000000000000000000000000000..e6bb1fae33f13df7aa87cf00e45f7b4c02b8f0df Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcavmlt.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcpl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcpl.o new file mode 100644 index 0000000000000000000000000000000000000000..10821fff1d2d2b190b0d7fbeb9f043b6a06376f0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfcpl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfdiags.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfdiags.o new file mode 100644 index 0000000000000000000000000000000000000000..a51e59f7f7c45689923d642e82368ffa9bff5ff8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfdiags.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfdynatf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfdynatf.o new file mode 100644 index 0000000000000000000000000000000000000000..1a89cee0dd30452979f7aea69ea925686be2e9d0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfdynatf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfhdiv.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfhdiv.o new file mode 100644 index 0000000000000000000000000000000000000000..285afb1d1676d08a6a98f89ed73430172bf5d7d1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfhdiv.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfload.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfload.o new file mode 100644 index 0000000000000000000000000000000000000000..f13a737a86feece237a628e446645cc714f9e609 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfload.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfpar.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfpar.o new file mode 100644 index 0000000000000000000000000000000000000000..f61a9926827c01dbe06c82d6885268454720f50b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfpar.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfparmlt.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfparmlt.o new file mode 100644 index 0000000000000000000000000000000000000000..7546027af16101de5e6ef361889d025c50d40f12 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfparmlt.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfrst.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfrst.o new file mode 100644 index 0000000000000000000000000000000000000000..7490b9bf654109a2e4985c58c8c293eeecca7a76 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfrst.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfstp.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfstp.o new file mode 100644 index 0000000000000000000000000000000000000000..77099e97e703a46a43a030165e4793c6d202a012 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfstp.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isftbl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isftbl.o new file mode 100644 index 0000000000000000000000000000000000000000..30f50fe7c32f4fe45d510c20c37f120301ddb4d1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isftbl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfutils.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfutils.o new file mode 100644 index 0000000000000000000000000000000000000000..8b8aae22c7f16b8cea87c1ff62d0fbb8cf495d28 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/isfutils.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/istate.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/istate.o new file mode 100644 index 0000000000000000000000000000000000000000..7100f93807f92fa04fb3927978dc10195d741486 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/istate.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/julian.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/julian.o new file mode 100644 index 0000000000000000000000000000000000000000..2ba2875d9f317f1d13276142d32960c3169e9467 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/julian.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/lbclnk.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/lbclnk.o new file mode 100644 index 0000000000000000000000000000000000000000..a11f3c1fe22462aa2197094a82e33de2f0b60d10 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/lbclnk.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/lbcnfd.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/lbcnfd.o new file mode 100644 index 0000000000000000000000000000000000000000..f7c247701e1e3d6918260f839242fdd9c99bd2a5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/lbcnfd.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldfc1d_c2d.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldfc1d_c2d.o new file mode 100644 index 0000000000000000000000000000000000000000..55bb853ebb93161c88b1171f1c16a6def89d828e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldfc1d_c2d.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldfdyn.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldfdyn.o new file mode 100644 index 0000000000000000000000000000000000000000..779866338253b66b1885b6746cb11d3146a3e9ac Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldfdyn.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldfslp.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldfslp.o new file mode 100644 index 0000000000000000000000000000000000000000..c0829eda8042ecbfaab7989a6f40fae0588a92e2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldfslp.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldftra.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldftra.o new file mode 100644 index 0000000000000000000000000000000000000000..8a5df6865f1db2ebf4aedc9124b0e6d2f4fdcdf8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ldftra.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/lib_cray.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/lib_cray.o new file mode 100644 index 0000000000000000000000000000000000000000..0a885d20d1df00c93a53348e95a22e986aeba096 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/lib_cray.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/lib_fortran.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/lib_fortran.o new file mode 100644 index 0000000000000000000000000000000000000000..11f9a3ba61ad0dc7b7d02de6da05ae370a17de08 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/lib_fortran.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/lib_mpp.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/lib_mpp.o new file mode 100644 index 0000000000000000000000000000000000000000..855e20a63858d1d595d5044bb2ef595aa4ebb875 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/lib_mpp.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/mathelp.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/mathelp.o new file mode 100644 index 0000000000000000000000000000000000000000..7cd298a369925ac04dcdb0fa97d388a303bc7363 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/mathelp.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/mpp_map.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/mpp_map.o new file mode 100644 index 0000000000000000000000000000000000000000..225cb58d83d730ced07eca10c9114fecdc6c103c Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/mpp_map.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/mppini.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/mppini.o new file mode 100644 index 0000000000000000000000000000000000000000..0a822e5edd96c248fe78ee3b8ce93757401dcdc1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/mppini.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/nc4interface.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/nc4interface.o new file mode 100644 index 0000000000000000000000000000000000000000..a88e42c4b22c5d5dabe0e1d477543b3717a04b07 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/nc4interface.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/nemo.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/nemo.o new file mode 100644 index 0000000000000000000000000000000000000000..e9684ff6c1162840d3c4b481783bf4de3b6e3c57 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/nemo.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/nemogcm.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/nemogcm.o new file mode 100644 index 0000000000000000000000000000000000000000..63434ecbc933600ed253cb34d439fd0acf5cf171 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/nemogcm.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_averg_h2d.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_averg_h2d.o new file mode 100644 index 0000000000000000000000000000000000000000..457d898bb1d322dd7c148137e799717e75cff858 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_averg_h2d.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_const.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_const.o new file mode 100644 index 0000000000000000000000000000000000000000..194b63bc7529042c6a93520b7152bf8f4b07caab Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_const.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_conv.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_conv.o new file mode 100644 index 0000000000000000000000000000000000000000..aa50310dd4b6a44a8f5b7e2b67a60637f5d8deba Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_conv.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_fbm.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_fbm.o new file mode 100644 index 0000000000000000000000000000000000000000..925fac6a0ab5adef7c008a216980eb515fb0a1c2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_fbm.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_grid.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_grid.o new file mode 100644 index 0000000000000000000000000000000000000000..a96d44b3f8ac2c4dfb0dae8d51d2ed038a4d3721 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_grid.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_inter_h2d.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_inter_h2d.o new file mode 100644 index 0000000000000000000000000000000000000000..20b079a32391ef83412e7b7734ebda65afb64663 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_inter_h2d.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_inter_sup.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_inter_sup.o new file mode 100644 index 0000000000000000000000000000000000000000..f32674eba5367f030f202539c517ef5bd753e5d2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_inter_sup.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_inter_z1d.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_inter_z1d.o new file mode 100644 index 0000000000000000000000000000000000000000..0e70e0372e3d2777188346e7ae16960f4eff5884 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_inter_z1d.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_mpp.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_mpp.o new file mode 100644 index 0000000000000000000000000000000000000000..756e36c39f2b834c0ad3a28ca199c836df87c272 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_mpp.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_oper.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_oper.o new file mode 100644 index 0000000000000000000000000000000000000000..a0c7567fc4cf3fa659fb20a37ce09e6569de7a02 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_oper.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_prep.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_prep.o new file mode 100644 index 0000000000000000000000000000000000000000..915fff5ab6ce2acae6989035996513896f18f7ed Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_prep.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_profiles.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_profiles.o new file mode 100644 index 0000000000000000000000000000000000000000..a5dace33f2c6ad4d8c9b5bc84d37e74c993130b6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_profiles.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_profiles_def.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_profiles_def.o new file mode 100644 index 0000000000000000000000000000000000000000..3be9a65995b821bd97d1cb14ced117c494d3531d Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_profiles_def.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_read_altbias.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_read_altbias.o new file mode 100644 index 0000000000000000000000000000000000000000..87c09c7b03fa182aca9d5b300f7e5f51df2a8cc8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_read_altbias.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_read_prof.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_read_prof.o new file mode 100644 index 0000000000000000000000000000000000000000..13ea449774e8019a93554ad4dd5fbe278acb2912 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_read_prof.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_read_surf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_read_surf.o new file mode 100644 index 0000000000000000000000000000000000000000..4a6899679d099ceb617933765ecb0ff825c7fd40 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_read_surf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_readmdt.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_readmdt.o new file mode 100644 index 0000000000000000000000000000000000000000..620f2c390f1f3ab0bf7b9d2c9737ba419bc771d3 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_readmdt.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_rot_vel.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_rot_vel.o new file mode 100644 index 0000000000000000000000000000000000000000..cfee4bfb79c382abac4a5cfa04d959d179d177be Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_rot_vel.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_sort.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_sort.o new file mode 100644 index 0000000000000000000000000000000000000000..f867bfa8378a17a26b5df829035180b967734bb9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_sort.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_sstbias.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_sstbias.o new file mode 100644 index 0000000000000000000000000000000000000000..349eb85ff91fb55714e80f532d6ee6f4b857b0a0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_sstbias.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_surf_def.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_surf_def.o new file mode 100644 index 0000000000000000000000000000000000000000..c895f4226af25d6a1f8c168d296bcc1d0e879419 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_surf_def.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_types.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_types.o new file mode 100644 index 0000000000000000000000000000000000000000..0255138b901ad5fc7317e4215f844349602ba8f1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_types.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_utils.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_utils.o new file mode 100644 index 0000000000000000000000000000000000000000..2b667854ec7ebb5b057886d12441a8a77d503ff1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_utils.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_write.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_write.o new file mode 100644 index 0000000000000000000000000000000000000000..02fad8272dbcd014173249ff0395a4b1d4293e53 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/obs_write.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/oce.o new file mode 100644 index 0000000000000000000000000000000000000000..59aa678d0e85160ad06641376ec76b86a76de29a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/ocealb.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ocealb.o new file mode 100644 index 0000000000000000000000000000000000000000..228536f62996a9cf9c2d08ca7f485a78199bdacc Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ocealb.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/par_kind.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/par_kind.o new file mode 100644 index 0000000000000000000000000000000000000000..7d3e593886f3adf4e849ff7440077fab7d24c020 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/par_kind.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/par_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/par_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..a31888eb2c4ed2d5a30a974346e046f5b2af8855 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/par_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/phycst.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/phycst.o new file mode 100644 index 0000000000000000000000000000000000000000..d2edd776186b966b124ddfa08cbd036bd1179ee1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/phycst.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/ppr_1d.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ppr_1d.o new file mode 100644 index 0000000000000000000000000000000000000000..3065f15a67b6d23f3f11258eacbc95106485c94f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/ppr_1d.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/prtctl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/prtctl.o new file mode 100644 index 0000000000000000000000000000000000000000..68f8d7686c51dab8207a3fe955ace2b2e780e7ec Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/prtctl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/restart.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/restart.o new file mode 100644 index 0000000000000000000000000000000000000000..6aecbacb685784d2386944100dfa623132cd5644 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/restart.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/restcom.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/restcom.o new file mode 100644 index 0000000000000000000000000000000000000000..8a9549b70d36b9f919a9345f4b46cf0e110280dd Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/restcom.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbc_ice.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbc_ice.o new file mode 100644 index 0000000000000000000000000000000000000000..4df957ed4db83ef44e05bdc6d12de6e5e28ed7af Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbc_ice.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbc_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbc_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..7161686f372ac046fd8cb015d65710ec799dafe7 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbc_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbc_phy.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbc_phy.o new file mode 100644 index 0000000000000000000000000000000000000000..acf6242826fbc8236bef2f51109e11e8e1cca1e1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbc_phy.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcabl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcabl.o new file mode 100644 index 0000000000000000000000000000000000000000..3f53e3f2c4efce57d7439fd6cf3b3c0fd546fc45 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcabl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcapr.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcapr.o new file mode 100644 index 0000000000000000000000000000000000000000..f90a166ce75168706f8c92bfdb45f6bcd2f84b71 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcapr.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk.o new file mode 100644 index 0000000000000000000000000000000000000000..67b25df13399253a28e186cb2d744566a92cef23 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_andreas.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_andreas.o new file mode 100644 index 0000000000000000000000000000000000000000..e38329d22cca6f516cbc852ad5f082adb3190ebf Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_andreas.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_coare3p0.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_coare3p0.o new file mode 100644 index 0000000000000000000000000000000000000000..a7113ae2bf6c47dc59449fe7aeca4924f937013b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_coare3p0.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_coare3p6.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_coare3p6.o new file mode 100644 index 0000000000000000000000000000000000000000..e6f621e62a59be28cf7b9807f26cce163b0e26dc Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_coare3p6.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ecmwf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ecmwf.o new file mode 100644 index 0000000000000000000000000000000000000000..e037b6065357e4cc13ad60ea2f312967bd1a67fa Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ecmwf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_an05.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_an05.o new file mode 100644 index 0000000000000000000000000000000000000000..88f8f0c2f436f3a4304f6ae064d215b0d7142afb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_an05.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_cdn.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_cdn.o new file mode 100644 index 0000000000000000000000000000000000000000..0262553f03b7e47b376b2bb5606a473c9efca49f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_cdn.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_lg15.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_lg15.o new file mode 100644 index 0000000000000000000000000000000000000000..ee2878f81e9e47ee30798b825e864d17e3f6f495 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_lg15.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_lu12.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_lu12.o new file mode 100644 index 0000000000000000000000000000000000000000..f8bafa103a6dc0443d3ad152d4860b7060e91b72 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ice_lu12.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ncar.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ncar.o new file mode 100644 index 0000000000000000000000000000000000000000..d41fdf7b289bc05a1e35513ef5946f61c53bc11a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_algo_ncar.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_skin_coare.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_skin_coare.o new file mode 100644 index 0000000000000000000000000000000000000000..7aa661568aa9fe84e0eeb2474e84dfbc415dcd0e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_skin_coare.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_skin_ecmwf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_skin_ecmwf.o new file mode 100644 index 0000000000000000000000000000000000000000..47dd3c3b5baaf0b74d08db82da03abb6ace58334 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcblk_skin_ecmwf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcclo.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcclo.o new file mode 100644 index 0000000000000000000000000000000000000000..da9f868782bbaabab4a43dd653a8bc46b99c2d68 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcclo.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbccpl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbccpl.o new file mode 100644 index 0000000000000000000000000000000000000000..8cd93076dba992a03cb42ef7cc69d9312f2bac08 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbccpl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcdcy.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcdcy.o new file mode 100644 index 0000000000000000000000000000000000000000..05f9b96a1223685160cd2ac6625942cf040764d9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcdcy.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcflx.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcflx.o new file mode 100644 index 0000000000000000000000000000000000000000..7654f3b10586c74c7d67859c860b8ac09f2c48b9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcflx.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcfwb.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcfwb.o new file mode 100644 index 0000000000000000000000000000000000000000..4ea931043746e7e2a393ea4757b3680b6d5962e5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcfwb.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcice_cice.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcice_cice.o new file mode 100644 index 0000000000000000000000000000000000000000..1baa1643d686aa96f999a6c624afa4185f5bb8cb Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcice_cice.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcice_if.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcice_if.o new file mode 100644 index 0000000000000000000000000000000000000000..7eba287df3a1a881433019a561901c5559bba959 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcice_if.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcmod.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcmod.o new file mode 100644 index 0000000000000000000000000000000000000000..873139fe8d2becbe9c0cbee009edb7394057e44a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcmod.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcrnf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcrnf.o new file mode 100644 index 0000000000000000000000000000000000000000..0c3de47643651a60893277b784b00055fd376b42 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcrnf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcssm.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcssm.o new file mode 100644 index 0000000000000000000000000000000000000000..e634a792372f1b4203adefed83623ae97ea23938 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcssm.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcssr.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcssr.o new file mode 100644 index 0000000000000000000000000000000000000000..4c7072b62840636967504668c4539f1e756221e3 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcssr.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcwave.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcwave.o new file mode 100644 index 0000000000000000000000000000000000000000..d573fc3fce023baa8624b8667d97ffe43536ddb2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sbcwave.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/solfrac_mod.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/solfrac_mod.o new file mode 100644 index 0000000000000000000000000000000000000000..28ee3f9d5698d505c7f6da8d4459c7122a938d75 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/solfrac_mod.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/sshwzv.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sshwzv.o new file mode 100644 index 0000000000000000000000000000000000000000..be2f9b8542ae582f0fd5a54c2cc50602651a12e8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/sshwzv.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/step.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/step.o new file mode 100644 index 0000000000000000000000000000000000000000..025e2822a0fbf86d535731b895010aea76b610e4 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/step.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/step_diu.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/step_diu.o new file mode 100644 index 0000000000000000000000000000000000000000..2dd6695c41fa45cac0f44211217e5fbbbf128a03 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/step_diu.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/step_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/step_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..8874d2d54d21bee70053ac16cfe7bd628e556368 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/step_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/stopar.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/stopar.o new file mode 100644 index 0000000000000000000000000000000000000000..1f664b70e065018d9d5c3fbceeea971b2b69faa8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/stopar.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/stopts.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/stopts.o new file mode 100644 index 0000000000000000000000000000000000000000..db8012fb6443eaed1dbdd128dd5e0891551ad272 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/stopts.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/storng.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/storng.o new file mode 100644 index 0000000000000000000000000000000000000000..303040275db6547ab4cb0ea60e000d998fc76b12 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/storng.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/stpctl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/stpctl.o new file mode 100644 index 0000000000000000000000000000000000000000..89cb88d422d8fb3a50bc2f3e4da7c10144d133e2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/stpctl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/stpmlf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/stpmlf.o new file mode 100644 index 0000000000000000000000000000000000000000..b0c376dd2b5cf73fc68e3b0aea26e14caae0cf28 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/stpmlf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/stringop.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/stringop.o new file mode 100644 index 0000000000000000000000000000000000000000..dea31e25609bf51d6926ea0523eb55434523e1d5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/stringop.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/tide_mod.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/tide_mod.o new file mode 100644 index 0000000000000000000000000000000000000000..29b75c2c9cf495cfb5ec941afedd284a0a6e4885 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/tide_mod.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/timing.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/timing.o new file mode 100644 index 0000000000000000000000000000000000000000..73e2ebceb89dae4454178a8753dbd0d43631e550 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/timing.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv.o new file mode 100644 index 0000000000000000000000000000000000000000..8de84fbb9b694076df0bf033fcc1f8244ba47a00 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_cen.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_cen.o new file mode 100644 index 0000000000000000000000000000000000000000..c412d61f32a42e7e5ea0fc178dd39b21ed31f2c2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_cen.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_cen_lf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_cen_lf.o new file mode 100644 index 0000000000000000000000000000000000000000..ca6405099fecccbf359c75d3a834ead8b425c4f8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_cen_lf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_fct.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_fct.o new file mode 100644 index 0000000000000000000000000000000000000000..d7d1502bf628eb2de9a9b82b9ffd4eea3a523c7b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_fct.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_mus.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_mus.o new file mode 100644 index 0000000000000000000000000000000000000000..4034952655bdb9dee18ac4f68be8fe9e6940f890 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_mus.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_qck.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_qck.o new file mode 100644 index 0000000000000000000000000000000000000000..b6f828e94579550e17e3d0893e977816117e2876 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_qck.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_qck_lf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_qck_lf.o new file mode 100644 index 0000000000000000000000000000000000000000..5429d3fcbabf7ad2d794b58315914f87ac2d9f83 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_qck_lf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_ubs.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_ubs.o new file mode 100644 index 0000000000000000000000000000000000000000..353f15bc1899eb13cb218b4ca86fec8530b2a9aa Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_ubs.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_ubs_lf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_ubs_lf.o new file mode 100644 index 0000000000000000000000000000000000000000..637a6a36477ce3b1bdbfb5f12b63fecf49c79f9a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traadv_ubs_lf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traatf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traatf.o new file mode 100644 index 0000000000000000000000000000000000000000..5bf2acc1bbceeb10a34def39182aafd14dada4be Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traatf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traatf_qco.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traatf_qco.o new file mode 100644 index 0000000000000000000000000000000000000000..36e5698f23b6f43ce5e58480abc732af8d486dd5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traatf_qco.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trabbc.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trabbc.o new file mode 100644 index 0000000000000000000000000000000000000000..488b6f0a91a1daa9cc5769d38eebd38c09881ada Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trabbc.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trabbl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trabbl.o new file mode 100644 index 0000000000000000000000000000000000000000..c983bb2c41b0634587d859a3c90ea17771ab94e1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trabbl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/tradmp.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/tradmp.o new file mode 100644 index 0000000000000000000000000000000000000000..98bdf97b12323be47b1469ac71f28fb13d867aad Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/tradmp.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traisf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traisf.o new file mode 100644 index 0000000000000000000000000000000000000000..7dcb857bd5047c4fa79827c93b976c0710d1ef24 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traisf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf.o new file mode 100644 index 0000000000000000000000000000000000000000..40088da862ae5355d453d583c765435cc27695ac Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf_iso.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf_iso.o new file mode 100644 index 0000000000000000000000000000000000000000..9fe9280a959def620e816ebab27188e37c4fb245 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf_iso.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf_lap_blp.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf_lap_blp.o new file mode 100644 index 0000000000000000000000000000000000000000..6b6322d67c52e9545656344bb39f54bc4109ce17 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf_lap_blp.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf_triad.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf_triad.o new file mode 100644 index 0000000000000000000000000000000000000000..732748c7572bf34a53030369e06af7da7dcd07db Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traldf_triad.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/tramle.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/tramle.o new file mode 100644 index 0000000000000000000000000000000000000000..85c92b40ab619e857db74b804eee809f25a276c9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/tramle.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/tranpc.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/tranpc.o new file mode 100644 index 0000000000000000000000000000000000000000..8fdb58b2e3cfef389b08a4d9e261dd6631ecbfc2 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/tranpc.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/traqsr.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traqsr.o new file mode 100644 index 0000000000000000000000000000000000000000..14ab948f9fd19a7c8d000bad44ddee57c006eb96 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/traqsr.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trasbc.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trasbc.o new file mode 100644 index 0000000000000000000000000000000000000000..29bd2ecf06b5ba236d848168d0080d521522470c Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trasbc.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trazdf.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trazdf.o new file mode 100644 index 0000000000000000000000000000000000000000..f813228045dc08620653b4d0997cb414bf5c31ea Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trazdf.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trc_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trc_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..2313012894813805bbf7034d61208158b59e82a5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trc_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trd_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trd_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..ea7faf0bd9b43eff8944b95f3bbb10c650e2cf56 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trd_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trddyn.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trddyn.o new file mode 100644 index 0000000000000000000000000000000000000000..ed3fd732f37ed63d2cb8eabef53ff73e13a05781 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trddyn.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdglo.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdglo.o new file mode 100644 index 0000000000000000000000000000000000000000..01130ebeff67181bea680580216a78e75ec2254f Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdglo.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdini.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdini.o new file mode 100644 index 0000000000000000000000000000000000000000..1fa39bd9583f8be0db88bfb1db68fa289a7ddf1a Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdini.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdken.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdken.o new file mode 100644 index 0000000000000000000000000000000000000000..b38ab8e1f34273bd31f6ab02b736c5abc7ca2438 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdken.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdmxl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdmxl.o new file mode 100644 index 0000000000000000000000000000000000000000..91f6724875e70cb25df024d76aa55f15bd9cd2a1 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdmxl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdmxl_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdmxl_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..9b5ab160acf9151840420ba7200bd043f487c623 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdmxl_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdmxl_rst.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdmxl_rst.o new file mode 100644 index 0000000000000000000000000000000000000000..7f67423fd206fc3fc0e8f95c7487fcdbf083ed2b Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdmxl_rst.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdpen.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdpen.o new file mode 100644 index 0000000000000000000000000000000000000000..7a5755d1fb0113eb013d4174bb59bd5bc72f9c19 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdpen.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdtra.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdtra.o new file mode 100644 index 0000000000000000000000000000000000000000..51400820fa9cccf7c3b25072964e91e7d7b97408 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdtra.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdtrc.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdtrc.o new file mode 100644 index 0000000000000000000000000000000000000000..e18ef2d9978bcae2a2a423a067ac3db4aa4375fa Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdtrc.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdvor.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdvor.o new file mode 100644 index 0000000000000000000000000000000000000000..2565d8849984139143bc9dca8d8c5ddde42641f0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdvor.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdvor_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdvor_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..e816908889b3c368b49c4789458f0eeebb000c0d Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/trdvor_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_fmask.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_fmask.o new file mode 100644 index 0000000000000000000000000000000000000000..97d34a46e85ec55be10c9833c826e4524169df12 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_fmask.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_hgr.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_hgr.o new file mode 100644 index 0000000000000000000000000000000000000000..2ac3d2d7c232a500e3ad32bf03a02f614d76a355 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_hgr.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_istate.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_istate.o new file mode 100644 index 0000000000000000000000000000000000000000..f8e7bdb06b93a5c288308f6a20590d12d2cb2d95 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_istate.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_nam.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_nam.o new file mode 100644 index 0000000000000000000000000000000000000000..c956d29b7ca39487092984582a3d4b607c3bc735 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_nam.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_sbc.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_sbc.o new file mode 100644 index 0000000000000000000000000000000000000000..a37afcd865d5d385612331e0de6f7973e21b30b8 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_sbc.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_zgr.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_zgr.o new file mode 100644 index 0000000000000000000000000000000000000000..92cc97ea930714a50647de3e9b9bb58afdc92ae5 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/usrdef_zgr.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/wet_dry.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/wet_dry.o new file mode 100644 index 0000000000000000000000000000000000000000..4b7136ead5dc1432768147a9a6d754d3b07701a0 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/wet_dry.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdf_oce.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdf_oce.o new file mode 100644 index 0000000000000000000000000000000000000000..8ee65d2ae849c199a1a40767814f4d6c97296c36 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdf_oce.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfddm.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfddm.o new file mode 100644 index 0000000000000000000000000000000000000000..b665fc1580753f7b29eb5902ddc0201115905f73 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfddm.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfdrg.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfdrg.o new file mode 100644 index 0000000000000000000000000000000000000000..e3671bfc3545650ac38b4576f2e7b55c1343d751 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfdrg.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfevd.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfevd.o new file mode 100644 index 0000000000000000000000000000000000000000..44b8cce20d4b73e6c1e7aecf38f79260fee64518 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfevd.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfgls.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfgls.o new file mode 100644 index 0000000000000000000000000000000000000000..14a6a0319de8d886361c16f5059729507b2ae31e Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfgls.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfiwm.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfiwm.o new file mode 100644 index 0000000000000000000000000000000000000000..18ca3423084c25ee22ec3842ed97e7169a2fd05c Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfiwm.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfmfc.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfmfc.o new file mode 100644 index 0000000000000000000000000000000000000000..9cd7e1c4686f9fbf0af3dfb4ff5fe8a3b7250fa3 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfmfc.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfmxl.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfmxl.o new file mode 100644 index 0000000000000000000000000000000000000000..221caba97ef652b6f36126a702098eb6a40aa458 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfmxl.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfosm.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfosm.o new file mode 100644 index 0000000000000000000000000000000000000000..71a528830438046f15ef1675f896784f018ef244 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfosm.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfphy.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfphy.o new file mode 100644 index 0000000000000000000000000000000000000000..0b213fab58670da0f368c22cbdbe273fbd92b165 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfphy.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfric.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfric.o new file mode 100644 index 0000000000000000000000000000000000000000..62e720d98507d0d0d37b3acde123d8b93235b4f9 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfric.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfsh2.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfsh2.o new file mode 100644 index 0000000000000000000000000000000000000000..84183e0744ea8830912d5d23d83c4b8846399bf6 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfsh2.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfswm.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfswm.o new file mode 100644 index 0000000000000000000000000000000000000000..d8a9a1f0c9eb634a78ca4f096c045cfdacea7168 Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdfswm.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdftke.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdftke.o new file mode 100644 index 0000000000000000000000000000000000000000..3df5530b4a937f11c64074c1be116bf58b07347c Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zdftke.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/obj/zpshde.o b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zpshde.o new file mode 100644 index 0000000000000000000000000000000000000000..7acfe8b57b8ff893d43962297945653623b235ed Binary files /dev/null and b/cfgs/ORCA2_OCE_MIXED/BLD/obj/zpshde.o differ diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/ioipsl/nc4interface.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/ioipsl/nc4interface.f90 new file mode 100644 index 0000000000000000000000000000000000000000..318f9c6a73b423d5277545dfc4db45f13a332297 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/ioipsl/nc4interface.f90 @@ -0,0 +1,67 @@ + + + + + + + + + + + + + +MODULE nc4interface +!- +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- + !!-------------------------------------------------------------------- + !! NOT 'key_netcdf4' Defines dummy routines for netcdf4 + !! calls when compiling without netcdf4 libraries + !!-------------------------------------------------------------------- + !- netcdf4 chunking control structure + !- (optional on histbeg and histend calls) +!$AGRIF_DO_NOT_TREAT + TYPE, PUBLIC :: snc4_ctl + SEQUENCE + INTEGER :: ni + INTEGER :: nj + INTEGER :: nk + LOGICAL :: luse + END TYPE snc4_ctl +!$AGRIF_END_DO_NOT_TREAT + +CONTAINS +!=== + SUBROUTINE GET_NF90_SYMBOL(sym_name, ivalue) + CHARACTER(len=*), INTENT(in) :: sym_name + INTEGER, INTENT(out) :: ivalue + ivalue = -999 + END SUBROUTINE GET_NF90_SYMBOL + INTEGER FUNCTION SET_NF90_DEF_VAR_CHUNKING(idum1, idum2, idum3, iarr1) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE NF90_DEF_VAR_CHUNKING *** + !! + !! ** Purpose : Dummy NetCDF4 routine to enable compiling with NetCDF3 libraries + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: idum1, idum2, idum3 + INTEGER, DIMENSION(4), INTENT(in) :: iarr1 + WRITE(*,*) 'Warning: Attempt to chunk output variable without NetCDF4 support' + SET_NF90_DEF_VAR_CHUNKING = -1 + END FUNCTION SET_NF90_DEF_VAR_CHUNKING + + INTEGER FUNCTION SET_NF90_DEF_VAR_DEFLATE(idum1, idum2, idum3, idum4, idum5) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE NF90_DEF_VAR_DEFLATE *** + !! + !! ** Purpose : Dummy NetCDF4 routine to enable compiling with NetCDF3 libraries + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: idum1, idum2, idum3, idum4, idum5 + WRITE(*,*) 'Warning: Attempt to compress output variable without NetCDF4 support' + SET_NF90_DEF_VAR_DEFLATE = -1 + END FUNCTION SET_NF90_DEF_VAR_DEFLATE + +!------------------ +END MODULE nc4interface diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/abl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/abl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..eb73c6fcac88be13008dca479458cc3bbf4b4084 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/abl.f90 @@ -0,0 +1,44 @@ + + + + + + + + + + + + + +MODULE abl + !!====================================================================== + !! *** MODULE abl *** + !! Abl : ABL dynamics and active tracers defined in memory + !!====================================================================== + USE par_kind ! abl parameters + + IMPLICIT NONE + PRIVATE + !! -------------------------- ! + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: u_abl !: i-horizontal velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: v_abl !: j-horizontal velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: tq_abl !: 4D T-q fields [Kelvin,kg/kg] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avm_abl !: turbulent viscosity [m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_abl !: turbulent diffusivity [m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: mxl_abl !: mixing length [m] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: tke_abl !: turbulent kinetic energy [m2/s2] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: fft_abl !: Coriolis parameter [1/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pblh !: PBL height [m] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: rest_eq + ! + INTEGER , PUBLIC :: nt_n, nt_a !: now / after indices (equal 1 or 2) + ! + !!---------------------------------------------------------------------- + !! NEMO/OPA 4.0 , NEMO Consortium (2011) + !! $Id: abl.F90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +CONTAINS + +END MODULE abl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/asmbkg.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/asmbkg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..67b773c20f83b458c1b3d2980a4859c2b675bdae --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/asmbkg.f90 @@ -0,0 +1,164 @@ + + + + + + + + + + + + + +MODULE asmbkg + !!====================================================================== + !! *** MODULE asmtrj -> asmbkg *** + !! Assimilation trajectory interface: Write to file the background state and the model state trajectory + !!====================================================================== + !! History : ! 2007-03 (M. Martin) Met. Office version + !! ! 2007-04 (A. Weaver) asm_trj_wri, original code + !! ! 2007-03 (K. Mogensen) Adapt to NEMOVAR and use IOM instead of IOIPSL + !! ! 2007-04 (A. Weaver) Name change (formally asmbkg.F90). Distinguish + !! background states in Jb term and at analysis time. + !! Include state trajectory routine (currently empty) + !! ! 2007-07 (A. Weaver) Add tke_rst and flt_rst for case nitbkg=0 + !! ! 2009-03 (F. Vigilant) Add hmlp (zdfmxl) for no tracer nmldp=2 + !! ! 2009-06 (F. Vigilant) asm_trj_wri: special case when kt=nit000-1 + !! ! 2009-07 (F. Vigilant) asm_trj_wri: add computation of eiv at restart + !! ! 2010-01 (A. Vidard) split asm_trj_wri into tam_trj_wri and asm_bkg_wri + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! asm_bkg_wri : Write out the background state + !! asm_trj_wri : Write out the model state trajectory (used with 4D-Var) + !!---------------------------------------------------------------------- + USE oce ! Dynamics and active tracers defined in memory + USE sbc_oce ! Ocean surface boundary conditions + USE zdf_oce ! Vertical mixing variables + USE zdfddm ! Double diffusion mixing parameterization + USE ldftra ! Lateral diffusion: eddy diffusivity coefficients + USE ldfslp ! Lateral diffusion: slopes of neutral surfaces + USE tradmp ! Tracer damping + USE zdftke ! TKE vertical physics + USE eosbn2 ! Equation of state (eos_bn2 routine) + USE zdfmxl ! Mixed layer depth + USE dom_oce , ONLY : ndastp, l_istiled + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE asmpar ! Parameters for the assmilation interface + USE zdfmxl ! mixed layer depth + + IMPLICIT NONE + PRIVATE + + PUBLIC asm_bkg_wri !: Write out the background state + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: asmbkg.F90 15417 2021-10-20 14:16:29Z lovato $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE asm_bkg_wri( kt, Kmm ) + !!----------------------------------------------------------------------- + !! *** ROUTINE asm_bkg_wri *** + !! + !! ** Purpose : Write to file the background state for later use in the + !! inner loop of data assimilation or for direct initialization + !! in the outer loop. + !! + !! ** Method : Write out the background state for use in the Jb term + !! in the cost function and for use with direct initialization + !! at analysis time. + !!----------------------------------------------------------------------- + INTEGER, INTENT( IN ) :: kt ! Current time-step + INTEGER, INTENT( IN ) :: Kmm ! time level index + ! + CHARACTER (LEN=50) :: cl_asmbkg + CHARACTER (LEN=50) :: cl_asmdin + LOGICAL :: llok ! Check if file exists + INTEGER :: inum ! File unit number + REAL(wp) :: zdate ! Date + !!----------------------------------------------------------------------- + + + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + ! !------------------------------------------- + IF( kt == nitbkg_r ) THEN ! Write out background at time step nitbkg_r + ! !-----------------------------------======== + ! + WRITE(cl_asmbkg, FMT='(A,".nc")' ) TRIM( c_asmbkg ) + cl_asmbkg = TRIM( cl_asmbkg ) + INQUIRE( FILE = cl_asmbkg, EXIST = llok ) + ! + IF( .NOT. llok ) THEN + IF(lwp) WRITE(numout,*) ' Setting up assimilation background file '// TRIM( c_asmbkg ) + ! + ! ! Define the output file + CALL iom_open( c_asmbkg, inum, ldwrt = .TRUE. ) + ! + IF( nitbkg_r == nit000 - 1 ) THEN ! Treat special case when nitbkg = 0 + zdate = REAL( ndastp ) + IF( ln_zdftke ) THEN ! read turbulent kinetic energy ( en ) + IF(lwp) WRITE(numout,*) ' Reading TKE (en) from restart...' + CALL tke_rst( nit000, 'READ' ) + ENDIF + ELSE + zdate = REAL( ndastp ) + ENDIF + ! + ! ! Write the information + CALL iom_rstput( kt, nitbkg_r, inum, 'rdastp' , zdate ) + CALL iom_rstput( kt, nitbkg_r, inum, 'un' , uu(:,:,:,Kmm) ) + CALL iom_rstput( kt, nitbkg_r, inum, 'vn' , vv(:,:,:,Kmm) ) + CALL iom_rstput( kt, nitbkg_r, inum, 'tn' , ts(:,:,:,jp_tem,Kmm) ) + CALL iom_rstput( kt, nitbkg_r, inum, 'sn' , ts(:,:,:,jp_sal,Kmm) ) + CALL iom_rstput( kt, nitbkg_r, inum, 'sshn' , ssh(:,:,Kmm) ) + IF( ln_zdftke ) CALL iom_rstput( kt, nitbkg_r, inum, 'en' , en ) + ! + CALL iom_close( inum ) + ENDIF + ! + ENDIF + + ! !------------------------------------------- + IF( kt == nitdin_r ) THEN ! Write out background at time step nitdin_r + ! !-----------------------------------======== + ! + WRITE(cl_asmdin, FMT='(A,".nc")' ) TRIM( c_asmdin ) + cl_asmdin = TRIM( cl_asmdin ) + INQUIRE( FILE = cl_asmdin, EXIST = llok ) + ! + IF( .NOT. llok ) THEN + IF(lwp) WRITE(numout,*) ' Setting up assimilation background file '// TRIM( c_asmdin ) + ! + ! ! Define the output file + CALL iom_open( c_asmdin, inum, ldwrt = .TRUE. ) + ! + IF( nitdin_r == nit000 - 1 ) THEN ! Treat special case when nitbkg = 0 + + zdate = REAL( ndastp ) + ELSE + zdate = REAL( ndastp ) + ENDIF + ! + ! ! Write the information + CALL iom_rstput( kt, nitdin_r, inum, 'rdastp' , zdate ) + CALL iom_rstput( kt, nitdin_r, inum, 'un' , uu(:,:,:,Kmm) ) + CALL iom_rstput( kt, nitdin_r, inum, 'vn' , vv(:,:,:,Kmm) ) + CALL iom_rstput( kt, nitdin_r, inum, 'tn' , ts(:,:,:,jp_tem,Kmm) ) + CALL iom_rstput( kt, nitdin_r, inum, 'sn' , ts(:,:,:,jp_sal,Kmm) ) + CALL iom_rstput( kt, nitdin_r, inum, 'sshn' , ssh(:,:,Kmm) ) + ! + CALL iom_close( inum ) + ENDIF + ! + ENDIF + ENDIF ! check for last tile + ! + END SUBROUTINE asm_bkg_wri + + !!====================================================================== +END MODULE asmbkg diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/asminc.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/asminc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0e6a13577e2bd1f3be539886c53a04cc40e6c178 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/asminc.f90 @@ -0,0 +1,974 @@ + + + + + + + + + + + + + +MODULE asminc + !!====================================================================== + !! *** MODULE asminc *** + !! Assimilation increment : Apply an increment generated by data + !! assimilation + !!====================================================================== + !! History : ! 2007-03 (M. Martin) Met Office version + !! ! 2007-04 (A. Weaver) calc_date original code + !! ! 2007-04 (A. Weaver) Merge with OPAVAR/NEMOVAR + !! NEMO 3.3 ! 2010-05 (D. Lea) Update to work with NEMO v3.2 + !! - ! 2010-05 (D. Lea) add calc_month_len routine based on day_init + !! 3.4 ! 2012-10 (A. Weaver and K. Mogensen) Fix for direct initialization + !! ! 2014-09 (D. Lea) Local calc_date removed use routine from OBS + !! ! 2015-11 (D. Lea) Handle non-zero initial time of day + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! asm_inc_init : Initialize the increment arrays and IAU weights + !! tra_asm_inc : Apply the tracer (T and S) increments + !! dyn_asm_inc : Apply the dynamic (u and v) increments + !! ssh_asm_inc : Apply the SSH increment + !! ssh_asm_div : Apply divergence associated with SSH increment + !! seaice_asm_inc : Apply the seaice increment + !!---------------------------------------------------------------------- + USE oce ! Dynamics and active tracers defined in memory + USE par_oce ! Ocean space and time domain variables + USE dom_oce ! Ocean space and time domain + USE domvvl ! domain: variable volume level + USE ldfdyn ! lateral diffusion: eddy viscosity coefficients + USE eosbn2 ! Equation of state - in situ and potential density + USE zpshde ! Partial step : Horizontal Derivative + USE asmpar ! Parameters for the assmilation interface + USE asmbkg ! + USE c1d ! 1D initialization + USE sbc_oce ! Surface boundary condition variables. + USE diaobs , ONLY : calc_date ! Compute the calendar date on a given step + ! + USE in_out_manager ! I/O manager + USE iom ! Library to read input files + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC asm_inc_init !: Initialize the increment arrays and IAU weights + PUBLIC tra_asm_inc !: Apply the tracer (T and S) increments + PUBLIC dyn_asm_inc !: Apply the dynamic (u and v) increments + PUBLIC ssh_asm_inc !: Apply the SSH increment + PUBLIC ssh_asm_div !: Apply the SSH divergence + PUBLIC seaice_asm_inc !: Apply the seaice increment + + LOGICAL, PUBLIC, PARAMETER :: lk_asminc = .FALSE. !: No assimilation increments + LOGICAL, PUBLIC :: ln_bkgwri !: No output of the background state fields + LOGICAL, PUBLIC :: ln_asmiau !: No applying forcing with an assimilation increment + LOGICAL, PUBLIC :: ln_asmdin !: No direct initialization + LOGICAL, PUBLIC :: ln_trainc !: No tracer (T and S) assimilation increments + LOGICAL, PUBLIC :: ln_dyninc !: No dynamics (u and v) assimilation increments + LOGICAL, PUBLIC :: ln_sshinc !: No sea surface height assimilation increment + LOGICAL, PUBLIC :: ln_seaiceinc !: No sea ice concentration increment + LOGICAL, PUBLIC :: ln_salfix !: Apply minimum salinity check + LOGICAL, PUBLIC :: ln_temnofreeze = .FALSE. !: Don't allow the temperature to drop below freezing + INTEGER, PUBLIC :: nn_divdmp !: Apply divergence damping filter nn_divdmp times + + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: t_bkg , s_bkg !: Background temperature and salinity + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkg , v_bkg !: Background u- & v- velocity components + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: t_bkginc, s_bkginc !: Increment to the background T & S + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkginc, v_bkginc !: Increment to the u- & v-components + REAL(wp), PUBLIC, DIMENSION(:) , ALLOCATABLE :: wgtiau !: IAU weights for each time step + ! !!! time steps relative to the cycle interval [0,nitend-nit000-1] + INTEGER , PUBLIC :: nitbkg !: Time step of the background state used in the Jb term + INTEGER , PUBLIC :: nitdin !: Time step of the background state for direct initialization + INTEGER , PUBLIC :: nitiaustr !: Time step of the start of the IAU interval + INTEGER , PUBLIC :: nitiaufin !: Time step of the end of the IAU interval + ! + INTEGER , PUBLIC :: niaufn !: Type of IAU weighing function: = 0 Constant weighting + ! !: = 1 Linear hat-like, centred in middle of IAU interval + REAL(wp), PUBLIC :: salfixmin !: Ensure that the salinity is larger than this value if (ln_salfix) + + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ssh_bkg, ssh_bkginc ! Background sea surface height and its increment + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: seaice_bkginc ! Increment to the background sea ice conc + + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: asminc.F90 15058 2021-06-25 09:15:15Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE asm_inc_init( Kbb, Kmm, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE asm_inc_init *** + !! + !! ** Purpose : Initialize the assimilation increment and IAU weights. + !! + !! ** Method : Initialize the assimilation increment and IAU weights. + !! + !! ** Action : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Krhs ! time level indices + ! + INTEGER :: ji, jj, jk, jt ! dummy loop indices + INTEGER :: imid, inum ! local integers + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: iiauper ! Number of time steps in the IAU period + INTEGER :: icycper ! Number of time steps in the cycle + REAL(KIND=wp) :: ditend_date ! Date YYYYMMDD.HHMMSS of final time step + REAL(KIND=wp) :: ditbkg_date ! Date YYYYMMDD.HHMMSS of background time step for Jb term + REAL(KIND=wp) :: ditdin_date ! Date YYYYMMDD.HHMMSS of background time step for DI + REAL(KIND=wp) :: ditiaustr_date ! Date YYYYMMDD.HHMMSS of IAU interval start time step + REAL(KIND=wp) :: ditiaufin_date ! Date YYYYMMDD.HHMMSS of IAU interval final time step + + REAL(wp) :: znorm ! Normalization factor for IAU weights + REAL(wp) :: ztotwgt ! Value of time-integrated IAU weights (should be equal to one) + REAL(wp) :: z_inc_dateb ! Start date of interval on which increment is valid + REAL(wp) :: z_inc_datef ! End date of interval on which increment is valid + REAL(wp) :: zdate_bkg ! Date in background state file for DI + REAL(wp) :: zdate_inc ! Time axis in increments file + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zhdiv ! 2D workspace + !! + NAMELIST/nam_asminc/ ln_bkgwri, & + & ln_trainc, ln_dyninc, ln_sshinc, & + & ln_asmdin, ln_asmiau, & + & nitbkg, nitdin, nitiaustr, nitiaufin, niaufn, & + & ln_salfix, salfixmin, nn_divdmp + !!---------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! Read Namelist nam_asminc : assimilation increment interface + !----------------------------------------------------------------------- + ln_seaiceinc = .FALSE. + ln_temnofreeze = .FALSE. + + READ ( numnam_ref, nam_asminc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_asminc in reference namelist' ) + READ ( numnam_cfg, nam_asminc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_asminc in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_asminc ) + + ! Control print + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : Assimilation increment initialization :' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namasm : set assimilation increment parameters' + WRITE(numout,*) ' Logical switch for writing out background state ln_bkgwri = ', ln_bkgwri + WRITE(numout,*) ' Logical switch for applying tracer increments ln_trainc = ', ln_trainc + WRITE(numout,*) ' Logical switch for applying velocity increments ln_dyninc = ', ln_dyninc + WRITE(numout,*) ' Logical switch for applying SSH increments ln_sshinc = ', ln_sshinc + WRITE(numout,*) ' Logical switch for Direct Initialization (DI) ln_asmdin = ', ln_asmdin + WRITE(numout,*) ' Logical switch for applying sea ice increments ln_seaiceinc = ', ln_seaiceinc + WRITE(numout,*) ' Logical switch for Incremental Analysis Updating (IAU) ln_asmiau = ', ln_asmiau + WRITE(numout,*) ' Timestep of background in [0,nitend-nit000-1] nitbkg = ', nitbkg + WRITE(numout,*) ' Timestep of background for DI in [0,nitend-nit000-1] nitdin = ', nitdin + WRITE(numout,*) ' Timestep of start of IAU interval in [0,nitend-nit000-1] nitiaustr = ', nitiaustr + WRITE(numout,*) ' Timestep of end of IAU interval in [0,nitend-nit000-1] nitiaufin = ', nitiaufin + WRITE(numout,*) ' Type of IAU weighting function niaufn = ', niaufn + WRITE(numout,*) ' Logical switch for ensuring that the sa > salfixmin ln_salfix = ', ln_salfix + WRITE(numout,*) ' Minimum salinity after applying the increments salfixmin = ', salfixmin + ENDIF + + nitbkg_r = nitbkg + nit000 - 1 ! Background time referenced to nit000 + nitdin_r = nitdin + nit000 - 1 ! Background time for DI referenced to nit000 + nitiaustr_r = nitiaustr + nit000 - 1 ! Start of IAU interval referenced to nit000 + nitiaufin_r = nitiaufin + nit000 - 1 ! End of IAU interval referenced to nit000 + + iiauper = nitiaufin_r - nitiaustr_r + 1 ! IAU interval length + icycper = nitend - nit000 + 1 ! Cycle interval length + + CALL calc_date( nitend , ditend_date ) ! Date of final time step + CALL calc_date( nitbkg_r , ditbkg_date ) ! Background time for Jb referenced to ndate0 + CALL calc_date( nitdin_r , ditdin_date ) ! Background time for DI referenced to ndate0 + CALL calc_date( nitiaustr_r, ditiaustr_date ) ! IAU start time referenced to ndate0 + CALL calc_date( nitiaufin_r, ditiaufin_date ) ! IAU end time referenced to ndate0 + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Time steps referenced to current cycle:' + WRITE(numout,*) ' iitrst = ', nit000 - 1 + WRITE(numout,*) ' nit000 = ', nit000 + WRITE(numout,*) ' nitend = ', nitend + WRITE(numout,*) ' nitbkg_r = ', nitbkg_r + WRITE(numout,*) ' nitdin_r = ', nitdin_r + WRITE(numout,*) ' nitiaustr_r = ', nitiaustr_r + WRITE(numout,*) ' nitiaufin_r = ', nitiaufin_r + WRITE(numout,*) + WRITE(numout,*) ' Dates referenced to current cycle:' + WRITE(numout,*) ' ndastp = ', ndastp + WRITE(numout,*) ' ndate0 = ', ndate0 + WRITE(numout,*) ' nn_time0 = ', nn_time0 + WRITE(numout,*) ' ditend_date = ', ditend_date + WRITE(numout,*) ' ditbkg_date = ', ditbkg_date + WRITE(numout,*) ' ditdin_date = ', ditdin_date + WRITE(numout,*) ' ditiaustr_date = ', ditiaustr_date + WRITE(numout,*) ' ditiaufin_date = ', ditiaufin_date + ENDIF + + + IF ( ( ln_asmdin ).AND.( ln_asmiau ) ) & + & CALL ctl_stop( ' ln_asmdin and ln_asmiau :', & + & ' Choose Direct Initialization OR Incremental Analysis Updating') + + IF ( ( ( .NOT. ln_asmdin ).AND.( .NOT. ln_asmiau ) ) & + .AND.( ( ln_trainc ).OR.( ln_dyninc ).OR.( ln_sshinc ) .OR. ( ln_seaiceinc) )) & + & CALL ctl_stop( ' One or more of ln_trainc, ln_dyninc, ln_sshinc and ln_seaiceinc is set to .true.', & + & ' but ln_asmdin and ln_asmiau are both set to .false. :', & + & ' Inconsistent options') + + IF ( ( niaufn /= 0 ).AND.( niaufn /= 1 ) ) & + & CALL ctl_stop( ' niaufn /= 0 or niaufn /=1 :', & + & ' Type IAU weighting function is invalid') + + IF ( ( .NOT. ln_trainc ).AND.( .NOT. ln_dyninc ).AND.( .NOT. ln_sshinc ).AND.( .NOT. ln_seaiceinc ) & + & ) & + & CALL ctl_warn( ' ln_trainc, ln_dyninc, ln_sshinc and ln_seaiceinc are set to .false. :', & + & ' The assimilation increments are not applied') + + IF ( ( ln_asmiau ).AND.( nitiaustr == nitiaufin ) ) & + & CALL ctl_stop( ' nitiaustr = nitiaufin :', & + & ' IAU interval is of zero length') + + IF ( ( ln_asmiau ).AND.( ( nitiaustr_r < nit000 ).OR.( nitiaufin_r > nitend ) ) ) & + & CALL ctl_stop( ' nitiaustr or nitiaufin :', & + & ' IAU starting or final time step is outside the cycle interval', & + & ' Valid range nit000 to nitend') + + IF ( ( nitbkg_r < nit000 - 1 ).OR.( nitbkg_r > nitend ) ) & + & CALL ctl_stop( ' nitbkg :', & + & ' Background time step is outside the cycle interval') + + IF ( ( nitdin_r < nit000 - 1 ).OR.( nitdin_r > nitend ) ) & + & CALL ctl_stop( ' nitdin :', & + & ' Background time step for Direct Initialization is outside', & + & ' the cycle interval') + + IF ( nstop > 0 ) RETURN ! if there are any errors then go no further + + !-------------------------------------------------------------------- + ! Initialize the Incremental Analysis Updating weighting function + !-------------------------------------------------------------------- + + IF( ln_asmiau ) THEN + ! + ALLOCATE( wgtiau( icycper ) ) + ! + wgtiau(:) = 0._wp + ! + ! !--------------------------------------------------------- + IF( niaufn == 0 ) THEN ! Constant IAU forcing + ! !--------------------------------------------------------- + DO jt = 1, iiauper + wgtiau(jt+nitiaustr-1) = 1.0 / REAL( iiauper ) + END DO + ! !--------------------------------------------------------- + ELSEIF ( niaufn == 1 ) THEN ! Linear hat-like, centred in middle of IAU interval + ! !--------------------------------------------------------- + ! Compute the normalization factor + znorm = 0._wp + IF( MOD( iiauper, 2 ) == 0 ) THEN ! Even number of time steps in IAU interval + imid = iiauper / 2 + DO jt = 1, imid + znorm = znorm + REAL( jt ) + END DO + znorm = 2.0 * znorm + ELSE ! Odd number of time steps in IAU interval + imid = ( iiauper + 1 ) / 2 + DO jt = 1, imid - 1 + znorm = znorm + REAL( jt ) + END DO + znorm = 2.0 * znorm + REAL( imid ) + ENDIF + znorm = 1.0 / znorm + ! + DO jt = 1, imid - 1 + wgtiau(jt+nitiaustr-1) = REAL( jt ) * znorm + END DO + DO jt = imid, iiauper + wgtiau(jt+nitiaustr-1) = REAL( iiauper - jt + 1 ) * znorm + END DO + ! + ENDIF + + ! Test that the integral of the weights over the weighting interval equals 1 + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : IAU weights' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' time step IAU weight' + WRITE(numout,*) ' ========= =====================' + ztotwgt = 0.0 + DO jt = 1, icycper + ztotwgt = ztotwgt + wgtiau(jt) + WRITE(numout,*) ' ', jt, ' ', wgtiau(jt) + END DO + WRITE(numout,*) ' ===================================' + WRITE(numout,*) ' Time-integrated weight = ', ztotwgt + WRITE(numout,*) ' ===================================' + ENDIF + + ENDIF + + !-------------------------------------------------------------------- + ! Allocate and initialize the increment arrays + !-------------------------------------------------------------------- + + ALLOCATE( t_bkginc (jpi,jpj,jpk) ) ; t_bkginc (:,:,:) = 0._wp + ALLOCATE( s_bkginc (jpi,jpj,jpk) ) ; s_bkginc (:,:,:) = 0._wp + ALLOCATE( u_bkginc (jpi,jpj,jpk) ) ; u_bkginc (:,:,:) = 0._wp + ALLOCATE( v_bkginc (jpi,jpj,jpk) ) ; v_bkginc (:,:,:) = 0._wp + ALLOCATE( ssh_bkginc (jpi,jpj) ) ; ssh_bkginc (:,:) = 0._wp + ALLOCATE( seaice_bkginc(jpi,jpj) ) ; seaice_bkginc(:,:) = 0._wp + ! + IF ( ln_trainc .OR. ln_dyninc .OR. & !-------------------------------------- + & ln_sshinc .OR. ln_seaiceinc ) THEN ! Read the increments from file + ! !-------------------------------------- + CALL iom_open( c_asminc, inum ) + ! + CALL iom_get( inum, 'time' , zdate_inc ) + CALL iom_get( inum, 'z_inc_dateb', z_inc_dateb ) + CALL iom_get( inum, 'z_inc_datef', z_inc_datef ) + z_inc_dateb = zdate_inc + z_inc_datef = zdate_inc + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : Assimilation increments valid between dates ', z_inc_dateb,' and ', z_inc_datef + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + IF ( ( z_inc_dateb < ndastp + nn_time0*0.0001_wp ) .OR. & + & ( z_inc_datef > ditend_date ) ) & + & CALL ctl_warn( ' Validity time of assimilation increments is ', & + & ' outside the assimilation interval' ) + + IF ( ( ln_asmdin ).AND.( zdate_inc /= ditdin_date ) ) & + & CALL ctl_warn( ' Validity time of assimilation increments does ', & + & ' not agree with Direct Initialization time' ) + + IF ( ln_trainc ) THEN + CALL iom_get( inum, jpdom_auto, 'bckint', t_bkginc, 1 ) + CALL iom_get( inum, jpdom_auto, 'bckins', s_bkginc, 1 ) + ! Apply the masks + t_bkginc(:,:,:) = t_bkginc(:,:,:) * tmask(:,:,:) + s_bkginc(:,:,:) = s_bkginc(:,:,:) * tmask(:,:,:) + ! Set missing increments to 0.0 rather than 1e+20 + ! to allow for differences in masks + WHERE( ABS( t_bkginc(:,:,:) ) > 1.0e+10 ) t_bkginc(:,:,:) = 0.0 + WHERE( ABS( s_bkginc(:,:,:) ) > 1.0e+10 ) s_bkginc(:,:,:) = 0.0 + ENDIF + + IF ( ln_dyninc ) THEN + CALL iom_get( inum, jpdom_auto, 'bckinu', u_bkginc, 1 ) + CALL iom_get( inum, jpdom_auto, 'bckinv', v_bkginc, 1 ) + ! Apply the masks + u_bkginc(:,:,:) = u_bkginc(:,:,:) * umask(:,:,:) + v_bkginc(:,:,:) = v_bkginc(:,:,:) * vmask(:,:,:) + ! Set missing increments to 0.0 rather than 1e+20 + ! to allow for differences in masks + WHERE( ABS( u_bkginc(:,:,:) ) > 1.0e+10 ) u_bkginc(:,:,:) = 0.0 + WHERE( ABS( v_bkginc(:,:,:) ) > 1.0e+10 ) v_bkginc(:,:,:) = 0.0 + ENDIF + + IF ( ln_sshinc ) THEN + CALL iom_get( inum, jpdom_auto, 'bckineta', ssh_bkginc, 1 ) + ! Apply the masks + ssh_bkginc(:,:) = ssh_bkginc(:,:) * tmask(:,:,1) + ! Set missing increments to 0.0 rather than 1e+20 + ! to allow for differences in masks + WHERE( ABS( ssh_bkginc(:,:) ) > 1.0e+10 ) ssh_bkginc(:,:) = 0.0 + ENDIF + + IF ( ln_seaiceinc ) THEN + CALL iom_get( inum, jpdom_auto, 'bckinseaice', seaice_bkginc, 1 ) + ! Apply the masks + seaice_bkginc(:,:) = seaice_bkginc(:,:) * tmask(:,:,1) + ! Set missing increments to 0.0 rather than 1e+20 + ! to allow for differences in masks + WHERE( ABS( seaice_bkginc(:,:) ) > 1.0e+10 ) seaice_bkginc(:,:) = 0.0 + ENDIF + ! + CALL iom_close( inum ) + ! + ENDIF + ! + ! !-------------------------------------- + IF ( ln_dyninc .AND. nn_divdmp > 0 ) THEN ! Apply divergence damping filter + ! !-------------------------------------- + ALLOCATE( zhdiv(jpi,jpj) ) + ! + DO jt = 1, nn_divdmp + ! + DO jk = 1, jpkm1 ! zhdiv = e1e1 * div + zhdiv(:,:) = 0._wp + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zhdiv(ji,jj) = ( e2u(ji ,jj) * (e3u_0(ji ,jj,jk)*(1._wp+r3u(ji ,jj,Kmm)*umask(ji ,jj,jk))) * u_bkginc(ji ,jj,jk) & + & - e2u(ji-1,jj) * (e3u_0(ji-1,jj,jk)*(1._wp+r3u(ji-1,jj,Kmm)*umask(ji-1,jj,jk))) * u_bkginc(ji-1,jj,jk) & + & + e1v(ji,jj ) * (e3v_0(ji,jj ,jk)*(1._wp+r3v(ji,jj ,Kmm)*vmask(ji,jj ,jk))) * v_bkginc(ji,jj ,jk) & + & - e1v(ji,jj-1) * (e3v_0(ji,jj-1,jk)*(1._wp+r3v(ji,jj-1,Kmm)*vmask(ji,jj-1,jk))) * v_bkginc(ji,jj-1,jk) ) & + & / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO + CALL lbc_lnk( 'asminc', zhdiv, 'T', 1.0_wp ) ! lateral boundary cond. (no sign change) + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + u_bkginc(ji,jj,jk) = u_bkginc(ji,jj,jk) & + & + 0.2_wp * ( zhdiv(ji+1,jj) - zhdiv(ji ,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) + v_bkginc(ji,jj,jk) = v_bkginc(ji,jj,jk) & + & + 0.2_wp * ( zhdiv(ji,jj+1) - zhdiv(ji,jj ) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) + END DO ; END DO + END DO + ! + END DO + ! + DEALLOCATE( zhdiv ) + ! + ENDIF + ! + ! !----------------------------------------------------- + IF ( ln_asmdin ) THEN ! Allocate and initialize the background state arrays + ! !----------------------------------------------------- + ! + ALLOCATE( t_bkg (jpi,jpj,jpk) ) ; t_bkg (:,:,:) = 0._wp + ALLOCATE( s_bkg (jpi,jpj,jpk) ) ; s_bkg (:,:,:) = 0._wp + ALLOCATE( u_bkg (jpi,jpj,jpk) ) ; u_bkg (:,:,:) = 0._wp + ALLOCATE( v_bkg (jpi,jpj,jpk) ) ; v_bkg (:,:,:) = 0._wp + ALLOCATE( ssh_bkg(jpi,jpj) ) ; ssh_bkg(:,:) = 0._wp + ! + ! + !-------------------------------------------------------------------- + ! Read from file the background state at analysis time + !-------------------------------------------------------------------- + ! + CALL iom_open( c_asmdin, inum ) + ! + CALL iom_get( inum, 'rdastp', zdate_bkg ) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> Assimilation background state valid at : ', zdate_bkg + WRITE(numout,*) + ENDIF + ! + IF ( zdate_bkg /= ditdin_date ) & + & CALL ctl_warn( ' Validity time of assimilation background state does', & + & ' not agree with Direct Initialization time' ) + ! + IF ( ln_trainc ) THEN + CALL iom_get( inum, jpdom_auto, 'tn', t_bkg ) + CALL iom_get( inum, jpdom_auto, 'sn', s_bkg ) + t_bkg(:,:,:) = t_bkg(:,:,:) * tmask(:,:,:) + s_bkg(:,:,:) = s_bkg(:,:,:) * tmask(:,:,:) + ENDIF + ! + IF ( ln_dyninc ) THEN + CALL iom_get( inum, jpdom_auto, 'un', u_bkg, cd_type = 'U', psgn = 1._dp ) + CALL iom_get( inum, jpdom_auto, 'vn', v_bkg, cd_type = 'V', psgn = 1._dp ) + u_bkg(:,:,:) = u_bkg(:,:,:) * umask(:,:,:) + v_bkg(:,:,:) = v_bkg(:,:,:) * vmask(:,:,:) + ENDIF + ! + IF ( ln_sshinc ) THEN + CALL iom_get( inum, jpdom_auto, 'sshn', ssh_bkg ) + ssh_bkg(:,:) = ssh_bkg(:,:) * tmask(:,:,1) + ENDIF + ! + CALL iom_close( inum ) + ! + ENDIF + ! + IF(lwp) WRITE(numout,*) ' ==>>> Euler time step switch is ', l_1st_euler + ! + IF( lk_asminc ) THEN !== data assimilation ==! + IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1, Kmm ) ! Output background fields + IF( ln_asmdin ) THEN ! Direct initialization + IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1, Kbb, Kmm, ts , Krhs ) ! Tracers + IF( ln_dyninc ) CALL dyn_asm_inc( nit000 - 1, Kbb, Kmm, uu, vv, Krhs ) ! Dynamics + IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1, Kbb, Kmm ) ! SSH + ENDIF + ENDIF + ! + END SUBROUTINE asm_inc_init + + + SUBROUTINE tra_asm_inc( kt, Kbb, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_asm_inc *** + !! + !! ** Purpose : Apply the tracer (T and S) assimilation increments + !! + !! ** Method : Direct initialization or Incremental Analysis Updating + !! + !! ** Action : + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! Current time step + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! Time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk + INTEGER :: it + REAL(wp) :: zincwgt ! IAU weight for current time step + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: fzptnz ! 3d freezing point values + !!---------------------------------------------------------------------- + ! + ! freezing point calculation taken from oc_fz_pt (but calculated for all depths) + ! used to prevent the applied increments taking the temperature below the local freezing point + IF( ln_temnofreeze ) THEN + DO jk = 1, jpkm1 + CALL eos_fzp( REAL(pts(:,:,jk,jp_sal,Kmm),sp), fzptnz(:,:,jk), (gdept_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) ) + END DO + ENDIF + ! + ! !-------------------------------------- + IF ( ln_asmiau ) THEN ! Incremental Analysis Updating + ! !-------------------------------------- + ! + IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN + ! + it = kt - nit000 + 1 + zincwgt = wgtiau(it) / rn_Dt ! IAU weight for the current time step + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! Update the tracer tendencies + DO jk = 1, jpkm1 + IF (ln_temnofreeze) THEN + ! Do not apply negative increments if the temperature will fall below freezing + WHERE(t_bkginc(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk) > 0.0_wp .OR. & + & pts(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk,jp_tem,Kmm) + pts(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk,jp_tem,Krhs) + t_bkginc(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk) * wgtiau(it) > fzptnz(:,:,jk) ) + pts(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk,jp_tem,Krhs) = pts(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk,jp_tem,Krhs) + t_bkginc(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk) * zincwgt + END WHERE + ELSE + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) + t_bkginc(ji,jj,jk) * zincwgt + END DO ; END DO + ENDIF + IF (ln_salfix) THEN + ! Do not apply negative increments if the salinity will fall below a specified + ! minimum value salfixmin + WHERE(s_bkginc(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk) > 0.0_wp .OR. & + & pts(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk,jp_sal,Kmm) + pts(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk,jp_sal,Krhs) + s_bkginc(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk) * wgtiau(it) > salfixmin ) + pts(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk,jp_sal,Krhs) = pts(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk,jp_sal,Krhs) + s_bkginc(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jk) * zincwgt + END WHERE + ELSE + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) + s_bkginc(ji,jj,jk) * zincwgt + END DO ; END DO + ENDIF + END DO + ! + ENDIF + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF ( kt == nitiaufin_r + 1 ) THEN ! For bias crcn to work + DEALLOCATE( t_bkginc ) + DEALLOCATE( s_bkginc ) + ENDIF + ENDIF + ! !-------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !-------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + l_1st_euler = .TRUE. ! Force Euler forward step + ! + ! Initialize the now fields with the background + increment + IF (ln_temnofreeze) THEN + ! Do not apply negative increments if the temperature will fall below freezing + WHERE( t_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_tem,Kmm) + t_bkginc(:,:,:) > fzptnz(:,:,:) ) + pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) + END WHERE + ELSE + pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) + ENDIF + IF (ln_salfix) THEN + ! Do not apply negative increments if the salinity will fall below a specified + ! minimum value salfixmin + WHERE( s_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_sal,Kmm) + s_bkginc(:,:,:) > salfixmin ) + pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) + END WHERE + ELSE + pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) + ENDIF + + pts(:,:,:,:,Kbb) = pts(:,:,:,:,Kmm) ! Update before fields + + CALL eos( pts(:,:,:,:,Kbb), rhd, rhop, gdept_0(:,:,:) ) ! Before potential and in situ densities +!!gm fabien +! CALL eos( pts(:,:,:,:,Kbb), rhd, rhop ) ! Before potential and in situ densities +!!gm + + IF( ln_zps .AND. .NOT. ln_c1d .AND. .NOT. ln_isfcav) & + & CALL zps_hde ( kt, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient + & rhd, gru , grv ) ! of t, s, rd at the last ocean level + IF( ln_zps .AND. .NOT. ln_c1d .AND. ln_isfcav) & + & CALL zps_hde_isf( nit000, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) + & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the last ocean level + + DEALLOCATE( t_bkginc ) + DEALLOCATE( s_bkginc ) + DEALLOCATE( t_bkg ) + DEALLOCATE( s_bkg ) + ENDIF + ! + ENDIF + ! Perhaps the following call should be in step + IF ( ln_seaiceinc ) CALL seaice_asm_inc ( kt ) ! apply sea ice concentration increment + ! + END SUBROUTINE tra_asm_inc + + + SUBROUTINE dyn_asm_inc( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_asm_inc *** + !! + !! ** Purpose : Apply the dynamics (u and v) assimilation increments. + !! + !! ** Method : Direct initialization or Incremental Analysis Updating. + !! + !! ** Action : + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk + INTEGER :: it + REAL(wp) :: zincwgt ! IAU weight for current time step + !!---------------------------------------------------------------------- + ! + ! !-------------------------------------------- + IF ( ln_asmiau ) THEN ! Incremental Analysis Updating + ! !-------------------------------------------- + ! + IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN + ! + it = kt - nit000 + 1 + zincwgt = wgtiau(it) / rn_Dt ! IAU weight for the current time step + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_asm_inc : Dynamics IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! Update the dynamic tendencies + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + u_bkginc(ji,jj,jk) * zincwgt + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + v_bkginc(ji,jj,jk) * zincwgt + END DO ; END DO ; END DO + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF ( kt == nitiaufin_r ) THEN + DEALLOCATE( u_bkginc ) + DEALLOCATE( v_bkginc ) + ENDIF + ENDIF + ! + ENDIF + ! !----------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !----------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + l_1st_euler = .TRUE. ! Force Euler forward step + ! + ! Initialize the now fields with the background + increment + puu(:,:,:,Kmm) = u_bkg(:,:,:) + u_bkginc(:,:,:) + pvv(:,:,:,Kmm) = v_bkg(:,:,:) + v_bkginc(:,:,:) + ! + puu(:,:,:,Kbb) = puu(:,:,:,Kmm) ! Update before fields + pvv(:,:,:,Kbb) = pvv(:,:,:,Kmm) + ! + DEALLOCATE( u_bkg ) + DEALLOCATE( v_bkg ) + DEALLOCATE( u_bkginc ) + DEALLOCATE( v_bkginc ) + ENDIF + ! + ENDIF + ! + END SUBROUTINE dyn_asm_inc + + + SUBROUTINE ssh_asm_inc( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ssh_asm_inc *** + !! + !! ** Purpose : Apply the sea surface height assimilation increment. + !! + !! ** Method : Direct initialization or Incremental Analysis Updating. + !! + !! ** Action : + !!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kt ! Current time step + INTEGER, INTENT(IN) :: Kbb, Kmm ! Current time step + ! + INTEGER :: it + INTEGER :: ji, jj, jk + REAL(wp) :: zincwgt ! IAU weight for current time step + !!---------------------------------------------------------------------- + ! + ! !----------------------------------------- + IF ( ln_asmiau ) THEN ! Incremental Analysis Updating + ! !----------------------------------------- + ! + IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN + ! + it = kt - nit000 + 1 + zincwgt = wgtiau(it) / rn_Dt ! IAU weight for the current time step + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'ssh_asm_inc : SSH IAU at time step = ', & + & kt,' with IAU weight = ', wgtiau(it) + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! Save the tendency associated with the IAU weighted SSH increment + ! (applied in dynspg.*) + ! + ELSE IF( kt == nitiaufin_r+1 ) THEN + ! + ! test on ssh_bkginc needed as ssh_asm_inc is called twice by time step + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF (ALLOCATED(ssh_bkginc)) DEALLOCATE( ssh_bkginc ) + ENDIF + ! + ! + ENDIF + ! !----------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !----------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + l_1st_euler = .TRUE. ! Force Euler forward step + ! + ssh(:,:,Kmm) = ssh_bkg(:,:) + ssh_bkginc(:,:) ! Initialize the now fields the background + increment + ! + ssh(:,:,Kbb) = ssh(:,:,Kmm) ! Update before fields +!!gm why not (e3u_0(:,:,:)*(1._wp+r3u(:,:,Kbb)*umask(:,:,:))), (e3v_0(:,:,:)*(1._wp+r3v(:,:,Kbb)*vmask(:,:,:))), (gdept_0(:,:,:)*(1._wp+r3t(:,:,Kbb))) ???? + ! + DEALLOCATE( ssh_bkg ) + DEALLOCATE( ssh_bkginc ) + ! + ENDIF + ! + ENDIF + ! + END SUBROUTINE ssh_asm_inc + + + SUBROUTINE ssh_asm_div( kt, Kbb, Kmm, phdivn ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ssh_asm_div *** + !! + !! ** Purpose : ssh increment with z* is incorporated via a correction of the local divergence + !! across all the water column + !! + !! ** Method : + !! CAUTION : sshiau is positive (inflow) decreasing the + !! divergence and expressed in m/s + !! + !! ** Action : phdivn decreased by the ssh increment + !!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kt ! ocean time-step index + INTEGER, INTENT(IN) :: Kbb, Kmm ! time level indices + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence + !! + INTEGER :: ji, jj, jk ! dummy loop index + REAL(wp), DIMENSION(:,:) , POINTER :: ztim ! local array + !!---------------------------------------------------------------------- + ! + ! + END SUBROUTINE ssh_asm_div + + + SUBROUTINE seaice_asm_inc( kt, kindic ) + !!---------------------------------------------------------------------- + !! *** ROUTINE seaice_asm_inc *** + !! + !! ** Purpose : Apply the sea ice assimilation increment. + !! + !! ** Method : Direct initialization or Incremental Analysis Updating. + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! Current time step + INTEGER, INTENT(in), OPTIONAL :: kindic ! flag for disabling the deallocation + ! + INTEGER :: ji, jj + INTEGER :: it + REAL(wp) :: zincwgt ! IAU weight for current time step + !!---------------------------------------------------------------------- + ! + ! !----------------------------------------- + IF ( ln_asmiau ) THEN ! Incremental Analysis Updating + ! !----------------------------------------- + ! + IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN + ! + it = kt - nit000 + 1 + zincwgt = wgtiau(it) ! IAU weight for the current time step + ! note this is not a tendency so should not be divided by rn_Dt (as with the tracer and other increments) + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! Sea-ice : SI3 case + ! + ! + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF ( kt == nitiaufin_r ) THEN + DEALLOCATE( seaice_bkginc ) + ENDIF + ENDIF + ! + ELSE + ! + ! + ENDIF + ! !----------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !----------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + l_1st_euler = .TRUE. ! Force Euler forward step + ! + ! Sea-ice : SI3 case + ! + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF ( .NOT. PRESENT(kindic) ) THEN + DEALLOCATE( seaice_bkginc ) + END IF + ENDIF + ! + ELSE + ! + ! + ENDIF + +!#if defined defined key_si3 || defined key_cice +! +! IF (ln_seaicebal ) THEN +! !! balancing salinity increments +! !! simple case from limflx.F90 (doesn't include a mass flux) +! !! assumption is that as ice concentration is reduced or increased +! !! the snow and ice depths remain constant +! !! note that snow is being created where ice concentration is being increased +! !! - could be more sophisticated and +! !! not do this (but would need to alter h_snow) +! +! usave(:,:,:)=sb(:,:,:) ! use array as a temporary store +! +! DO jj = 1, jpj +! DO ji = 1, jpi +! ! calculate change in ice and snow mass per unit area +! ! positive values imply adding salt to the ocean (results from ice formation) +! ! fwf : ice formation and melting +! +! zfons = ( -nfresh_da(ji,jj)*soce + nfsalt_da(ji,jj) )*rn_Dt +! +! ! change salinity down to mixed layer depth +! mld=hmld_kara(ji,jj) +! +! ! prevent small mld +! ! less than 10m can cause salinity instability +! IF (mld < 10) mld=10 +! +! ! set to bottom of a level +! DO jk = jpk-1, 2, -1 +! IF ((mld > (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))) .and. (mld < (gdepw_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))))) THEN +! mld=(gdepw_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) +! jkmax=jk +! ENDIF +! ENDDO +! +! ! avoid applying salinity balancing in shallow water or on land +! ! +! +! ! dsal_ocn (psu kg m^-2) / (kg m^-3 * m) +! +! dsal_ocn=0.0_wp +! sal_thresh=5.0_wp ! minimum salinity threshold for salinity balancing +! +! if (tmask(ji,jj,1) > 0 .AND. tmask(ji,jj,jkmax) > 0 ) & +! dsal_ocn = zfons / (rhop(ji,jj,1) * mld) +! +! ! put increments in for levels in the mixed layer +! ! but prevent salinity below a threshold value +! +! DO jk = 1, jkmax +! +! IF (dsal_ocn > 0.0_wp .or. sb(ji,jj,jk)+dsal_ocn > sal_thresh) THEN +! sb(ji,jj,jk) = sb(ji,jj,jk) + dsal_ocn +! sn(ji,jj,jk) = sn(ji,jj,jk) + dsal_ocn +! ENDIF +! +! ENDDO +! +! ! ! salt exchanges at the ice/ocean interface +! ! zpmess = zfons / rDt_ice ! rDt_ice is ice timestep +! ! +! !! Adjust fsalt. A +ve fsalt means adding salt to ocean +! !! fsalt(ji,jj) = fsalt(ji,jj) + zpmess ! adjust fsalt +! !! +! !! emps(ji,jj) = emps(ji,jj) + zpmess ! or adjust emps (see icestp1d) +! !! ! E-P (kg m-2 s-2) +! ! emp(ji,jj) = emp(ji,jj) + zpmess ! E-P (kg m-2 s-2) +! ENDDO !ji +! ENDDO !jj! +! +! ENDIF !ln_seaicebal +! +!#endif + ! + ENDIF + ! + END SUBROUTINE seaice_asm_inc + + !!====================================================================== +END MODULE asminc diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/asmpar.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/asmpar.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a9b9d4ddda34e5924f4c85e7d10fe658a8b2118a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/asmpar.f90 @@ -0,0 +1,42 @@ + + + + + + + + + + + + + +MODULE asmpar + !!====================================================================== + !! *** MODULE asmpar *** + !! Assimilation increment : Parameters for assimilation interface + !!====================================================================== + + IMPLICIT NONE + PRIVATE + + CHARACTER(LEN=40), PUBLIC, PARAMETER :: c_asmbkg = 'assim_background_state_Jb' !: Filename for storing the background state + ! ! for use in the Jb term + CHARACTER(LEN=40), PUBLIC, PARAMETER :: c_asmdin = 'assim_background_state_DI' !: Filename for storing the background state + ! ! for direct initialization + CHARACTER(LEN=40), PUBLIC, PARAMETER :: c_asmtrj = 'assim_trj' !: Filename for storing the reference trajectory + CHARACTER(LEN=40), PUBLIC, PARAMETER :: c_asminc = 'assim_background_increments' !: Filename for storing the increments + ! ! to the background state + + INTEGER, PUBLIC :: nitbkg_r !: Background time step referenced to nit000 + INTEGER, PUBLIC :: nitdin_r !: Direct Initialization time step referenced to nit000 + INTEGER, PUBLIC :: nitiaustr_r !: IAU starting time step referenced to nit000 + INTEGER, PUBLIC :: nitiaufin_r !: IAU final time step referenced to nit000 + INTEGER, PUBLIC :: nittrjfrq !: Frequency of trajectory output for 4D-VAR + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: asmpar.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE asmpar diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdy_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdy_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1780b5519149999e6a41b95d96efcb82aabe3e06 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdy_oce.f90 @@ -0,0 +1,185 @@ + + + + + + + + + + + + + +MODULE bdy_oce + !!====================================================================== + !! *** MODULE bdy_oce *** + !! Unstructured Open Boundary Cond. : define related variables + !!====================================================================== + !! History : 1.0 ! 2001-05 (J. Chanut, A. Sellar) Original code + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.3 ! 2010-09 (D. Storkey) add ice boundary conditions + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !! 3.6 ! 2014-01 (C. Rousset) add ice boundary conditions for new model + !! 4.0 ! 2018 (C. Rousset) SI3 compatibility + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + + IMPLICIT NONE + PUBLIC + + INTEGER, PUBLIC, PARAMETER :: jp_bdy = 10 !: Maximum number of bdy sets + INTEGER, PUBLIC, PARAMETER :: jpbgrd = 3 !: Number of horizontal grid types used (T, U, V) + + TYPE, PUBLIC :: OBC_INDEX !: Indices and weights which define the open boundary + INTEGER , DIMENSION(jpbgrd) :: nblen + INTEGER , DIMENSION(jpbgrd) :: nblenrim + INTEGER , DIMENSION(jpbgrd) :: nblenrim0 + INTEGER , POINTER, DIMENSION(:,:) :: nbi + INTEGER , POINTER, DIMENSION(:,:) :: nbj + INTEGER , POINTER, DIMENSION(:,:) :: nbr + INTEGER , POINTER, DIMENSION(:,:) :: nbmap + INTEGER , POINTER, DIMENSION(:,:) :: ntreat + REAL(wp), POINTER, DIMENSION(:,:) :: nbw + REAL(wp), POINTER, DIMENSION(:,:) :: nbd + REAL(wp), POINTER, DIMENSION(:,:) :: nbdout + REAL(wp), POINTER, DIMENSION(:,:) :: flagu + REAL(wp), POINTER, DIMENSION(:,:) :: flagv + END TYPE OBC_INDEX + + !! Logicals in OBC_DATA structure are true if the chosen algorithm requires this + !! field as external data. If true the data can come from external files + !! or model initial conditions. If false then no "external" data array + !! is required for this field. + + TYPE, PUBLIC :: OBC_DATA !: Storage for external data + INTEGER , DIMENSION(2) :: nread + LOGICAL :: lneed_ssh + LOGICAL :: lneed_dyn2d + LOGICAL :: lneed_dyn3d + LOGICAL :: lneed_tra + LOGICAL :: lneed_ice + REAL(wp), POINTER, DIMENSION(:) :: ssh + REAL(wp), POINTER, DIMENSION(:) :: u2d + REAL(wp), POINTER, DIMENSION(:) :: v2d + REAL(wp), POINTER, DIMENSION(:,:) :: u3d + REAL(wp), POINTER, DIMENSION(:,:) :: v3d + REAL(wp), POINTER, DIMENSION(:,:) :: tem + REAL(wp), POINTER, DIMENSION(:,:) :: sal + REAL(wp), POINTER, DIMENSION(:,:) :: a_i !: now ice leads fraction climatology + REAL(wp), POINTER, DIMENSION(:,:) :: h_i !: Now ice thickness climatology + REAL(wp), POINTER, DIMENSION(:,:) :: h_s !: now snow thickness + REAL(wp), POINTER, DIMENSION(:,:) :: t_i !: now ice temperature + REAL(wp), POINTER, DIMENSION(:,:) :: t_s !: now snow temperature + REAL(wp), POINTER, DIMENSION(:,:) :: tsu !: now surf temperature + REAL(wp), POINTER, DIMENSION(:,:) :: s_i !: now ice salinity + REAL(wp), POINTER, DIMENSION(:,:) :: aip !: now ice pond concentration + REAL(wp), POINTER, DIMENSION(:,:) :: hip !: now ice pond depth + REAL(wp), POINTER, DIMENSION(:,:) :: hil !: now ice pond lid depth + END TYPE OBC_DATA + + !!---------------------------------------------------------------------- + !! Namelist variables + !!---------------------------------------------------------------------- + ! !!** nambdy ** + LOGICAL, PUBLIC :: ln_bdy !: Unstructured Ocean Boundary Condition + + CHARACTER(len=80), DIMENSION(jp_bdy) :: cn_coords_file !: Name of bdy coordinates file + CHARACTER(len=80) :: cn_mask_file !: Name of bdy mask file + ! + LOGICAL, DIMENSION(jp_bdy) :: ln_coords_file !: =T read bdy coordinates from file; + ! !: =F read bdy coordinates from namelist + LOGICAL :: ln_mask_file !: =T read bdymask from file + LOGICAL :: ln_vol !: =T volume correction + ! + INTEGER :: nb_bdy !: number of open boundary sets + INTEGER, DIMENSION(jp_bdy) :: nn_rimwidth !: boundary rim width for Flow Relaxation Scheme + INTEGER :: nn_volctl !: = 0 the total volume will have the variability of the surface Flux E-P + ! ! = 1 the volume will be constant during all the integration. + CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_dyn2d ! Choice of boundary condition for barotropic variables (U,V,SSH) + INTEGER, DIMENSION(jp_bdy) :: nn_dyn2d_dta !: = 0 use the initial state as bdy dta ; + !: = 1 read it in a NetCDF file + !: = 2 read tidal harmonic forcing from a NetCDF file + !: = 3 read external data AND tidal harmonic forcing from NetCDF files + CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_dyn3d ! Choice of boundary condition for baroclinic velocities + INTEGER, DIMENSION(jp_bdy) :: nn_dyn3d_dta !: = 0 use the initial state as bdy dta ; + !: = 1 read it in a NetCDF file + CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_tra ! Choice of boundary condition for active tracers (T and S) + INTEGER, DIMENSION(jp_bdy) :: nn_tra_dta !: = 0 use the initial state as bdy dta ; + !: = 1 read it in a NetCDF file + LOGICAL , DIMENSION(jp_bdy) :: ln_tra_dmp !: =T Tracer damping + LOGICAL , DIMENSION(jp_bdy) :: ln_dyn3d_dmp !: =T Baroclinic velocity damping + REAL(wp), DIMENSION(jp_bdy) :: rn_time_dmp !: Damping time scale in days + REAL(wp), DIMENSION(jp_bdy) :: rn_time_dmp_out !: Damping time scale in days at radiation outflow points + + CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_ice ! Choice of boundary condition for sea ice variables + INTEGER , DIMENSION(jp_bdy) :: nn_ice_dta !: = 0 use the initial state as bdy dta ; + !: = 1 read it in a NetCDF file + ! + ! !!** nambdy_dta ** + REAL(wp), DIMENSION(jp_bdy) :: rice_tem !: temperature of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_sal !: salinity of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_age !: age of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_apnd !: pond conc. of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_hpnd !: pond thick. of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_hlid !: pond lid thick. of incoming sea ice + ! + !!---------------------------------------------------------------------- + !! Global variables + !!---------------------------------------------------------------------- + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdytmask !: Mask defining computational domain at T-points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdyumask !: Mask defining computational domain at U-points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdyvmask !: Mask defining computational domain at V-points + + REAL(wp) :: bdysurftot !: Lateral surface of unstructured open boundary + + !!---------------------------------------------------------------------- + !! open boundary data variables + !!---------------------------------------------------------------------- + + INTEGER, DIMENSION(jp_bdy) :: nn_dta !: =0 => *all* data is set to initial conditions + !: =1 => some data to be read in from data files +!$AGRIF_DO_NOT_TREAT + TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET :: idx_bdy !: bdy indices (local process) + TYPE(OBC_DATA) , DIMENSION(jp_bdy), TARGET :: dta_bdy !: bdy external data (local process) +!$AGRIF_END_DO_NOT_TREAT + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyolr !: mark needed communication for given boundary, grid and neighbour + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyolr !: when searching in any direction (only for orlansky) + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyint !: mark needed communication for given boundary, grid and neighbour + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyint !: when searching towards the interior of the computational domain + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyext !: mark needed communication for given boundary, grid and neighbour + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyext !: when searching towards the exterior of the computational domain + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdy_oce.F90 15354 2021-10-12 13:44:46Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + FUNCTION bdy_oce_alloc() + !!---------------------------------------------------------------------- + USE lib_mpp, ONLY: ctl_stop, mpp_sum + ! + INTEGER :: bdy_oce_alloc + !!---------------------------------------------------------------------- + ! + ALLOCATE( bdytmask(jpi,jpj) , bdyumask(jpi,jpj), bdyvmask(jpi,jpj), & + & STAT=bdy_oce_alloc ) + ! + ! Initialize masks + bdytmask(:,:) = 1._wp + bdyumask(:,:) = 1._wp + bdyvmask(:,:) = 1._wp + ! + CALL mpp_sum ( 'bdy_oce', bdy_oce_alloc ) + IF( bdy_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'bdy_oce_alloc: failed to allocate arrays.' ) + ! + END FUNCTION bdy_oce_alloc + + !!====================================================================== +END MODULE bdy_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydta.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydta.f90 new file mode 100644 index 0000000000000000000000000000000000000000..750e55b30f7399a47f107cd7989e8f85b78d4c87 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydta.f90 @@ -0,0 +1,663 @@ + + + + + + + + + + + + + +MODULE bdydta + !!====================================================================== + !! *** MODULE bdydta *** + !! Open boundary data : read the data for the unstructured open boundaries. + !!====================================================================== + !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code + !! - ! 2007-01 (D. Storkey) Update to use IOM module + !! - ! 2007-07 (D. Storkey) add bdy_dta_fla + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.3 ! 2010-09 (E.O'Dea) modifications for Shelf configurations + !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !! 3.6 ! 2012-01 (C. Rousset) add ice boundary conditions for sea ice + !! 4.0 ! 2018 (C. Rousset) SI3 compatibility + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! bdy_dta : read external data along open boundaries from file + !! bdy_dta_init : initialise arrays etc for reading of external data + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbcapr ! atmospheric pressure forcing + USE tide_mod, ONLY: ln_tide ! tidal forcing + USE bdy_oce ! ocean open boundary conditions + USE bdytides ! tidal forcing at boundaries + ! + USE lib_mpp, ONLY: ctl_stop, ctl_nam + USE fldread ! read input fields + USE iom ! IOM library + USE in_out_manager ! I/O logical units + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_dta ! routine called by step.F90 and dynspg_ts.F90 + PUBLIC bdy_dta_init ! routine called by nemogcm.F90 + + INTEGER , PARAMETER :: jpbdyfld = 17 ! maximum number of files to read + INTEGER , PARAMETER :: jp_bdyssh = 1 ! + INTEGER , PARAMETER :: jp_bdyu2d = 2 ! + INTEGER , PARAMETER :: jp_bdyv2d = 3 ! + INTEGER , PARAMETER :: jp_bdyu3d = 4 ! + INTEGER , PARAMETER :: jp_bdyv3d = 5 ! + INTEGER , PARAMETER :: jp_bdytem = 6 ! + INTEGER , PARAMETER :: jp_bdysal = 7 ! + INTEGER , PARAMETER :: jp_bdya_i = 8 ! + INTEGER , PARAMETER :: jp_bdyh_i = 9 ! + INTEGER , PARAMETER :: jp_bdyh_s = 10 ! + INTEGER , PARAMETER :: jp_bdyt_i = 11 ! + INTEGER , PARAMETER :: jp_bdyt_s = 12 ! + INTEGER , PARAMETER :: jp_bdytsu = 13 ! + INTEGER , PARAMETER :: jp_bdys_i = 14 ! + INTEGER , PARAMETER :: jp_bdyaip = 15 ! + INTEGER , PARAMETER :: jp_bdyhip = 16 ! + INTEGER , PARAMETER :: jp_bdyhil = 17 ! + INTEGER , PARAMETER :: jpl = 1 + +!$AGRIF_DO_NOT_TREAT + TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:,:), TARGET :: bf ! structure of input fields (file informations, fields read) +!$AGRIF_END_DO_NOT_TREAT + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdydta.F90 15368 2021-10-14 08:25:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_dta( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dta *** + !! + !! ** Purpose : Update external data for open boundary conditions + !! + !! ** Method : Use fldread.F90 + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: jbdy, jfld, jstart, jend, ib, jl ! dummy loop indices + INTEGER :: ii, ij, ik, igrd, ipl ! local integers + TYPE(OBC_DATA) , POINTER :: dta_alias ! short cut + TYPE(FLD), DIMENSION(:), POINTER :: bf_alias + !!--------------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('bdy_dta') + ! + ! Initialise data arrays once for all from initial conditions where required + !--------------------------------------------------------------------------- + IF( kt == nit000 ) THEN + + ! Calculate depth-mean currents + !----------------------------- + + DO jbdy = 1, nb_bdy + ! + IF( nn_dyn2d_dta(jbdy) == 0 ) THEN + IF( dta_bdy(jbdy)%lneed_ssh ) THEN + igrd = 1 + DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd) ! ssh is allocated and used only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%ssh(ib) = ssh(ii,ij,Kmm) * tmask(ii,ij,1) + END DO + ENDIF + IF( ASSOCIATED(dta_bdy(jbdy)%u2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain + igrd = 2 + DO ib = 1, SIZE(dta_bdy(jbdy)%u2d) ! u2d is used either over the whole bdy or only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%u2d(ib) = uu_b(ii,ij,Kmm) * umask(ii,ij,1) + END DO + ENDIF + IF( ASSOCIATED(dta_bdy(jbdy)%v2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain + igrd = 3 + DO ib = 1, SIZE(dta_bdy(jbdy)%v2d) ! v2d is used either over the whole bdy or only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%v2d(ib) = vv_b(ii,ij,Kmm) * vmask(ii,ij,1) + END DO + ENDIF + ENDIF + ! + IF( nn_dyn3d_dta(jbdy) == 0 ) THEN + IF( dta_bdy(jbdy)%lneed_dyn3d ) THEN + igrd = 2 + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + DO ik = 1, jpkm1 + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%u3d(ib,ik) = ( uu(ii,ij,ik,Kmm) - uu_b(ii,ij,Kmm) ) * umask(ii,ij,ik) + END DO + END DO + igrd = 3 + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + DO ik = 1, jpkm1 + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%v3d(ib,ik) = ( vv(ii,ij,ik,Kmm) - vv_b(ii,ij,Kmm) ) * vmask(ii,ij,ik) + END DO + END DO + ENDIF + ENDIF + + IF( nn_tra_dta(jbdy) == 0 ) THEN + IF( dta_bdy(jbdy)%lneed_tra ) THEN + igrd = 1 + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + DO ik = 1, jpkm1 + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%tem(ib,ik) = ts(ii,ij,ik,jp_tem,Kmm) * tmask(ii,ij,ik) + dta_bdy(jbdy)%sal(ib,ik) = ts(ii,ij,ik,jp_sal,Kmm) * tmask(ii,ij,ik) + END DO + END DO + ENDIF + ENDIF + + END DO ! jbdy + ! + ENDIF ! kt == nit000 + + ! update external data from files + !-------------------------------- + + DO jbdy = 1, nb_bdy + + dta_alias => dta_bdy(jbdy) + bf_alias => bf(:,jbdy) + + ! read/update all bdy data + ! ------------------------ + ! BDY: use pt_offset=0.5 as applied at the end of the step and fldread is referenced at the middle of the step + CALL fld_read( kt, 1, bf_alias, pt_offset = 0.5_wp, Kmm = Kmm ) + ! apply some corrections in some specific cases... + ! -------------------------------------------------- + ! + ! if runoff condition: change river flow we read (in m3/s) into barotropic velocity (m/s) + IF( cn_tra(jbdy) == 'runoff' ) THEN ! runoff + ! + IF( ASSOCIATED(dta_bdy(jbdy)%u2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain + igrd = 2 ! zonal flow (m3/s) to barotropic zonal velocity (m/s) + DO ib = 1, SIZE(dta_alias%u2d) ! u2d is used either over the whole bdy or only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_alias%u2d(ib) = dta_alias%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) + END DO + ENDIF + IF( ASSOCIATED(dta_bdy(jbdy)%v2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain + igrd = 3 ! meridional flow (m3/s) to barotropic meridional velocity (m/s) + DO ib = 1, SIZE(dta_alias%v2d) ! v2d is used either over the whole bdy or only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_alias%v2d(ib) = dta_alias%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) + END DO + ENDIF + ENDIF + + ! tidal harmonic forcing ONLY: initialise arrays + IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! we did not read ssh, u/v2d + IF( ASSOCIATED(dta_alias%ssh) ) dta_alias%ssh(:) = 0._wp + IF( ASSOCIATED(dta_alias%u2d) ) dta_alias%u2d(:) = 0._wp + IF( ASSOCIATED(dta_alias%v2d) ) dta_alias%v2d(:) = 0._wp + ENDIF + + ! If full velocities in boundary data, then split it into barotropic and baroclinic component + IF( bf_alias(jp_bdyu3d)%ltotvel ) THEN ! if we read 3D total velocity (can be true only if u3d was read) + igrd = 2 ! zonal velocity + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_alias%u2d(ib) = 0._wp ! compute barotrope zonal velocity and put it in u2d + DO ik = 1, jpkm1 + dta_alias%u2d(ib) = dta_alias%u2d(ib) & + & + (e3u_0(ii,ij,ik)*(1._wp+r3u(ii,ij,Kmm)*umask(ii,ij,ik))) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik) + END DO + dta_alias%u2d(ib) = dta_alias%u2d(ib) * (r1_hu_0(ii,ij)/(1._wp+r3u(ii,ij,Kmm))) + DO ik = 1, jpkm1 ! compute barocline zonal velocity and put it in u3d + dta_alias%u3d(ib,ik) = dta_alias%u3d(ib,ik) - dta_alias%u2d(ib) + END DO + END DO + ENDIF ! ltotvel + IF( bf_alias(jp_bdyv3d)%ltotvel ) THEN ! if we read 3D total velocity (can be true only if v3d was read) + igrd = 3 ! meridional velocity + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_alias%v2d(ib) = 0._wp ! compute barotrope meridional velocity and put it in v2d + DO ik = 1, jpkm1 + dta_alias%v2d(ib) = dta_alias%v2d(ib) & + & + (e3v_0(ii,ij,ik)*(1._wp+r3v(ii,ij,Kmm)*vmask(ii,ij,ik))) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik) + END DO + dta_alias%v2d(ib) = dta_alias%v2d(ib) * (r1_hv_0(ii,ij)/(1._wp+r3v(ii,ij,Kmm))) + DO ik = 1, jpkm1 ! compute barocline meridional velocity and put it in v3d + dta_alias%v3d(ib,ik) = dta_alias%v3d(ib,ik) - dta_alias%v2d(ib) + END DO + END DO + ENDIF ! ltotvel + + ! atm surface pressure : add inverted barometer effect to ssh if it was read + IF ( ln_apr_obc .AND. TRIM(bf_alias(jp_bdyssh)%clrootname) /= 'NOT USED' ) THEN + igrd = 1 + DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd) ! ssh is used only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_alias%ssh(ib) = dta_alias%ssh(ib) + ssh_ib(ii,ij) + END DO + ENDIF + + END DO ! jbdy + + IF ( ln_tide ) THEN + IF (ln_dynspg_ts) THEN ! Fill temporary arrays with slow-varying bdy data + DO jbdy = 1, nb_bdy ! Tidal component added in ts loop + IF ( nn_dyn2d_dta(jbdy) .GE. 2 ) THEN + IF( ASSOCIATED(dta_bdy(jbdy)%ssh) ) dta_bdy_s(jbdy)%ssh(:) = dta_bdy(jbdy)%ssh(:) + IF( ASSOCIATED(dta_bdy(jbdy)%u2d) ) dta_bdy_s(jbdy)%u2d(:) = dta_bdy(jbdy)%u2d(:) + IF( ASSOCIATED(dta_bdy(jbdy)%v2d) ) dta_bdy_s(jbdy)%v2d(:) = dta_bdy(jbdy)%v2d(:) + ENDIF + END DO + ELSE ! Add tides if not split-explicit free surface else this is done in ts loop + ! + CALL bdy_dta_tides( kt=kt, pt_offset = 1._wp ) + ENDIF + ENDIF + ! + IF( ln_timing ) CALL timing_stop('bdy_dta') + ! + END SUBROUTINE bdy_dta + + + SUBROUTINE bdy_dta_init + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dta_init *** + !! + !! ** Purpose : Initialise arrays for reading of external data + !! for open boundary conditions + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER :: jbdy, jfld ! Local integers + INTEGER :: ierror, ios ! + ! + INTEGER :: nbdy_rdstart, nbdy_loc + CHARACTER(LEN=50) :: cerrmsg ! error string + CHARACTER(len=3) :: cl3 ! + CHARACTER(len=100) :: cn_dir ! Root directory for location of data files + LOGICAL :: ln_full_vel ! =T => full velocities in 3D boundary data + ! ! =F => baroclinic velocities in 3D boundary data + LOGICAL :: ln_zinterp ! =T => requires a vertical interpolation of the bdydta + REAL(wp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid + INTEGER :: ipk,ipl ! + INTEGER :: idvar ! variable ID + INTEGER :: indims ! number of dimensions of the variable + INTEGER :: iszdim ! number of dimensions of the variable + INTEGER, DIMENSION(4) :: i4dimsz ! size of variable dimensions + INTEGER :: igrd ! index for grid type (1,2,3 = T,U,V) + LOGICAL :: lluld ! is the variable using the unlimited dimension + LOGICAL :: llneed ! + LOGICAL :: llread ! + LOGICAL :: llfullbdy ! + TYPE(FLD_N), DIMENSION(1), TARGET :: bn_tem, bn_sal, bn_u3d, bn_v3d ! must be an array to be used with fld_fill + TYPE(FLD_N), DIMENSION(1), TARGET :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read + TYPE(FLD_N), DIMENSION(1), TARGET :: bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil + TYPE(FLD_N), DIMENSION(:), POINTER :: bn_alias ! must be an array to be used with fld_fill + TYPE(FLD ), DIMENSION(:), POINTER :: bf_alias + ! + NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d, & + & bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil, & + & rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid, & + & ln_full_vel, ln_zinterp + !!--------------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'bdy_dta_ini : initialization of data at the open boundaries' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + IF(lwp) WRITE(numout,*) '' + + ALLOCATE( bf(jpbdyfld,nb_bdy), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'bdy_dta: unable to allocate bf structure' ) ; RETURN + ENDIF + bf(:,:)%clrootname = 'NOT USED' ! default definition used as a flag in fld_read to do nothing. + bf(:,:)%lzint = .FALSE. ! default definition + bf(:,:)%ltotvel = .FALSE. ! default definition + + ! Read namelists + ! -------------- + nbdy_rdstart = 1 + DO jbdy = 1, nb_bdy + + WRITE(ctmp1, '(a,i2)') 'BDY number ', jbdy + WRITE(ctmp2, '(a,i2)') 'block nambdy_dta number ', jbdy + + ! There is only one nambdy_dta block in namelist_ref -> use it for each bdy so we read from the beginning + READ ( numnam_ref, nambdy_dta, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_dta in reference namelist' ) + + ! by-pass nambdy_dta reading if no input data used in this bdy + IF( ( dta_bdy(jbdy)%lneed_dyn2d .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ) & + & .OR. ( dta_bdy(jbdy)%lneed_dyn3d .AND. nn_dyn3d_dta(jbdy) == 1 ) & + & .OR. ( dta_bdy(jbdy)%lneed_tra .AND. nn_tra_dta(jbdy) == 1 ) & + & .OR. ( dta_bdy(jbdy)%lneed_ice .AND. nn_ice_dta(jbdy) == 1 ) ) THEN + ! + ! Need to support possibility of reading more than one + ! nambdy_dta from the namelist_cfg internal file. + ! Do this by finding the jbdy'th occurence of nambdy_dta in the + ! character buffer as the starting point. + ! + nbdy_loc = INDEX( numnam_cfg( nbdy_rdstart: ), 'nambdy_dta' ) + IF( nbdy_loc .GT. 0 ) THEN + nbdy_rdstart = nbdy_rdstart + nbdy_loc + ELSE + WRITE(cerrmsg,'(A,I4,A)') 'Error: entry number ',jbdy,' of nambdy_dta not found' + ios = -1 + CALL ctl_nam ( ios , cerrmsg ) + ENDIF + READ ( numnam_cfg( MAX( 1, nbdy_rdstart - 2 ): ), nambdy_dta, IOSTAT = ios, ERR = 902) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_dta in configuration namelist' ) + IF(lwm) WRITE( numond, nambdy_dta ) + ENDIF + + ! get the number of ice categories in bdy data file (use a_i information to do this) + ipl = jpl ! default definition + IF( dta_bdy(jbdy)%lneed_ice ) THEN ! if we need ice bdy data + IF( nn_ice_dta(jbdy) == 1 ) THEN ! if we get ice bdy data from netcdf file + CALL fld_fill( bf(jp_bdya_i,jbdy:jbdy), bn_a_i, cn_dir, 'bdy_dta', 'a_i'//' '//ctmp1, ctmp2 ) ! use namelist info + CALL fld_def( bf(jp_bdya_i,jbdy) ) + CALL iom_open( bf(jp_bdya_i,jbdy)%clname, bf(jp_bdya_i,jbdy)%num ) + idvar = iom_varid( bf(jp_bdya_i,jbdy)%num, bf(jp_bdya_i,jbdy)%clvar, kndims=indims, kdimsz=i4dimsz, lduld=lluld ) + IF( indims == 4 .OR. ( indims == 3 .AND. .NOT. lluld ) ) THEN ; ipl = i4dimsz(3) ! xylt or xyl + ELSE ; ipl = 1 ! xy or xyt + ENDIF + CALL iom_close( bf(jp_bdya_i,jbdy)%num ) + bf(jp_bdya_i,jbdy)%clrootname = 'NOT USED' ! reset to default value as this subdomain may not need to read this bdy + ENDIF + ENDIF + + + ! temp, salt, age and ponds of incoming ice + rice_tem (jbdy) = rn_ice_tem + rice_sal (jbdy) = rn_ice_sal + rice_age (jbdy) = rn_ice_age + rice_apnd(jbdy) = rn_ice_apnd + rice_hpnd(jbdy) = rn_ice_hpnd + rice_hlid(jbdy) = rn_ice_hlid + + + DO jfld = 1, jpbdyfld + + ! ===================== + ! ssh + ! ===================== + IF( jfld == jp_bdyssh ) THEN + cl3 = 'ssh' + igrd = 1 ! T point + ipk = 1 ! surface data + llneed = dta_bdy(jbdy)%lneed_ssh ! dta_bdy(jbdy)%ssh will be needed + llread = MOD(nn_dyn2d_dta(jbdy),2) == 1 ! get data from NetCDF file + bf_alias => bf(jp_bdyssh,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy + bn_alias => bn_ssh ! alias for ssh structure of nambdy_dta + iszdim = idx_bdy(jbdy)%nblenrim(igrd) ! length of this bdy on this MPI processus : used only on the rim + ENDIF + ! ===================== + ! dyn2d + ! ===================== + IF( jfld == jp_bdyu2d ) THEN + cl3 = 'u2d' + igrd = 2 ! U point + ipk = 1 ! surface data + llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%u2d will be needed + llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ! don't get u2d from u3d and read NetCDF file + bf_alias => bf(jp_bdyu2d,jbdy:jbdy) ! alias for u2d structure of bdy number jbdy + bn_alias => bn_u2d ! alias for u2d structure of nambdy_dta + llfullbdy = ln_full_vel .OR. cn_dyn2d(jbdy) == 'frs' ! need u2d over the whole bdy or only over the rim? + IF( llfullbdy ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd) + ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd) + ENDIF + ENDIF + IF( jfld == jp_bdyv2d ) THEN + cl3 = 'v2d' + igrd = 3 ! V point + ipk = 1 ! surface data + llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%v2d will be needed + llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ! don't get v2d from v3d and read NetCDF file + bf_alias => bf(jp_bdyv2d,jbdy:jbdy) ! alias for v2d structure of bdy number jbdy + bn_alias => bn_v2d ! alias for v2d structure of nambdy_dta + llfullbdy = ln_full_vel .OR. cn_dyn2d(jbdy) == 'frs' ! need v2d over the whole bdy or only over the rim? + IF( llfullbdy ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd) + ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd) + ENDIF + ENDIF + ! ===================== + ! dyn3d + ! ===================== + IF( jfld == jp_bdyu3d ) THEN + cl3 = 'u3d' + igrd = 2 ! U point + ipk = jpk ! 3d data + llneed = dta_bdy(jbdy)%lneed_dyn3d .OR. & ! dta_bdy(jbdy)%u3d will be needed + & ( dta_bdy(jbdy)%lneed_dyn2d .AND. ln_full_vel ) ! u3d needed to compute u2d + llread = nn_dyn3d_dta(jbdy) == 1 ! get data from NetCDF file + bf_alias => bf(jp_bdyu3d,jbdy:jbdy) ! alias for u3d structure of bdy number jbdy + bn_alias => bn_u3d ! alias for u3d structure of nambdy_dta + iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus + ENDIF + IF( jfld == jp_bdyv3d ) THEN + cl3 = 'v3d' + igrd = 3 ! V point + ipk = jpk ! 3d data + llneed = dta_bdy(jbdy)%lneed_dyn3d .OR. & ! dta_bdy(jbdy)%v3d will be needed + & ( dta_bdy(jbdy)%lneed_dyn2d .AND. ln_full_vel ) ! v3d needed to compute v2d + llread = nn_dyn3d_dta(jbdy) == 1 ! get data from NetCDF file + bf_alias => bf(jp_bdyv3d,jbdy:jbdy) ! alias for v3d structure of bdy number jbdy + bn_alias => bn_v3d ! alias for v3d structure of nambdy_dta + iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus + ENDIF + + ! ===================== + ! tra + ! ===================== + IF( jfld == jp_bdytem ) THEN + cl3 = 'tem' + igrd = 1 ! T point + ipk = jpk ! 3d data + llneed = dta_bdy(jbdy)%lneed_tra ! dta_bdy(jbdy)%tem will be needed + llread = nn_tra_dta(jbdy) == 1 ! get data from NetCDF file + bf_alias => bf(jp_bdytem,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy + bn_alias => bn_tem ! alias for ssh structure of nambdy_dta + iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus + ENDIF + IF( jfld == jp_bdysal ) THEN + cl3 = 'sal' + igrd = 1 ! T point + ipk = jpk ! 3d data + llneed = dta_bdy(jbdy)%lneed_tra ! dta_bdy(jbdy)%sal will be needed + llread = nn_tra_dta(jbdy) == 1 ! get data from NetCDF file + bf_alias => bf(jp_bdysal,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy + bn_alias => bn_sal ! alias for ssh structure of nambdy_dta + iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus + ENDIF + + ! ===================== + ! ice + ! ===================== + IF( jfld == jp_bdya_i .OR. jfld == jp_bdyh_i .OR. jfld == jp_bdyh_s .OR. & + & jfld == jp_bdyt_i .OR. jfld == jp_bdyt_s .OR. jfld == jp_bdytsu .OR. & + & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip .OR. jfld == jp_bdyhil ) THEN + igrd = 1 ! T point + ipk = ipl ! jpl-cat data + llneed = dta_bdy(jbdy)%lneed_ice ! ice will be needed + llread = nn_ice_dta(jbdy) == 1 ! get data from NetCDF file + iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus + ENDIF + IF( jfld == jp_bdya_i ) THEN + cl3 = 'a_i' + bf_alias => bf(jp_bdya_i,jbdy:jbdy) ! alias for a_i structure of bdy number jbdy + bn_alias => bn_a_i ! alias for a_i structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyh_i ) THEN + cl3 = 'h_i' + bf_alias => bf(jp_bdyh_i,jbdy:jbdy) ! alias for h_i structure of bdy number jbdy + bn_alias => bn_h_i ! alias for h_i structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyh_s ) THEN + cl3 = 'h_s' + bf_alias => bf(jp_bdyh_s,jbdy:jbdy) ! alias for h_s structure of bdy number jbdy + bn_alias => bn_h_s ! alias for h_s structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyt_i ) THEN + cl3 = 't_i' + bf_alias => bf(jp_bdyt_i,jbdy:jbdy) ! alias for t_i structure of bdy number jbdy + bn_alias => bn_t_i ! alias for t_i structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyt_s ) THEN + cl3 = 't_s' + bf_alias => bf(jp_bdyt_s,jbdy:jbdy) ! alias for t_s structure of bdy number jbdy + bn_alias => bn_t_s ! alias for t_s structure of nambdy_dta + ENDIF + IF( jfld == jp_bdytsu ) THEN + cl3 = 'tsu' + bf_alias => bf(jp_bdytsu,jbdy:jbdy) ! alias for tsu structure of bdy number jbdy + bn_alias => bn_tsu ! alias for tsu structure of nambdy_dta + ENDIF + IF( jfld == jp_bdys_i ) THEN + cl3 = 's_i' + bf_alias => bf(jp_bdys_i,jbdy:jbdy) ! alias for s_i structure of bdy number jbdy + bn_alias => bn_s_i ! alias for s_i structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyaip ) THEN + cl3 = 'aip' + bf_alias => bf(jp_bdyaip,jbdy:jbdy) ! alias for aip structure of bdy number jbdy + bn_alias => bn_aip ! alias for aip structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyhip ) THEN + cl3 = 'hip' + bf_alias => bf(jp_bdyhip,jbdy:jbdy) ! alias for hip structure of bdy number jbdy + bn_alias => bn_hip ! alias for hip structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyhil ) THEN + cl3 = 'hil' + bf_alias => bf(jp_bdyhil,jbdy:jbdy) ! alias for hil structure of bdy number jbdy + bn_alias => bn_hil ! alias for hil structure of nambdy_dta + ENDIF + + IF( llneed .AND. iszdim > 0 ) THEN ! dta_bdy(jbdy)%xxx will be needed + ! ! -> must be associated with an allocated target + ALLOCATE( bf_alias(1)%fnow( iszdim, 1, ipk ) ) ! allocate the target + ! + IF( llread ) THEN ! get data from NetCDF file + CALL fld_fill( bf_alias, bn_alias, cn_dir, 'bdy_dta', cl3//' '//ctmp1, ctmp2 ) ! use namelist info + IF( bf_alias(1)%ln_tint ) ALLOCATE( bf_alias(1)%fdta( iszdim, 1, ipk, 2 ) ) + bf_alias(1)%imap => idx_bdy(jbdy)%nbmap(1:iszdim,igrd) ! associate the mapping used for this bdy + bf_alias(1)%igrd = igrd ! used only for vertical integration of 3D arrays + bf_alias(1)%ibdy = jbdy ! " " " " " " " " + bf_alias(1)%ltotvel = ln_full_vel ! T if u3d is full velocity + bf_alias(1)%lzint = ln_zinterp ! T if it requires a vertical interpolation + ENDIF + + ! associate the pointer and get rid of the dimensions with a size equal to 1 + IF( jfld == jp_bdyssh ) dta_bdy(jbdy)%ssh => bf_alias(1)%fnow(:,1,1) + IF( jfld == jp_bdyu2d ) dta_bdy(jbdy)%u2d => bf_alias(1)%fnow(:,1,1) + IF( jfld == jp_bdyv2d ) dta_bdy(jbdy)%v2d => bf_alias(1)%fnow(:,1,1) + IF( jfld == jp_bdyu3d ) dta_bdy(jbdy)%u3d => bf_alias(1)%fnow(:,1,:) + IF( jfld == jp_bdyv3d ) dta_bdy(jbdy)%v3d => bf_alias(1)%fnow(:,1,:) + IF( jfld == jp_bdytem ) dta_bdy(jbdy)%tem => bf_alias(1)%fnow(:,1,:) + IF( jfld == jp_bdysal ) dta_bdy(jbdy)%sal => bf_alias(1)%fnow(:,1,:) + IF( jfld == jp_bdya_i ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%a_i => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%a_i(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyh_i ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%h_i => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%h_i(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyh_s ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%h_s => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%h_s(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyt_i ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%t_i => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%t_i(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyt_s ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%t_s => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%t_s(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdytsu ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%tsu => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%tsu(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdys_i ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%s_i => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%s_i(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyaip ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%aip => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%aip(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyhip ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%hip => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%hip(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyhil ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%hil => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%hil(iszdim,jpl) ) + ENDIF + ENDIF + ENDIF + + END DO ! jpbdyfld + ! + END DO ! jbdy + ! + END SUBROUTINE bdy_dta_init + + !!============================================================================== +END MODULE bdydta diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydyn.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydyn.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7a769f34a860bd6ed294761d9f7e5924437e7505 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydyn.f90 @@ -0,0 +1,151 @@ + + + + + + + + + + + + + +MODULE bdydyn + !!====================================================================== + !! *** MODULE bdydyn *** + !! Unstructured Open Boundary Cond. : Apply boundary conditions to velocities + !!====================================================================== + !! History : 1.0 ! 2005-02 (J. Chanut, A. Sellar) Original code + !! - ! 2007-07 (D. Storkey) Move Flather implementation to separate routine. + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.2 ! 2008-04 (R. Benshila) consider velocity instead of transport + !! 3.3 ! 2010-09 (E.O'Dea) modifications for Shelf configurations + !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !!---------------------------------------------------------------------- + !! bdy_dyn : split velocities into barotropic and baroclinic parts + !! and call bdy_dyn2d and bdy_dyn3d to apply boundary + !! conditions + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE bdy_oce ! ocean open boundary conditions + USE bdydyn2d ! open boundary conditions for barotropic solution + USE bdydyn3d ! open boundary conditions for baroclinic velocities + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! + USE domvvl ! variable volume + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_dyn ! routine called in dyn_nxt + + !! * Substitutions +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdydyn.F90 13237 2020-07-03 09:12:53Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_dyn( kt, Kbb, puu, pvv, Kaa, dyn3d_only ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn *** + !! + !! ** Purpose : - Wrapper routine for bdy_dyn2d and bdy_dyn3d. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! Main time step counter + INTEGER , INTENT(in) :: Kbb, Kaa ! Ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + LOGICAL, OPTIONAL , INTENT(in) :: dyn3d_only ! T => only update baroclinic velocities + ! + INTEGER :: jk, ii, ij, ib_bdy, ib, igrd ! Loop counter + LOGICAL :: ll_dyn2d, ll_dyn3d, ll_orlanski + REAL(wp), DIMENSION(jpi,jpj) :: zua2d, zva2d ! after barotropic velocities + !!---------------------------------------------------------------------- + ! + ll_dyn2d = .true. + ll_dyn3d = .true. + ! + IF( PRESENT(dyn3d_only) ) THEN + IF( dyn3d_only ) ll_dyn2d = .false. + ENDIF + ! + ll_orlanski = .false. + DO ib_bdy = 1, nb_bdy + IF ( cn_dyn2d(ib_bdy) == 'orlanski' .OR. cn_dyn2d(ib_bdy) == 'orlanski_npo' & + & .OR. cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo') ll_orlanski = .true. + END DO + + !------------------------------------------------------- + ! Split velocities into barotropic and baroclinic parts + !------------------------------------------------------- + + ! ! "After" velocities: + zua2d(:,:) = 0._wp + zva2d(:,:) = 0._wp + DO jk = 1, jpkm1 + zua2d(:,:) = zua2d(:,:) + (e3u_0(:,:,jk)*(1._wp+r3u(:,:,Kaa)*umask(:,:,jk))) * puu(:,:,jk,Kaa) * umask(:,:,jk) + zva2d(:,:) = zva2d(:,:) + (e3v_0(:,:,jk)*(1._wp+r3v(:,:,Kaa)*vmask(:,:,jk))) * pvv(:,:,jk,Kaa) * vmask(:,:,jk) + END DO + zua2d(:,:) = zua2d(:,:) * (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kaa))) + zva2d(:,:) = zva2d(:,:) * (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kaa))) + + DO jk = 1 , jpkm1 + puu(:,:,jk,Kaa) = ( puu(:,:,jk,Kaa) - zua2d(:,:) ) * umask(:,:,jk) + pvv(:,:,jk,Kaa) = ( pvv(:,:,jk,Kaa) - zva2d(:,:) ) * vmask(:,:,jk) + END DO + + + IF( ll_orlanski ) THEN ! "Before" velocities (Orlanski condition only) + DO jk = 1 , jpkm1 + puu(:,:,jk,Kbb) = ( puu(:,:,jk,Kbb) - uu_b(:,:,Kbb) ) * umask(:,:,jk) + pvv(:,:,jk,Kbb) = ( pvv(:,:,jk,Kbb) - vv_b(:,:,Kbb) ) * vmask(:,:,jk) + END DO + ENDIF + + !------------------------------------------------------- + ! Apply boundary conditions to barotropic and baroclinic + ! parts separately + !------------------------------------------------------- + + IF( ll_dyn2d ) CALL bdy_dyn2d( kt, zua2d, zva2d, uu_b(:,:,Kbb), vv_b(:,:,Kbb), (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kaa))), (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kaa))), ssh(:,:,Kaa) ) + + IF( ll_dyn3d ) CALL bdy_dyn3d( kt, Kbb, puu, pvv, Kaa ) + + !------------------------------------------------------- + ! Recombine velocities + !------------------------------------------------------- + ! + DO jk = 1 , jpkm1 + puu(:,:,jk,Kaa) = ( puu(:,:,jk,Kaa) + zua2d(:,:) ) * umask(:,:,jk) + pvv(:,:,jk,Kaa) = ( pvv(:,:,jk,Kaa) + zva2d(:,:) ) * vmask(:,:,jk) + END DO + ! + IF ( ll_orlanski ) THEN + DO jk = 1 , jpkm1 + puu(:,:,jk,Kbb) = ( puu(:,:,jk,Kbb) + uu_b(:,:,Kbb) ) * umask(:,:,jk) + pvv(:,:,jk,Kbb) = ( pvv(:,:,jk,Kbb) + vv_b(:,:,Kbb) ) * vmask(:,:,jk) + END DO + END IF + ! + END SUBROUTINE bdy_dyn + + !!====================================================================== +END MODULE bdydyn diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydyn2d.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydyn2d.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e0830165c85bc261eb65556b973dfbc160257272 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydyn2d.f90 @@ -0,0 +1,356 @@ + + + + + + + + + + + + + +MODULE bdydyn2d + !!====================================================================== + !! *** MODULE bdydyn *** + !! Unstructured Open Boundary Cond. : Apply boundary conditions to barotropic solution + !!====================================================================== + !! History : 3.4 ! 2011 (D. Storkey) new module as part of BDY rewrite + !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) Optimization of BDY communications + !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes + !!---------------------------------------------------------------------- + !! bdy_dyn2d : Apply open boundary conditions to barotropic variables. + !! bdy_dyn2d_frs : Apply Flow Relaxation Scheme + !! bdy_dyn2d_fla : Apply Flather condition + !! bdy_dyn2d_orlanski : Orlanski Radiation + !! bdy_ssh : Duplicate sea level across open boundaries + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE bdy_oce ! ocean open boundary conditions + USE bdylib ! BDY library routines + USE phycst ! physical constants + USE lib_mpp + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE wet_dry ! Use wet dry to get reference ssh level + USE in_out_manager ! + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_dyn2d ! routine called in dynspg_ts and bdy_dyn + PUBLIC bdy_ssh ! routine called in dynspg_ts or sshwzv + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdydyn2d.F90 15368 2021-10-14 08:25:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_dyn2d( kt, pua2d, pva2d, pub2d, pvb2d, phur, phvr, pssh ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn2d *** + !! + !! ** Purpose : - Apply open boundary conditions for barotropic variables + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! Main time step counter + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pub2d, pvb2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: phur, phvr + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh + !! + INTEGER :: ib_bdy, ir ! BDY set index, rim index + INTEGER, DIMENSION(3) :: idir3 + INTEGER, DIMENSION(6) :: idir6 + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(8) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out + !!---------------------------------------------------------------------- + + llsend2(:) = .false. ; llrecv2(:) = .false. + llsend3(:) = .false. ; llrecv3(:) = .false. + DO ir = 1, 0, -1 ! treat rim 1 before rim 0 + IF( ir == 0 ) THEN ; llrim0 = .TRUE. + ELSE ; llrim0 = .FALSE. + END IF + DO ib_bdy=1, nb_bdy + SELECT CASE( cn_dyn2d(ib_bdy) ) + CASE('none') + CYCLE + CASE('frs') ! treat the whole boundary at once + IF( llrim0 ) CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d ) + CASE('flather') + CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) + CASE('orlanski') + CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & + & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.false. ) + CASE('orlanski_npo') + CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & + & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.true. ) + CASE DEFAULT + CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) + END SELECT + ENDDO + ! + IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 + IF( nn_hls == 1 ) THEN + llsend2(:) = .false. ; llrecv2(:) = .false. + llsend3(:) = .false. ; llrecv3(:) = .false. + END IF + DO ib_bdy=1, nb_bdy + SELECT CASE( cn_dyn2d(ib_bdy) ) + CASE('flather') + idir6 = (/ jpwe, jpea, jpsw, jpse, jpnw, jpne /) + llsend2(idir6) = llsend2(idir6) .OR. lsend_bdyint(ib_bdy,2,idir6,ir) ! west/east, U points + idir3 = (/ jpwe, jpsw, jpnw /) + llsend2(idir3) = llsend2(idir3) .OR. lsend_bdyext(ib_bdy,2,idir3,ir) ! nei might search point towards its east bdy + llrecv2(idir6) = llrecv2(idir6) .OR. lrecv_bdyint(ib_bdy,2,idir6,ir) ! west/east, U points + idir3 = (/ jpea, jpse, jpne /) + llrecv2(idir3) = llrecv2(idir3) .OR. lrecv_bdyext(ib_bdy,2,idir3,ir) ! might search point towards bdy on the east + idir6 = (/ jpso, jpno, jpsw, jpse, jpnw, jpne /) + llsend3(idir6) = llsend3(idir6) .OR. lsend_bdyint(ib_bdy,3,idir6,ir) ! north/south, V points + idir3 = (/ jpso, jpsw, jpse /) + llsend3(idir3) = llsend3(idir3) .OR. lsend_bdyext(ib_bdy,3,idir3,ir) ! nei might search point towards its north bdy + llrecv3(idir6) = llrecv3(idir6) .OR. lrecv_bdyint(ib_bdy,3,idir6,ir) ! north/south, V points + idir3 = (/ jpno, jpnw, jpne /) + llrecv3(idir3) = llrecv3(idir3) .OR. lrecv_bdyext(ib_bdy,3,idir3,ir) ! might search point towards bdy on the north + CASE('orlanski', 'orlanski_npo') + llsend2(:) = llsend2(:) .OR. lsend_bdyolr(ib_bdy,2,:,ir) ! possibly every direction, U points + llrecv2(:) = llrecv2(:) .OR. lrecv_bdyolr(ib_bdy,2,:,ir) ! possibly every direction, U points + llsend3(:) = llsend3(:) .OR. lsend_bdyolr(ib_bdy,3,:,ir) ! possibly every direction, V points + llrecv3(:) = llrecv3(:) .OR. lrecv_bdyolr(ib_bdy,3,:,ir) ! possibly every direction, V points + END SELECT + END DO + IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) + END IF + IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) + END IF + ! + END DO ! ir + ! + END SUBROUTINE bdy_dyn2d + + SUBROUTINE bdy_dyn2d_frs( idx, dta, ib_bdy, pua2d, pva2d ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn2d_frs *** + !! + !! ** Purpose : - Apply the Flow Relaxation Scheme for barotropic velocities + !! at open boundaries. + !! + !! References :- Engedahl H., 1995: Use of the flow relaxation scheme in + !! a three-dimensional baroclinic ocean model with realistic + !! topography. Tellus, 365-382. + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data + INTEGER, INTENT(in) :: ib_bdy ! BDY set index + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + !! + INTEGER :: jb ! dummy loop indices + INTEGER :: ii, ij, igrd ! local integers + REAL(wp) :: zwgt ! boundary weight + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Relaxation of zonal velocity + DO jb = 1, idx%nblen(igrd) + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + zwgt = idx%nbw(jb,igrd) + pua2d(ii,ij) = ( pua2d(ii,ij) + zwgt * ( dta%u2d(jb) - pua2d(ii,ij) ) ) * umask(ii,ij,1) + END DO + ! + igrd = 3 ! Relaxation of meridional velocity + DO jb = 1, idx%nblen(igrd) + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + zwgt = idx%nbw(jb,igrd) + pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1) + END DO + ! + END SUBROUTINE bdy_dyn2d_frs + + + SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn2d_fla *** + !! + !! - Apply Flather boundary conditions on normal barotropic velocities + !! + !! ** WARNINGS about FLATHER implementation: + !!1. According to Palma and Matano, 1998 "after ssh" is used. + !! In ROMS and POM implementations, it is "now ssh". In the current + !! implementation (tested only in the EEL-R5 conf.), both cases were unstable. + !! So I use "before ssh" in the following. + !! + !!2. We assume that the normal ssh gradient at the bdy is zero. As a matter of + !! fact, the model ssh just inside the dynamical boundary is used (the outside + !! ssh in the code is not updated). + !! + !! References: Flather, R. A., 1976: A tidal model of the northwest European + !! continental shelf. Mem. Soc. R. Sci. Liege, Ser. 6,10, 141-164. + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data + INTEGER, INTENT(in) :: ib_bdy ! BDY set index + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phur, phvr + REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pssh + LOGICAL , INTENT(in) :: llrim0 ! indicate if rim 0 is treated + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) + INTEGER :: jb, igrd ! dummy loop indices + INTEGER :: ii, ij ! 2D addresses + INTEGER :: iiTrim, ijTrim ! T pts i/j-indice on the rim + INTEGER :: iiToce, ijToce, iiUoce, ijVoce ! T, U and V pts i/j-indice of the ocean next to the rim + REAL(wp) :: flagu, flagv ! short cuts + REAL(wp) :: zfla ! Flather correction + REAL(wp) :: z1_2 ! + REAL(wp), DIMENSION(jpi,jpj) :: sshdta ! 2D version of dta%ssh + !!---------------------------------------------------------------------- + + z1_2 = 0.5_wp + + ! ---------------------------------! + ! Flather boundary conditions :! + ! ---------------------------------! + + ! Fill temporary array with ssh data (here we use spgu with the alias sshdta): + igrd = 1 + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) + END IF + ! + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + IF( ll_wd ) THEN ; sshdta(ii, ij) = dta%ssh(jb) - ssh_ref + ELSE ; sshdta(ii, ij) = dta%ssh(jb) + ENDIF + END DO + ! + igrd = 2 ! Flather bc on u-velocity + ! ! remember that flagu=-1 if normal velocity direction is outward + ! ! I think we should rather use after ssh ? + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) + END IF + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + flagu = idx%flagu(jb,igrd) + IF( flagu == 0. ) THEN + pua2d(ii,ij) = dta%u2d(jb) + ELSE ! T pts j-indice on the rim on the ocean next to the rim on T and U points + IF( flagu == 1. ) THEN ; iiTrim = ii ; iiToce = ii+1 ; iiUoce = ii+1 ; ENDIF + IF( flagu == -1. ) THEN ; iiTrim = ii+1 ; iiToce = ii ; iiUoce = ii-1 ; ENDIF + ! + ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received + IF( iiTrim > jpi .OR. iiToce > jpi .OR. iiUoce > jpi .OR. iiUoce < 1 ) CYCLE + ! + zfla = dta%u2d(jb) - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iiToce,ij) - sshdta(iiTrim,ij) ) + ! + ! jchanut tschanges, use characteristics method (Blayo et Debreu, 2005) : + ! mix Flather scheme with velocity of the ocean next to the rim + pua2d(ii,ij) = z1_2 * ( pua2d(iiUoce,ij) + zfla ) + END IF + END DO + ! + igrd = 3 ! Flather bc on v-velocity + ! ! remember that flagv=-1 if normal velocity direction is outward + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) + END IF + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + flagv = idx%flagv(jb,igrd) + IF( flagv == 0. ) THEN + pva2d(ii,ij) = dta%v2d(jb) + ELSE ! T pts j-indice on the rim on the ocean next to the rim on T and V points + IF( flagv == 1. ) THEN ; ijTrim = ij ; ijToce = ij+1 ; ijVoce = ij+1 ; ENDIF + IF( flagv == -1. ) THEN ; ijTrim = ij+1 ; ijToce = ij ; ijVoce = ij-1 ; ENDIF + ! + ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received + IF( ijTrim > jpj .OR. ijToce > jpj .OR. ijVoce > jpj .OR. ijVoce < 1 ) CYCLE + ! + zfla = dta%v2d(jb) - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii,ijToce) - sshdta(ii,ijTrim) ) + ! + ! jchanut tschanges, use characteristics method (Blayo et Debreu, 2005) : + ! mix Flather scheme with velocity of the ocean next to the rim + pva2d(ii,ij) = z1_2 * ( pva2d(ii,ijVoce) + zfla ) + END IF + END DO + ! + END SUBROUTINE bdy_dyn2d_fla + + + SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn2d_orlanski *** + !! + !! - Apply Orlanski radiation condition adaptively: + !! - radiation plus weak nudging at outflow points + !! - no radiation and strong nudging at inflow points + !! + !! + !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data + INTEGER, INTENT(in) :: ib_bdy ! number of current open boundary set + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d + LOGICAL, INTENT(in) :: ll_npo ! flag for NPO version + LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated + INTEGER :: ib, igrd ! dummy loop indices + INTEGER :: ii, ij, iibm1, ijbm1 ! indices + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Orlanski bc on u-velocity; + ! + CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, llrim0, ll_npo ) + + igrd = 3 ! Orlanski bc on v-velocity + ! + CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, llrim0, ll_npo ) + ! + END SUBROUTINE bdy_dyn2d_orlanski + + + SUBROUTINE bdy_ssh( zssh ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_ssh *** + !! + !! ** Purpose : Duplicate sea level across open boundaries + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(jpi,jpj,1), INTENT(inout) :: zssh ! Sea level, need 3 dimensions to be used by bdy_nmn + !! + INTEGER :: ib_bdy, ir ! bdy index, rim index + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(8) :: llsend1, llrecv1 ! indicate how communications are to be carried out + !!---------------------------------------------------------------------- + llsend1(:) = .false. ; llrecv1(:) = .false. + DO ir = 1, 0, -1 ! treat rim 1 before rim 0 + IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF + IF( ir == 0 ) THEN ; llrim0 = .TRUE. + ELSE ; llrim0 = .FALSE. + END IF + DO ib_bdy = 1, nb_bdy + CALL bdy_nmn( idx_bdy(ib_bdy), 1, zssh, llrim0 ) ! zssh is masked + llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points + llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points + END DO + IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 + IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1.0_dp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + END IF + END DO + ! + END SUBROUTINE bdy_ssh + + !!====================================================================== +END MODULE bdydyn2d diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydyn3d.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydyn3d.f90 new file mode 100644 index 0000000000000000000000000000000000000000..386c7773a4d23e472e99235814c0f08cf8ead9cc --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdydyn3d.f90 @@ -0,0 +1,431 @@ + + + + + + + + + + + + + +MODULE bdydyn3d + !!====================================================================== + !! *** MODULE bdydyn3d *** + !! Unstructured Open Boundary Cond. : Flow relaxation scheme on baroclinic velocities + !!====================================================================== + !! History : 3.4 ! 2011 (D. Storkey) new module as part of BDY rewrite + !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) Optimization of BDY communications + !!---------------------------------------------------------------------- + !! bdy_dyn3d : apply open boundary conditions to baroclinic velocities + !! bdy_dyn3d_frs : apply Flow Relaxation Scheme + !!---------------------------------------------------------------------- + USE timing ! Timing + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE bdy_oce ! ocean open boundary conditions + USE bdylib ! for orlanski library routines + USE lib_mpp + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! + Use phycst + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_dyn3d ! routine called by bdy_dyn + PUBLIC bdy_dyn3d_dmp ! routine called by step + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdydyn3d.F90 15368 2021-10-14 08:25:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_dyn3d( kt, Kbb, puu, pvv, Kaa ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d *** + !! + !! ** Purpose : - Apply open boundary conditions for baroclinic velocities + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! Main time step counter + INTEGER , INTENT( in ) :: Kbb, Kaa ! Time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + ! + INTEGER :: ib_bdy, ir ! BDY set index, rim index + INTEGER, DIMENSION(6) :: idir6 + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(8) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out + !!---------------------------------------------------------------------- + + llsend2(:) = .false. ; llrecv2(:) = .false. + llsend3(:) = .false. ; llrecv3(:) = .false. + DO ir = 1, 0, -1 ! treat rim 1 before rim 0 + IF( ir == 0 ) THEN ; llrim0 = .TRUE. + ELSE ; llrim0 = .FALSE. + END IF + DO ib_bdy=1, nb_bdy + ! + SELECT CASE( cn_dyn3d(ib_bdy) ) + CASE('none') ; CYCLE + CASE('frs' ) ! treat the whole boundary at once + IF( ir == 0) CALL bdy_dyn3d_frs( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) + CASE('specified') ! treat the whole rim at once + IF( ir == 0) CALL bdy_dyn3d_spe( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) + CASE('zero') ! treat the whole rim at once + IF( ir == 0) CALL bdy_dyn3d_zro( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) + CASE('orlanski' ) ; CALL bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.false. ) + CASE('orlanski_npo'); CALL bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.true. ) + CASE('zerograd') ; CALL bdy_dyn3d_zgrad( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy, llrim0 ) + CASE('neumann') ; CALL bdy_dyn3d_nmn( puu, pvv, Kaa, idx_bdy(ib_bdy), ib_bdy, llrim0 ) + CASE DEFAULT ; CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) + END SELECT + END DO + ! + IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 + IF( nn_hls == 1 ) THEN + llsend2(:) = .false. ; llrecv2(:) = .false. + llsend3(:) = .false. ; llrecv3(:) = .false. + END IF + DO ib_bdy=1, nb_bdy + SELECT CASE( cn_dyn3d(ib_bdy) ) + CASE('orlanski', 'orlanski_npo') + llsend2(:) = llsend2(:) .OR. lsend_bdyolr(ib_bdy,2,:,ir) ! possibly every direction, U points + llrecv2(:) = llrecv2(:) .OR. lrecv_bdyolr(ib_bdy,2,:,ir) ! possibly every direction, U points + llsend3(:) = llsend3(:) .OR. lsend_bdyolr(ib_bdy,3,:,ir) ! possibly every direction, V points + llrecv3(:) = llrecv3(:) .OR. lrecv_bdyolr(ib_bdy,3,:,ir) ! possibly every direction, V points + CASE('zerograd') + idir6 = (/ jpso, jpno, jpsw, jpse, jpnw, jpne /) + llsend2(idir6) = llsend2(idir6) .OR. lsend_bdyint(ib_bdy,2,idir6,ir) ! north/south, U points + llrecv2(idir6) = llrecv2(idir6) .OR. lrecv_bdyint(ib_bdy,2,idir6,ir) ! north/south, U points + idir6 = (/ jpwe, jpea, jpsw, jpse, jpnw, jpne /) + llsend3(idir6) = llsend3(idir6) .OR. lsend_bdyint(ib_bdy,3,idir6,ir) ! west/east, V points + llrecv3(idir6) = llrecv3(idir6) .OR. lrecv_bdyint(ib_bdy,3,idir6,ir) ! west/east, V points + CASE('neumann') + llsend2(:) = llsend2(:) .OR. lsend_bdyint(ib_bdy,2,:,ir) ! possibly every direction, U points + llrecv2(:) = llrecv2(:) .OR. lrecv_bdyint(ib_bdy,2,:,ir) ! possibly every direction, U points + llsend3(:) = llsend3(:) .OR. lsend_bdyint(ib_bdy,3,:,ir) ! possibly every direction, V points + llrecv3(:) = llrecv3(:) .OR. lrecv_bdyint(ib_bdy,3,:,ir) ! possibly every direction, V points + END SELECT + END DO + ! + IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', puu(:,:,:,Kaa), 'U', -1.0_dp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) + END IF + IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', pvv(:,:,:,Kaa), 'V', -1.0_dp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) + END IF + END DO ! ir + ! + END SUBROUTINE bdy_dyn3d + + + SUBROUTINE bdy_dyn3d_spe( puu, pvv, Kaa, idx, dta, kt, ib_bdy ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_spe *** + !! + !! ** Purpose : - Apply a specified value for baroclinic velocities + !! at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: Kaa ! Time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + TYPE(OBC_DATA) , INTENT( in ) :: dta ! OBC external data + INTEGER , INTENT( in ) :: kt ! Time step + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + ! + INTEGER :: jb, jk ! dummy loop indices + INTEGER :: ii, ij, igrd ! local integers + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Relaxation of zonal velocity + DO jb = 1, idx%nblenrim(igrd) + DO jk = 1, jpkm1 + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + puu(ii,ij,jk,Kaa) = dta%u3d(jb,jk) * umask(ii,ij,jk) + END DO + END DO + ! + igrd = 3 ! Relaxation of meridional velocity + DO jb = 1, idx%nblenrim(igrd) + DO jk = 1, jpkm1 + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + pvv(ii,ij,jk,Kaa) = dta%v3d(jb,jk) * vmask(ii,ij,jk) + END DO + END DO + ! + END SUBROUTINE bdy_dyn3d_spe + + + SUBROUTINE bdy_dyn3d_zgrad( puu, pvv, Kaa, idx, dta, kt, ib_bdy, llrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_zgrad *** + !! + !! ** Purpose : - Enforce a zero gradient of normal velocity + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: Kaa ! Time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + TYPE(OBC_DATA) , INTENT( in ) :: dta ! OBC external data + INTEGER , INTENT( in ) :: kt + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + LOGICAL , INTENT( in ) :: llrim0 ! indicate if rim 0 is treated + !! + INTEGER :: jb, jk ! dummy loop indices + INTEGER :: ii, ij, igrd ! local integers + INTEGER :: flagu, flagv ! short cuts + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Copying tangential velocity into bdy points + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) + ENDIF + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + flagu = NINT(idx%flagu(jb,igrd)) + flagv = NINT(idx%flagv(jb,igrd)) + ! + IF( flagu == 0 ) THEN ! north/south bdy + IF( ij+flagv > jpj .OR. ij+flagv < 1 ) CYCLE + ! + DO jk = 1, jpkm1 + puu(ii,ij,jk,Kaa) = puu(ii,ij+flagv,jk,Kaa) * umask(ii,ij+flagv,jk) + END DO + ! + END IF + END DO + ! + igrd = 3 ! Copying tangential velocity into bdy points + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) + ENDIF + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + flagu = NINT(idx%flagu(jb,igrd)) + flagv = NINT(idx%flagv(jb,igrd)) + ! + IF( flagv == 0 ) THEN ! west/east bdy + IF( ii+flagu > jpi .OR. ii+flagu < 1 ) CYCLE + ! + DO jk = 1, jpkm1 + pvv(ii,ij,jk,Kaa) = pvv(ii+flagu,ij,jk,Kaa) * vmask(ii+flagu,ij,jk) + END DO + ! + END IF + END DO + ! + END SUBROUTINE bdy_dyn3d_zgrad + + + SUBROUTINE bdy_dyn3d_zro( puu, pvv, Kaa, idx, dta, kt, ib_bdy ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_zro *** + !! + !! ** Purpose : - baroclinic velocities = 0. at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! time step index + INTEGER , INTENT( in ) :: Kaa ! Time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + TYPE(OBC_DATA) , INTENT( in ) :: dta ! OBC external data + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + ! + INTEGER :: ib, ik ! dummy loop indices + INTEGER :: ii, ij, igrd ! local integers + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Everything is at T-points here + DO ib = 1, idx%nblenrim(igrd) + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + DO ik = 1, jpkm1 + puu(ii,ij,ik,Kaa) = 0._wp + END DO + END DO + ! + igrd = 3 ! Everything is at T-points here + DO ib = 1, idx%nblenrim(igrd) + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + DO ik = 1, jpkm1 + pvv(ii,ij,ik,Kaa) = 0._wp + END DO + END DO + ! + END SUBROUTINE bdy_dyn3d_zro + + + SUBROUTINE bdy_dyn3d_frs( puu, pvv, Kaa, idx, dta, kt, ib_bdy ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_frs *** + !! + !! ** Purpose : - Apply the Flow Relaxation Scheme for baroclinic velocities + !! at open boundaries. + !! + !! References :- Engedahl H., 1995: Use of the flow relaxation scheme in + !! a three-dimensional baroclinic ocean model with realistic + !! topography. Tellus, 365-382. + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! time step index + INTEGER , INTENT( in ) :: Kaa ! Time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + TYPE(OBC_DATA) , INTENT( in ) :: dta ! OBC external data + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + ! + INTEGER :: jb, jk ! dummy loop indices + INTEGER :: ii, ij, igrd ! local integers + REAL(wp) :: zwgt ! boundary weight + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Relaxation of zonal velocity + DO jb = 1, idx%nblen(igrd) + DO jk = 1, jpkm1 + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + zwgt = idx%nbw(jb,igrd) + puu(ii,ij,jk,Kaa) = ( puu(ii,ij,jk,Kaa) + zwgt * ( dta%u3d(jb,jk) - puu(ii,ij,jk,Kaa) ) ) * umask(ii,ij,jk) + END DO + END DO + ! + igrd = 3 ! Relaxation of meridional velocity + DO jb = 1, idx%nblen(igrd) + DO jk = 1, jpkm1 + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + zwgt = idx%nbw(jb,igrd) + pvv(ii,ij,jk,Kaa) = ( pvv(ii,ij,jk,Kaa) + zwgt * ( dta%v3d(jb,jk) - pvv(ii,ij,jk,Kaa) ) ) * vmask(ii,ij,jk) + END DO + END DO + ! + END SUBROUTINE bdy_dyn3d_frs + + + SUBROUTINE bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx, dta, ib_bdy, llrim0, ll_npo ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_orlanski *** + !! + !! - Apply Orlanski radiation to baroclinic velocities. + !! - Wrapper routine for bdy_orlanski_3d + !! + !! + !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: Kbb, Kaa ! Time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + TYPE(OBC_DATA) , INTENT( in ) :: dta ! OBC external data + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + LOGICAL , INTENT( in ) :: llrim0 ! indicate if rim 0 is treated + LOGICAL , INTENT( in ) :: ll_npo ! switch for NPO version + + INTEGER :: jb, igrd ! dummy loop indices + !!---------------------------------------------------------------------- + ! + !! Note that at this stage the puu(:,:,:,Kbb) and puu(:,:,:,Kaa) arrays contain the baroclinic velocities. + ! + igrd = 2 ! Orlanski bc on u-velocity; + ! + CALL bdy_orlanski_3d( idx, igrd, puu(:,:,:,Kbb), puu(:,:,:,Kaa), dta%u3d, ll_npo, llrim0 ) + + igrd = 3 ! Orlanski bc on v-velocity + ! + CALL bdy_orlanski_3d( idx, igrd, pvv(:,:,:,Kbb), pvv(:,:,:,Kaa), dta%v3d, ll_npo, llrim0 ) + ! + END SUBROUTINE bdy_dyn3d_orlanski + + + SUBROUTINE bdy_dyn3d_dmp( kt, Kbb, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_dmp *** + !! + !! ** Purpose : Apply damping for baroclinic velocities at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! time step + INTEGER , INTENT( in ) :: Kbb, Krhs ! Time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities and trends (to be updated at open boundaries) + ! + INTEGER :: jb, jk ! dummy loop indices + INTEGER :: ib_bdy ! loop index + INTEGER :: ii, ij, igrd ! local integers + REAL(wp) :: zwgt ! boundary weight + !!---------------------------------------------------------------------- + IF( l_istiled .AND. ntile /= 1 ) RETURN ! Do only for the full domain + ! + IF( ln_timing ) CALL timing_start('bdy_dyn3d_dmp') + ! + DO ib_bdy=1, nb_bdy + IF ( ln_dyn3d_dmp(ib_bdy) .and. cn_dyn3d(ib_bdy) /= 'none' ) THEN + igrd = 2 ! Relaxation of zonal velocity + DO jb = 1, idx_bdy(ib_bdy)%nblen(igrd) + ii = idx_bdy(ib_bdy)%nbi(jb,igrd) + ij = idx_bdy(ib_bdy)%nbj(jb,igrd) + zwgt = idx_bdy(ib_bdy)%nbd(jb,igrd) + DO jk = 1, jpkm1 + puu(ii,ij,jk,Krhs) = ( puu(ii,ij,jk,Krhs) + zwgt * ( dta_bdy(ib_bdy)%u3d(jb,jk) - & + puu(ii,ij,jk,Kbb) + uu_b(ii,ij,Kbb)) ) * umask(ii,ij,jk) + END DO + END DO + ! + igrd = 3 ! Relaxation of meridional velocity + DO jb = 1, idx_bdy(ib_bdy)%nblen(igrd) + ii = idx_bdy(ib_bdy)%nbi(jb,igrd) + ij = idx_bdy(ib_bdy)%nbj(jb,igrd) + zwgt = idx_bdy(ib_bdy)%nbd(jb,igrd) + DO jk = 1, jpkm1 + pvv(ii,ij,jk,Krhs) = ( pvv(ii,ij,jk,Krhs) + zwgt * ( dta_bdy(ib_bdy)%v3d(jb,jk) - & + pvv(ii,ij,jk,Kbb) + vv_b(ii,ij,Kbb)) ) * vmask(ii,ij,jk) + END DO + END DO + ENDIF + END DO + ! + IF( ln_timing ) CALL timing_stop('bdy_dyn3d_dmp') + ! + END SUBROUTINE bdy_dyn3d_dmp + + + SUBROUTINE bdy_dyn3d_nmn( puu, pvv, Kaa, idx, ib_bdy, llrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_nmn *** + !! + !! - Apply Neumann condition to baroclinic velocities. + !! - Wrapper routine for bdy_nmn + !! + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: Kaa ! Time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + LOGICAL , INTENT( in ) :: llrim0 ! indicate if rim 0 is treated + INTEGER :: igrd ! dummy indice + !!---------------------------------------------------------------------- + ! + !! Note that at this stage the puu(:,:,:,Kbb) and puu(:,:,:,Kaa) arrays contain the baroclinic velocities. + ! + igrd = 2 ! Neumann bc on u-velocity; + ! + CALL bdy_nmn( idx, igrd, puu(:,:,:,Kaa), llrim0 ) + + igrd = 3 ! Neumann bc on v-velocity + ! + CALL bdy_nmn( idx, igrd, pvv(:,:,:,Kaa), llrim0 ) + ! + END SUBROUTINE bdy_dyn3d_nmn + + !!====================================================================== +END MODULE bdydyn3d diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdyice.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdyice.f90 new file mode 100644 index 0000000000000000000000000000000000000000..210aa49f4de21ab20dc4f567f3c48d0acef091da --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdyice.f90 @@ -0,0 +1,34 @@ + + + + + + + + + + + + + +MODULE bdyice + !!====================================================================== + !! *** MODULE bdyice *** + !! Unstructured Open Boundary Cond. : Open boundary conditions for sea-ice (SI3) + !!====================================================================== + !! History : 3.3 ! 2010-09 (D. Storkey) Original code + !! 3.4 ! 2012-01 (C. Rousset) add new sea ice model + !! 4.0 ! 2018 (C. Rousset) SI3 compatibility + !!---------------------------------------------------------------------- + !!--------------------------------------------------------------------------------- + !! Default option Empty module + !!--------------------------------------------------------------------------------- +CONTAINS + SUBROUTINE bdy_ice( kt ) ! Empty routine + IMPLICIT NONE + INTEGER, INTENT( in ) :: kt + WRITE(*,*) 'bdy_ice: You should not have seen this print! error?', kt + END SUBROUTINE bdy_ice + + !!================================================================================= +END MODULE bdyice diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdyini.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdyini.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5c1e6ba64aed16c1beaa71c53142a73131f228c5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdyini.f90 @@ -0,0 +1,2009 @@ + + + + + + + + + + + + + +MODULE bdyini + !!====================================================================== + !! *** MODULE bdyini *** + !! Unstructured open boundaries : initialisation + !!====================================================================== + !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code + !! - ! 2007-01 (D. Storkey) Update to use IOM module + !! - ! 2007-01 (D. Storkey) Tidal forcing + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.3 ! 2010-09 (E.O'Dea) updates for Shelf configurations + !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !! 3.4 ! 2012 (J. Chanut) straight open boundary case update + !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) optimization of BDY communications + !! 3.7 ! 2016 (T. Lovato) Remove bdy macro, call here init for dta and tides + !!---------------------------------------------------------------------- + !! bdy_init : Initialization of unstructured open boundaries + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain + USE sbc_oce , ONLY: nn_ice + USE bdy_oce ! unstructured open boundary conditions + USE bdydta ! open boundary cond. setting (bdy_dta_init routine) + USE bdytides ! open boundary cond. setting (bdytide_init routine) + USE tide_mod, ONLY: ln_tide ! tidal forcing + USE phycst , ONLY: rday + ! + USE in_out_manager ! I/O units + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! for mpp_sum + USE iom ! I/O + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_init ! routine called in nemo_init + PUBLIC find_neib ! routine called in bdy_nmn + + INTEGER, PARAMETER :: jp_nseg = 100 ! + ! Straight open boundary segment parameters: + INTEGER :: nbdysege, nbdysegw, nbdysegn, nbdysegs + INTEGER, DIMENSION(jp_nseg) :: jpieob, jpjedt, jpjeft, npckge ! + INTEGER, DIMENSION(jp_nseg) :: jpiwob, jpjwdt, jpjwft, npckgw ! + INTEGER, DIMENSION(jp_nseg) :: jpjnob, jpindt, jpinft, npckgn ! + INTEGER, DIMENSION(jp_nseg) :: jpjsob, jpisdt, jpisft, npckgs ! + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdyini.F90 15368 2021-10-14 08:25:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_init + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_init *** + !! + !! ** Purpose : Initialization of the dynamics and tracer fields with + !! unstructured open boundaries. + !! + !! ** Method : Read initialization arrays (mask, indices) to identify + !! an unstructured open boundary + !! + !! ** Input : bdy_init.nc, input file for unstructured open boundaries + !!---------------------------------------------------------------------- + NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & + & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & + & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & + & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & + & cn_ice, nn_ice_dta, & + & ln_vol, nn_volctl, nn_rimwidth + ! + INTEGER :: ios ! Local integer output status for namelist read + !!---------------------------------------------------------------------- + + ! ------------------------ + ! Read namelist parameters + ! ------------------------ + READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' ) + ! make sur that all elements of the namelist variables have a default definition from namelist_ref + ln_coords_file (2:jp_bdy) = ln_coords_file (1) + cn_coords_file (2:jp_bdy) = cn_coords_file (1) + cn_dyn2d (2:jp_bdy) = cn_dyn2d (1) + nn_dyn2d_dta (2:jp_bdy) = nn_dyn2d_dta (1) + cn_dyn3d (2:jp_bdy) = cn_dyn3d (1) + nn_dyn3d_dta (2:jp_bdy) = nn_dyn3d_dta (1) + cn_tra (2:jp_bdy) = cn_tra (1) + nn_tra_dta (2:jp_bdy) = nn_tra_dta (1) + ln_tra_dmp (2:jp_bdy) = ln_tra_dmp (1) + ln_dyn3d_dmp (2:jp_bdy) = ln_dyn3d_dmp (1) + rn_time_dmp (2:jp_bdy) = rn_time_dmp (1) + rn_time_dmp_out(2:jp_bdy) = rn_time_dmp_out(1) + cn_ice (2:jp_bdy) = cn_ice (1) + nn_ice_dta (2:jp_bdy) = nn_ice_dta (1) + READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' ) + IF(lwm) WRITE ( numond, nambdy ) + + IF( .NOT. Agrif_Root() ) ln_bdy = .FALSE. ! forced for Agrif children + + IF( nb_bdy == 0 ) ln_bdy = .FALSE. + + ! ----------------------------------------- + ! unstructured open boundaries use control + ! ----------------------------------------- + IF ( ln_bdy ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'bdy_init : initialization of open boundaries' + IF(lwp) WRITE(numout,*) '~~~~~~~~' + ! + ! Open boundaries definition (arrays and masks) + CALL bdy_def + IF( ln_meshmask ) CALL bdy_meshwri() + ! + ! Open boundaries initialisation of external data arrays + CALL bdy_dta_init + ! + ! Open boundaries initialisation of tidal harmonic forcing + IF( ln_tide ) CALL bdytide_init + ! + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'bdy_init : open boundaries not used (ln_bdy = F)' + IF(lwp) WRITE(numout,*) '~~~~~~~~' + ! + ENDIF + ! + END SUBROUTINE bdy_init + + + SUBROUTINE bdy_def + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_init *** + !! + !! ** Purpose : Definition of unstructured open boundaries. + !! + !! ** Method : Read initialization arrays (mask, indices) to identify + !! an unstructured open boundary + !! + !! ** Input : bdy_init.nc, input file for unstructured open boundaries + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ib_bdy, ii, ij, igrd, ib, ir, iseg ! dummy loop indices + INTEGER :: icount, icountr, icountr0, ibr_max ! local integers + INTEGER :: ilen1 ! - - + INTEGER :: iiRst, iiRnd, iiSst, iiSnd, iiSstdiag, iiSnddiag, iiSstsono, iiSndsono + INTEGER :: ijRst, ijRnd, ijSst, ijSnd, ijSstdiag, ijSnddiag, ijSstsono, ijSndsono + INTEGER :: iiout, ijout, iioutdir, ijoutdir, icnt + INTEGER :: iRnei, iRdiag, iRsono + INTEGER :: iSnei, iSdiag, iSsono ! - - + INTEGER :: iwe, ies, iso, ino, inum, id_dummy ! - - + INTEGER :: jpbdta ! - - + INTEGER :: ib_bdy1, ib_bdy2, ib1, ib2 ! - - + INTEGER :: ii1, ii2, ii3, ij1, ij2, ij3 ! - - + INTEGER :: iibe, ijbe, iibi, ijbi ! - - + INTEGER :: flagu, flagv ! short cuts + INTEGER :: nbdyind, nbdybeg, nbdyend + INTEGER , DIMENSION(4) :: kdimsz + INTEGER , DIMENSION(jpbgrd,jp_bdy) :: nblendta ! Length of index arrays + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbidta, nbjdta ! Index arrays: i and j indices of bdy dta + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbrdta ! Discrete distance from rim points + CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zz_read ! work space for 2D global boundary data + REAL(wp), POINTER , DIMENSION(:,:) :: zmask ! pointer to 2D mask fields + REAL(wp) , DIMENSION(jpi,jpj) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) + REAL(wp) , DIMENSION(jpi,jpj) :: ztmask, zumask, zvmask ! temporary u/v mask array + REAL(wp) , DIMENSION(jpi,jpj) :: zzbdy + !!---------------------------------------------------------------------- + ! + cgrid = (/'t','u','v'/) + + ! ----------------------------------------- + ! Check and write out namelist parameters + ! ----------------------------------------- + + IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy + + DO ib_bdy = 1,nb_bdy + + IF(lwp) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) '------ Open boundary data set ',ib_bdy,' ------' + IF( ln_coords_file(ib_bdy) ) THEN + WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_bdy)) + ELSE + WRITE(numout,*) 'Boundary defined in namelist.' + ENDIF + WRITE(numout,*) + ENDIF + + ! barotropic bdy + !---------------- + IF(lwp) THEN + WRITE(numout,*) 'Boundary conditions for barotropic solution: ' + SELECT CASE( cn_dyn2d(ib_bdy) ) + CASE( 'none' ) ; WRITE(numout,*) ' no open boundary condition' + CASE( 'frs' ) ; WRITE(numout,*) ' Flow Relaxation Scheme' + CASE( 'flather' ) ; WRITE(numout,*) ' Flather radiation condition' + CASE( 'orlanski' ) ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' + CASE( 'orlanski_npo' ) ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn2d' ) + END SELECT + ENDIF + + dta_bdy(ib_bdy)%lneed_ssh = cn_dyn2d(ib_bdy) == 'flather' + dta_bdy(ib_bdy)%lneed_dyn2d = cn_dyn2d(ib_bdy) /= 'none' + + IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn2d ) THEN + SELECT CASE( nn_dyn2d_dta(ib_bdy) ) ! + CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' + CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' + CASE( 2 ) ; WRITE(numout,*) ' tidal harmonic forcing taken from file' + CASE( 3 ) ; WRITE(numout,*) ' boundary data AND tidal harmonic forcing taken from files' + CASE DEFAULT ; CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' ) + END SELECT + ENDIF + IF ( dta_bdy(ib_bdy)%lneed_dyn2d .AND. nn_dyn2d_dta(ib_bdy) .GE. 2 .AND. .NOT.ln_tide ) THEN + CALL ctl_stop( 'You must activate with ln_tide to add tidal forcing at open boundaries' ) + ENDIF + IF(lwp) WRITE(numout,*) + + ! baroclinic bdy + !---------------- + IF(lwp) THEN + WRITE(numout,*) 'Boundary conditions for baroclinic velocities: ' + SELECT CASE( cn_dyn3d(ib_bdy) ) + CASE('none') ; WRITE(numout,*) ' no open boundary condition' + CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' + CASE('specified') ; WRITE(numout,*) ' Specified value' + CASE('neumann') ; WRITE(numout,*) ' Neumann conditions' + CASE('zerograd') ; WRITE(numout,*) ' Zero gradient for baroclinic velocities' + CASE('zero') ; WRITE(numout,*) ' Zero baroclinic velocities (runoff case)' + CASE('orlanski') ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' + CASE('orlanski_npo') ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn3d' ) + END SELECT + ENDIF + + dta_bdy(ib_bdy)%lneed_dyn3d = cn_dyn3d(ib_bdy) == 'frs' .OR. cn_dyn3d(ib_bdy) == 'specified' & + & .OR. cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' + + IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn3d ) THEN + SELECT CASE( nn_dyn3d_dta(ib_bdy) ) ! + CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' + CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' + CASE DEFAULT ; CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' ) + END SELECT + END IF + + IF ( ln_dyn3d_dmp(ib_bdy) ) THEN + IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN + IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.' + ln_dyn3d_dmp(ib_bdy) = .false. + ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN + CALL ctl_stop( 'Use FRS OR relaxation' ) + ELSE + IF(lwp) WRITE(numout,*) ' + baroclinic velocities relaxation zone' + IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' + IF(rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) + dta_bdy(ib_bdy)%lneed_dyn3d = .TRUE. + ENDIF + ELSE + IF(lwp) WRITE(numout,*) ' NO relaxation on baroclinic velocities' + ENDIF + IF(lwp) WRITE(numout,*) + + ! tra bdy + !---------------- + IF(lwp) THEN + WRITE(numout,*) 'Boundary conditions for temperature and salinity: ' + SELECT CASE( cn_tra(ib_bdy) ) + CASE('none') ; WRITE(numout,*) ' no open boundary condition' + CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' + CASE('specified') ; WRITE(numout,*) ' Specified value' + CASE('neumann') ; WRITE(numout,*) ' Neumann conditions' + CASE('runoff') ; WRITE(numout,*) ' Runoff conditions : Neumann for T and specified to 0.1 for salinity' + CASE('orlanski') ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' + CASE('orlanski_npo') ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_tra' ) + END SELECT + ENDIF + + dta_bdy(ib_bdy)%lneed_tra = cn_tra(ib_bdy) == 'frs' .OR. cn_tra(ib_bdy) == 'specified' & + & .OR. cn_tra(ib_bdy) == 'orlanski' .OR. cn_tra(ib_bdy) == 'orlanski_npo' + + IF( lwp .AND. dta_bdy(ib_bdy)%lneed_tra ) THEN + SELECT CASE( nn_tra_dta(ib_bdy) ) ! + CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' + CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' + CASE DEFAULT ; CALL ctl_stop( 'nn_tra_dta must be 0 or 1' ) + END SELECT + ENDIF + + IF ( ln_tra_dmp(ib_bdy) ) THEN + IF ( cn_tra(ib_bdy) == 'none' ) THEN + IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.' + ln_tra_dmp(ib_bdy) = .false. + ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN + CALL ctl_stop( 'Use FRS OR relaxation' ) + ELSE + IF(lwp) WRITE(numout,*) ' + T/S relaxation zone' + IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' + IF(lwp) WRITE(numout,*) ' Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days' + IF(lwp.AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) + dta_bdy(ib_bdy)%lneed_tra = .TRUE. + ENDIF + ELSE + IF(lwp) WRITE(numout,*) ' NO T/S relaxation' + ENDIF + IF(lwp) WRITE(numout,*) + + dta_bdy(ib_bdy)%lneed_ice = .FALSE. + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Width of relaxation zone = ', nn_rimwidth(ib_bdy) + IF(lwp) WRITE(numout,*) + ! + END DO ! nb_bdy + + IF( lwp ) THEN + IF( ln_vol ) THEN ! check volume conservation (nn_volctl value) + WRITE(numout,*) 'Volume correction applied at open boundaries' + WRITE(numout,*) + SELECT CASE ( nn_volctl ) + CASE( 1 ) ; WRITE(numout,*) ' The total volume will be constant' + CASE( 0 ) ; WRITE(numout,*) ' The total volume will vary according to the surface E-P flux' + CASE DEFAULT ; CALL ctl_stop( 'nn_volctl must be 0 or 1' ) + END SELECT + WRITE(numout,*) + ! + ! sanity check if used with tides + IF( ln_tide ) THEN + WRITE(numout,*) ' The total volume correction is not working with tides. ' + WRITE(numout,*) ' Set ln_vol to .FALSE. ' + WRITE(numout,*) ' or ' + WRITE(numout,*) ' equilibriate your bdy input files ' + CALL ctl_stop( 'The total volume correction is not working with tides.' ) + END IF + ELSE + WRITE(numout,*) 'No volume correction applied at open boundaries' + WRITE(numout,*) + ENDIF + ENDIF + + ! ------------------------------------------------- + ! Initialise indices arrays for open boundaries + ! ------------------------------------------------- + + nblendta(:,:) = 0 + nbdysege = 0 + nbdysegw = 0 + nbdysegn = 0 + nbdysegs = 0 + + ! Define all boundaries + ! --------------------- + DO ib_bdy = 1, nb_bdy + ! + IF( .NOT. ln_coords_file(ib_bdy) ) THEN ! build bdy coordinates with segments defined in namelist + + CALL bdy_read_seg( ib_bdy, nblendta(:,ib_bdy) ) + + ELSE ! Read size of arrays in boundary coordinates file. + + CALL iom_open( cn_coords_file(ib_bdy), inum ) + DO igrd = 1, jpbgrd + id_dummy = iom_varid( inum, 'nbi'//cgrid(igrd), kdimsz=kdimsz ) + nblendta(igrd,ib_bdy) = MAXVAL(kdimsz) + END DO + CALL iom_close( inum ) + ENDIF + ! + END DO ! ib_bdy + + ! Now look for crossings in user (namelist) defined open boundary segments: + IF( nbdysege > 0 .OR. nbdysegw > 0 .OR. nbdysegn > 0 .OR. nbdysegs > 0) CALL bdy_ctl_seg + + ! Allocate arrays + !--------------- + jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy)) + ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy), nbrdta(jpbdta, jpbgrd, nb_bdy) ) + nbrdta(:,:,:) = 0 ! initialize nbrdta as it may not be completely defined for each bdy + + ! Calculate global boundary index arrays or read in from file + !------------------------------------------------------------ + ! 1. Read global index arrays from boundary coordinates file. + DO ib_bdy = 1, nb_bdy + ! + IF( ln_coords_file(ib_bdy) ) THEN + ! + ALLOCATE( zz_read( MAXVAL(nblendta), 1 ) ) + CALL iom_open( cn_coords_file(ib_bdy), inum ) + ! + DO igrd = 1, jpbgrd + CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) + DO ii = 1,nblendta(igrd,ib_bdy) + nbidta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) + nn_hls + END DO + CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) + DO ii = 1,nblendta(igrd,ib_bdy) + nbjdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) + nn_hls + END DO + CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) + DO ii = 1,nblendta(igrd,ib_bdy) + nbrdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) + END DO + ! + ibr_max = MAXVAL( nbrdta(:,igrd,ib_bdy) ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Maximum rimwidth in file is ', ibr_max + IF(lwp) WRITE(numout,*) ' nn_rimwidth from namelist is ', nn_rimwidth(ib_bdy) + IF (ibr_max < nn_rimwidth(ib_bdy)) & + CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) ) + END DO + ! + CALL iom_close( inum ) + DEALLOCATE( zz_read ) + ! + ENDIF + ! + END DO + + ! 2. Now fill indices corresponding to straight open boundary arrays: + CALL bdy_coords_seg( nbidta, nbjdta, nbrdta ) + + ! Deal with duplicated points + !----------------------------- + ! We assign negative indices to duplicated points (to remove them from bdy points to be updated) + ! if their distance to the bdy is greater than the other + ! If their distance are the same, just keep only one to avoid updating a point twice + DO igrd = 1, jpbgrd + DO ib_bdy1 = 1, nb_bdy + DO ib_bdy2 = 1, nb_bdy + IF (ib_bdy1/=ib_bdy2) THEN + DO ib1 = 1, nblendta(igrd,ib_bdy1) + DO ib2 = 1, nblendta(igrd,ib_bdy2) + IF ((nbidta(ib1, igrd, ib_bdy1)==nbidta(ib2, igrd, ib_bdy2)).AND. & + & (nbjdta(ib1, igrd, ib_bdy1)==nbjdta(ib2, igrd, ib_bdy2))) THEN + ! IF ((lwp).AND.(igrd==1)) WRITE(numout,*) ' found coincident point ji, jj:', & + ! & nbidta(ib1, igrd, ib_bdy1), & + ! & nbjdta(ib2, igrd, ib_bdy2) + ! keep only points with the lowest distance to boundary: + IF (nbrdta(ib1, igrd, ib_bdy1)nbrdta(ib2, igrd, ib_bdy2)) THEN + nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 + nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 + ! Arbitrary choice if distances are the same: + ELSE + nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 + nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 + ENDIF + END IF + END DO + END DO + ENDIF + END DO + END DO + END DO + ! + ! Find lenght of boundaries and rim on local mpi domain + !------------------------------------------------------ + ! + iwe = mig(1) + ies = mig(jpi) + iso = mjg(1) + ino = mjg(jpj) + ! + DO ib_bdy = 1, nb_bdy + DO igrd = 1, jpbgrd + icount = 0 ! initialization of local bdy length + icountr = 0 ! initialization of local rim 0 and rim 1 bdy length + icountr0 = 0 ! initialization of local rim 0 bdy length + idx_bdy(ib_bdy)%nblen(igrd) = 0 + idx_bdy(ib_bdy)%nblenrim(igrd) = 0 + idx_bdy(ib_bdy)%nblenrim0(igrd) = 0 + DO ib = 1, nblendta(igrd,ib_bdy) + ! check that data is in correct order in file + IF( ib > 1 ) THEN + IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ib-1,igrd,ib_bdy) ) THEN + CALL ctl_stop('bdy_segs : ERROR : boundary data in file must be defined ', & + & ' in order of distance from edge nbr A utility for re-ordering ', & + & ' boundary coordinates and data files exists in the TOOLS/OBC directory') + ENDIF + ENDIF + ! check if point is in local domain + IF( nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND. & + & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino ) THEN + ! + icount = icount + 1 + IF( nbrdta(ib,igrd,ib_bdy) == 1 .OR. nbrdta(ib,igrd,ib_bdy) == 0 ) icountr = icountr + 1 + IF( nbrdta(ib,igrd,ib_bdy) == 0 ) icountr0 = icountr0 + 1 + ENDIF + END DO + idx_bdy(ib_bdy)%nblen (igrd) = icount !: length of boundary data on each proc + idx_bdy(ib_bdy)%nblenrim (igrd) = icountr !: length of rim 0 and rim 1 boundary data on each proc + idx_bdy(ib_bdy)%nblenrim0(igrd) = icountr0 !: length of rim 0 boundary data on each proc + END DO ! igrd + + ! Allocate index arrays for this boundary set + !-------------------------------------------- + ilen1 = MAXVAL( idx_bdy(ib_bdy)%nblen(:) ) + ALLOCATE( idx_bdy(ib_bdy)%nbi (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbj (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbr (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbd (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%ntreat(ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbmap (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbw (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%flagu (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%flagv (ilen1,jpbgrd) ) + + ! Dispatch mapping indices and discrete distances on each processor + ! ----------------------------------------------------------------- + DO igrd = 1, jpbgrd + icount = 0 + ! Outer loop on rimwidth to ensure outermost points come first in the local arrays. + DO ir = 0, nn_rimwidth(ib_bdy) + DO ib = 1, nblendta(igrd,ib_bdy) + ! check if point is in local domain and equals ir + IF( nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND. & + & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino .AND. & + & nbrdta(ib,igrd,ib_bdy) == ir ) THEN + ! + icount = icount + 1 + idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy) - mig(1) + 1 ! global to local indexes + idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy) - mjg(1) + 1 ! global to local indexes + idx_bdy(ib_bdy)%nbr(icount,igrd) = nbrdta(ib,igrd,ib_bdy) + idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib + ENDIF + END DO + END DO + END DO ! igrd + + END DO ! ib_bdy + + ! Initialize array indicating communications in bdy + ! ------------------------------------------------- + ALLOCATE( lsend_bdyolr(nb_bdy,jpbgrd,8,0:1), lrecv_bdyolr(nb_bdy,jpbgrd,8,0:1) ) + lsend_bdyolr(:,:,:,:) = .false. + lrecv_bdyolr(:,:,:,:) = .false. + + DO ib_bdy = 1, nb_bdy + DO igrd = 1, jpbgrd + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! only the rim triggers communications, see bdy routines + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( ib .LE. idx_bdy(ib_bdy)%nblenrim0(igrd) ) THEN ; ir = 0 + ELSE ; ir = 1 + END IF + ! + ! check if point has to be sent to a neighbour + IF( ii >= Nis0 .AND. ii < Nis0 + nn_hls .AND. ij >= Njs0 .AND. ij <= Nje0 ) THEN ! we inner side + IF( mpiSnei(nn_hls,jpwe) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpwe,ir) = .TRUE. + ENDIF + IF( ii <= Nie0 .AND. ii > Nie0 - nn_hls .AND. ij >= Njs0 .AND. ij <= Nje0 ) THEN ! ea inner side + IF( mpiSnei(nn_hls,jpea) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpea,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii <= Nie0 .AND. ij >= Njs0 .AND. ij < Njs0 + nn_hls ) THEN ! so inner side + IF( mpiSnei(nn_hls,jpso) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii < Nis0 .AND. ij >= Njs0 .AND. ij < Njs0 + nn_hls ) THEN ! so side we-halo + IF( mpiSnei(nn_hls,jpso) > -1 .AND. nn_comm == 1 ) lsend_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii > Nie0 .AND. ij >= Njs0 .AND. ij < Njs0 + nn_hls ) THEN ! so side ea-halo + IF( mpiSnei(nn_hls,jpso) > -1 .AND. nn_comm == 1 ) lsend_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii <= Nie0 .AND. ij <= Nje0 .AND. ij > Nje0 - nn_hls ) THEN ! no inner side + IF( mpiSnei(nn_hls,jpno) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + IF( ii < Nis0 .AND. ij <= Nje0 .AND. ij > Nje0 - nn_hls ) THEN ! no side we-halo + IF( mpiSnei(nn_hls,jpno) > -1 .AND. nn_comm == 1 ) lsend_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + IF( ii > Nie0 .AND. ij <= Nje0 .AND. ij > Nje0 - nn_hls ) THEN ! no side ea-halo + IF( mpiSnei(nn_hls,jpno) > -1 .AND. nn_comm == 1 ) lsend_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii < Nis0 + nn_hls .AND. ij >= Njs0 .AND. ij < Njs0 + nn_hls ) THEN ! sw inner corner + IF( mpiSnei(nn_hls,jpsw) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpsw,ir) = .TRUE. + ENDIF + IF( ii <= Nie0 .AND. ii > Nie0 - nn_hls .AND. ij >= Njs0 .AND. ij < Njs0 + nn_hls ) THEN ! se inner corner + IF( mpiSnei(nn_hls,jpse) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpse,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii < Nis0 + nn_hls .AND. ij <= Nje0 .AND. ij > Nje0 - nn_hls ) THEN ! nw inner corner + IF( mpiSnei(nn_hls,jpnw) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpnw,ir) = .TRUE. + ENDIF + IF( ii <= Nie0 .AND. ii > Nie0 - nn_hls .AND. ij <= Nje0 .AND. ij > Nje0 - nn_hls ) THEN ! ne inner corner + IF( mpiSnei(nn_hls,jpne) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpne,ir) = .TRUE. + ENDIF + ! + ! check if point has to be received from a neighbour + IF( ii < Nis0 .AND. ij >= Njs0 .AND. ij <= Nje0 ) THEN ! we side + IF( mpiRnei(nn_hls,jpwe) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpwe,ir) = .TRUE. + ENDIF + IF( ii > Nie0 .AND. ij >= Njs0 .AND. ij <= Nje0 ) THEN ! ea side + IF( mpiRnei(nn_hls,jpea) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpea,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii <= Nie0 .AND. ij < Njs0 ) THEN ! so side + IF( mpiRnei(nn_hls,jpso) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii <= Nie0 .AND. ij > Nje0 ) THEN ! no side + IF( mpiRnei(nn_hls,jpno) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + IF( ii < Nis0 .AND. ij < Njs0 ) THEN ! sw corner + IF( mpiRnei(nn_hls,jpsw) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpsw,ir) = .TRUE. + IF( mpiRnei(nn_hls,jpso) > -1 .AND. nn_comm == 1 ) lrecv_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii > Nie0 .AND. ij < Njs0 ) THEN ! se corner + IF( mpiRnei(nn_hls,jpse) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpse,ir) = .TRUE. + IF( mpiRnei(nn_hls,jpso) > -1 .AND. nn_comm == 1 ) lrecv_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii < Nis0 .AND. ij > Nje0 ) THEN ! nw corner + IF( mpiRnei(nn_hls,jpnw) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpnw,ir) = .TRUE. + IF( mpiRnei(nn_hls,jpno) > -1 .AND. nn_comm == 1 ) lrecv_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + IF( ii > Nie0 .AND. ij > Nje0 ) THEN ! ne corner + IF( mpiRnei(nn_hls,jpne) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpne,ir) = .TRUE. + IF( mpiRnei(nn_hls,jpno) > -1 .AND. nn_comm == 1 ) lrecv_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + ! + END DO + END DO ! igrd + + ! Comment out for debug +!!$ DO ir = 0,1 +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'T', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyolr(ib_bdy,1,:,ir), lrecv = lrecv_bdyolr(ib_bdy,1,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' seb bdy debug olr T', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'U', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyolr(ib_bdy,2,:,ir), lrecv = lrecv_bdyolr(ib_bdy,2,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' seb bdy debug olr U', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'V', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyolr(ib_bdy,3,:,ir), lrecv = lrecv_bdyolr(ib_bdy,3,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' seb bdy debug olr V', ir ; CALL FLUSH(numout) +!!$ END DO + + ! Compute rim weights for FRS scheme + ! ---------------------------------- + DO igrd = 1, jpbgrd + DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) + ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) ) ! both rim 0 and rim 1 have the same weights + idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( ir - 1 ) *0.5 ) ! tanh formulation + ! idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic + ! idx_bdy(ib_bdy)%nbw(ib,igrd) = REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)) ! linear + END DO + END DO + + ! Compute damping coefficients + ! ---------------------------- + DO igrd = 1, jpbgrd + DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) + ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) ) ! both rim 0 and rim 1 have the same damping coefficients + idx_bdy(ib_bdy)%nbd(ib,igrd) = 1. / ( rn_time_dmp(ib_bdy) * rday ) & + & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic + idx_bdy(ib_bdy)%nbdout(ib,igrd) = 1. / ( rn_time_dmp_out(ib_bdy) * rday ) & + & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic + END DO + END DO + + END DO ! ib_bdy + + ! ------------------------------------------------------ + ! Initialise masks and find normal/tangential directions + ! ------------------------------------------------------ + + ! ------------------------------------------ + ! handle rim0, do as if rim 1 was free ocean + ! ------------------------------------------ + + ztmask(:,:) = tmask(:,:,1) ; zumask(:,:) = umask(:,:,1) ; zvmask(:,:) = vmask(:,:,1) + ! For the flagu/flagv calculation below we require a version of fmask without + ! the land boundary condition (shlat) included: + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zfmask(ji,jj) = ztmask(ji,jj ) * ztmask(ji+1,jj ) & + & * ztmask(ji,jj+1) * ztmask(ji+1,jj+1) + END DO ; END DO + CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp ) + + ! Read global 2D mask at T-points: bdytmask + ! ----------------------------------------- + ! bdytmask = 1 on the computational domain but not on open boundaries + ! = 0 elsewhere + + bdytmask(:,:) = ssmask(:,:) + + ! Derive mask on U and V grid from mask on T grid + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + bdyumask(ji,jj) = bdytmask(ji,jj) * bdytmask(ji+1,jj ) + bdyvmask(ji,jj) = bdytmask(ji,jj) * bdytmask(ji ,jj+1) + END DO ; END DO + CALL lbc_lnk( 'bdyini', bdyumask, 'U', 1.0_wp , bdyvmask, 'V', 1.0_wp ) ! Lateral boundary cond. + + ! bdy masks are now set to zero on rim 0 points: + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 + bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 + bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 + bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp + END DO + END DO + + CALL bdy_rim_treat( zumask, zvmask, zfmask, .true. ) ! compute flagu, flagv, ntreat on rim 0 + + ! ------------------------------------ + ! handle rim1, do as if rim 0 was land + ! ------------------------------------ + + ! z[tuv]mask are now set to zero on rim 0 points: + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 + ztmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 + zumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 + zvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp + END DO + END DO + + ! Recompute zfmask + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zfmask(ji,jj) = ztmask(ji,jj ) * ztmask(ji+1,jj ) & + & * ztmask(ji,jj+1) * ztmask(ji+1,jj+1) + END DO ; END DO + CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp ) + + ! bdy masks are now set to zero on rim1 points: + DO ib_bdy = 1, nb_bdy + DO ib = idx_bdy(ib_bdy)%nblenrim0(1) + 1, idx_bdy(ib_bdy)%nblenrim(1) ! extent of rim 1 + bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp + END DO + DO ib = idx_bdy(ib_bdy)%nblenrim0(2) + 1, idx_bdy(ib_bdy)%nblenrim(2) ! extent of rim 1 + bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp + END DO + DO ib = idx_bdy(ib_bdy)%nblenrim0(3) + 1, idx_bdy(ib_bdy)%nblenrim(3) ! extent of rim 1 + bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp + END DO + END DO + + CALL bdy_rim_treat( zumask, zvmask, zfmask, .false. ) ! compute flagu, flagv, ntreat on rim 1 + ! + ! Check which boundaries might need communication + ALLOCATE( lsend_bdyint(nb_bdy,jpbgrd,8,0:1), lrecv_bdyint(nb_bdy,jpbgrd,8,0:1) ) + lsend_bdyint(:,:,:,:) = .false. + lrecv_bdyint(:,:,:,:) = .false. + ALLOCATE( lsend_bdyext(nb_bdy,jpbgrd,8,0:1), lrecv_bdyext(nb_bdy,jpbgrd,8,0:1) ) + lsend_bdyext(:,:,:,:) = .false. + lrecv_bdyext(:,:,:,:) = .false. + ! + DO ib_bdy = 1, nb_bdy + DO igrd = 1, jpbgrd + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) + IF( idx_bdy(ib_bdy)%ntreat(ib,igrd) == -1 ) CYCLE + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + ir = idx_bdy(ib_bdy)%nbr(ib,igrd) + flagu = NINT(idx_bdy(ib_bdy)%flagu(ib,igrd)) + flagv = NINT(idx_bdy(ib_bdy)%flagv(ib,igrd)) + iibe = ii - flagu ! neighbouring point towards the exterior of the computational domain + ijbe = ij - flagv + iibi = ii + flagu ! neighbouring point towards the interior of the computational domain + ijbi = ij + flagv + CALL find_neib( ii, ij, idx_bdy(ib_bdy)%ntreat(ib,igrd), ii1, ij1, ii2, ij2, ii3, ij3 ) ! free ocean neighbours + ! + ! take care of the 4 sides + ! + DO icnt = 1, 4 + SELECT CASE( icnt ) + ! ... _____ + CASE( 1 ) ! x: rim on rcvwe/sndea-side o| : + ! o: potential neighbour(s) o|x : + ! outside of the MPI domain ..o|__:__ + iRnei = jpwe ; iSnei = jpea + iiRst = 1 ; ijRst = Njs0 ! Rcv we-side starting point, excluding sw-corner + iiRnd = nn_hls ; ijRnd = Nje0 ! Rcv we-side ending point, excluding nw-corner + iiSst = Nie0-nn_hls+1 ; ijSst = Njs0 ! Snd ea-side starting point, excluding se-corner + iiSnd = Nie0 ; ijSnd = Nje0 ! Snd ea-side ending point, excluding ne-corner + iioutdir = -1 ; ijoutdir = -999 ! outside MPI domain: westward + ! ______.... + CASE( 2 ) ! x: rim on rcvea/sndwe-side : |o + ! o: potential neighbour(s) : x|o + ! outside of the MPI domain ___:__|o.. + iRnei = jpea ; iSnei = jpwe + iiRst = Nie0+1 ; ijRst = Njs0 ! Rcv ea-side starting point, excluding se-corner + iiRnd = jpi ; ijRnd = Nje0 ! Rcv ea-side ending point, excluding ne-corner + iiSst = Nis0 ; ijSst = Njs0 ! Snd we-side starting point, excluding sw-corner + iiSnd = Nis0+nn_hls-1 ; ijSnd = Nje0 ! Snd we-side ending point, excluding nw-corner + iioutdir = 1 ; ijoutdir = -999 ! outside MPI domain: eastward + ! + CASE( 3 ) ! x: rim on rcvso/sndno-side | | + ! o: potential neighbour(s) |¨¨¨¨¨¨¨| + ! outside of the MPI domain |___x___| + ! : o o o : + ! : : + iRnei = jpso ; iSnei = jpno + iiRst = Nis0 ; ijRst = 1 ! Rcv so-side starting point, excluding sw-corner + iiRnd = Nie0 ; ijRnd = nn_hls ! Rcv so-side ending point, excluding se-corner + iiSst = Nis0 ; ijSst = Nje0-nn_hls+1 ! Snd no-side starting point, excluding nw-corner + iiSnd = Nie0 ; ijSnd = Nje0 ! Snd no-side ending point, excluding ne-corner + iioutdir = -999 ; ijoutdir = -1 ! outside MPI domain: southward + ! : : + CASE( 4 ) ! x: rim on rcvno/sndso-side :_o_o_o_: + ! o: potential neighbour(s) | x | + ! outside of the MPI domain | | + ! |¨¨¨¨¨¨¨| + iRnei = jpno ; iSnei = jpso + iiRst = Nis0 ; ijRst = Nje0+1 ! Rcv no-side starting point, excluding nw-corner + iiRnd = Nie0 ; ijRnd = jpj ! Rcv no-side ending point, excluding ne-corner + iiSst = Nis0 ; ijSst = Njs0 ! Snd so-side starting point, excluding sw-corner + iiSnd = Nie0 ; ijSnd = Njs0+nn_hls-1 ! Snd so-side ending point, excluding se-corner + iioutdir = -999 ; ijoutdir = 1 ! outside MPI domain: northward + END SELECT + ! + IF( ii >= iiRst .AND. ii <= iiRnd .AND. ij >= ijRst .AND. ij <= ijRnd ) THEN ! rim point in recv side + iiout = ii+iioutdir ; ijout = ij+ijoutdir ! in which direction do we go outside of the MPI domain? + ! take care of neighbourg(s) in the interior of the computational domain + IF( iibi==iiout .OR. ii1==iiout .OR. ii2==iiout .OR. ii3==iiout .OR. & ! Neib outside of the MPI domain + & ijbi==ijout .OR. ij1==ijout .OR. ij2==ijout .OR. ij3==ijout ) THEN ! -> I cannot compute it -> recv it + IF( mpiRnei(nn_hls,iRnei) > -1 ) lrecv_bdyint(ib_bdy,igrd,iRnei,ir) = .TRUE. + ENDIF + ! take care of neighbourg in the exterior of the computational domain + IF( iibe==iiout .OR. ijbe==ijout ) THEN ! Neib outside of the MPI domain -> I cannot compute it -> recv it + IF( mpiRnei(nn_hls,iRnei) > -1 ) lrecv_bdyext(ib_bdy,igrd,iRnei,ir) = .TRUE. + ENDIF + ENDIF + + IF( ii >= iiSst .AND. ii <= iiSnd .AND. ij >= ijSst .AND. ij <= ijSnd ) THEN ! rim point in send side + iiout = ii+iioutdir ; ijout = ij+ijoutdir ! in which direction do we go outside of the nei MPI domain? + ! take care of neighbourg(s) in the interior of the computational domain + IF( iibi==iiout .OR. ii1==iiout .OR. ii2==iiout .OR. ii3==iiout .OR. & ! Neib outside of nei MPI domain + & ijbi==ijout .OR. ij1==ijout .OR. ij2==ijout .OR. ij3==ijout ) THEN ! -> nei cannot compute it + IF( mpiSnei(nn_hls,iSnei) > -1 ) lsend_bdyint(ib_bdy,igrd,iSnei,ir) = .TRUE. ! -> send to nei + ENDIF + ! take care of neighbourg in the exterior of the computational domain + IF( iibe == iiout .OR. ijbe == ijout ) THEN ! Neib outside of the nei MPI domain -> nei cannot compute it + IF( mpiSnei(nn_hls,iSnei) > -1 ) lsend_bdyext(ib_bdy,igrd,iSnei,ir) = .TRUE. ! -> send to nei + ENDIF + END IF + + END DO ! 4 sides + ! + ! specific treatment for the corners + ! + DO icnt = 1, 4 + SELECT CASE( icnt ) + ! ...|.... + CASE( 1 ) ! x: rim on sw-corner o| : + ! o: potential neighbour(s) o|x__:__ + ! outside of the MPI domain o o o: + ! : + iRdiag = jpsw ; iRsono = jpso ! Recv: for sw or so + iSdiag = jpne ; iSsono = jpno ! Send: to ne or no + iiRst = 1 ; ijRst = 1 ! Rcv sw-corner starting point + iiRnd = nn_hls ; ijRnd = nn_hls ! Rcv sw-corner ending point + iiSstdiag = Nie0-nn_hls+1 ; ijSstdiag = Nje0-nn_hls+1 ! send to sw-corner of ne neighbourg + iiSnddiag = Nie0 ; ijSnddiag = Nje0 ! send to sw-corner of ne neighbourg + iiSstsono = 1 ; ijSstsono = Nje0-nn_hls+1 ! send to sw-corner of no neighbourg + iiSndsono = nn_hls ; ijSndsono = Nje0 ! send to sw-corner of no neighbourg + iioutdir = -1 ; ijoutdir = -1 ! outside MPI domain: westward or southward + ! ....|... + CASE( 2 ) ! x: rim on se-corner : |o + ! o: potential neighbour(s) __:__x|o + ! outside of the MPI domain :o o o + ! : + iRdiag = jpse ; iRsono = jpso ! Recv: for se or so + iSdiag = jpnw ; iSsono = jpno ! Send: to nw or no + iiRst = Nie0+1 ; ijRst = 1 ! Rcv se-corner starting point + iiRnd = jpi ; ijRnd = nn_hls ! Rcv se-corner ending point + iiSstdiag = Nis0 ; ijSstdiag = Nje0-nn_hls+1 ! send to se-corner of nw neighbourg + iiSnddiag = Nis0+nn_hls-1 ; ijSnddiag = Nje0 ! send to se-corner of nw neighbourg + iiSstsono = Nie0+1 ; ijSstsono = Nje0-nn_hls+1 ! send to se-corner of no neighbourg + iiSndsono = jpi ; ijSndsono = Nje0 ! send to se-corner of no neighbourg + iioutdir = 1 ; ijoutdir = -1 ! outside MPI domain: eastward or southward + ! : + ! o o_o:___ + CASE( 3 ) ! x: rim on nw-corner o|x : + ! o: potential neighbour(s) ..o|...: + ! outside of the MPI domain | + iRdiag = jpnw ; iRsono = jpno ! Recv: for nw or no + iSdiag = jpse ; iSsono = jpso ! Send: to se or so + iiRst = 1 ; ijRst = Nje0+1 ! Rcv nw-corner starting point + iiRnd = nn_hls ; ijRnd = jpj ! Rcv nw-corner ending point + iiSstdiag = Nie0-nn_hls+1 ; ijSstdiag = Njs0 ! send to nw-corner of se neighbourg + iiSnddiag = Nie0 ; ijSnddiag = Njs0+nn_hls-1 ! send to nw-corner of se neighbourg + iiSstsono = 1 ; ijSstsono = Njs0 ! send to nw-corner of so neighbourg + iiSndsono = nn_hls ; ijSndsono = Njs0+nn_hls-1 ! send to nw-corner of so neighbourg + iioutdir = -1 ; ijoutdir = 1 ! outside MPI domain: westward or northward + ! : + ! ___:o_o o + CASE( 4 ) ! x: rim on ne-corner : x|o + ! o: potential neighbour(s) :...|o... + ! outside of the MPI domain | + iRdiag = jpne ; iRsono = jpno ! Recv: for ne or no + iSdiag = jpsw ; iSsono = jpso ! Send: to sw or so + iiRst = Nie0+1 ; ijRst = Nje0+1 ! Rcv ne-corner starting point + iiRnd = jpi ; ijRnd = jpj ! Rcv ne-corner ending point + iiSstdiag = Nis0 ; ijSstdiag = Njs0 ! send to ne-corner of sw neighbourg + iiSnddiag = Nis0+nn_hls-1 ; ijSnddiag = Njs0+nn_hls-1 ! send to ne-corner of sw neighbourg + iiSstsono = Nie0+1 ; ijSstsono = Njs0 ! send to ne-corner of so neighbourg + iiSndsono = jpi ; ijSndsono = Njs0+nn_hls-1 ! send to ne-corner of so neighbourg + iioutdir = 1 ; ijoutdir = 1 ! outside MPI domain: eastward or southward + END SELECT + ! + ! Check if we need to receive data for this rim point + IF( ii >= iiRst .AND. ii <= iiRnd .AND. ij >= ijRst .AND. ij <= ijRnd ) THEN ! rim point on the corner + iiout = ii+iioutdir ; ijout = ij+ijoutdir ! in which direction do we go outside of the MPI domain? + ! take care of neighbourg(s) in the interior of the computational domain + IF( iibi==iiout .OR. ii1==iiout .OR. ii2==iiout .OR. ii3==iiout .OR. & ! Neib outside of the MPI domain + & ijbi==ijout .OR. ij1==ijout .OR. ij2==ijout .OR. ij3==ijout ) THEN ! -> I cannot compute it -> recv it + IF( mpiRnei(nn_hls,iRdiag) > -1 ) lrecv_bdyint(ib_bdy,igrd,iRdiag,ir) = .TRUE. ! Receive directly from diagonal neighbourg + IF( mpiRnei(nn_hls,iRsono) > -1 .AND. nn_comm == 1 ) lrecv_bdyint(ib_bdy,igrd,iRsono,ir) = .TRUE. ! Receive through the South/North neighbourg + ENDIF + ! take care of neighbourg in the exterior of the computational domain + IF( iibe==iiout .OR. ijbe==ijout ) THEN ! Neib outside of the MPI domain -> I cannot compute it -> recv it + IF( mpiRnei(nn_hls,iRdiag) > -1 ) lrecv_bdyext(ib_bdy,igrd,iRdiag,ir) = .TRUE. ! Receive directly from diagonal neighbourg + IF( mpiRnei(nn_hls,iRsono) > -1 .AND. nn_comm == 1 ) lrecv_bdyext(ib_bdy,igrd,iRsono,ir) = .TRUE. ! Receive through the South/North neighbourg + ENDIF + ENDIF + ! + ! Check if this rim point corresponds to the corner of one neighbourg. if yes, do we need to send data? + ! Direct send to diag: Is this rim point the corner point of a diag neighbour with which we communicate? + IF( ii >= iiSstdiag .AND. ii <= iiSnddiag .AND. ij >= ijSstdiag .AND. ij <= ijSnddiag & + & .AND. mpiSnei(nn_hls,iSdiag) > -1 ) THEN + iiout = ii+iioutdir ; ijout = ij+ijoutdir ! in which direction do we go outside of the nei MPI domain? + ! take care of neighbourg(s) in the interior of the computational domain + IF( iibi==iiout .OR. ii1==iiout .OR. ii2==iiout .OR. ii3==iiout .OR. & ! Neib outside of diag nei MPI + & ijbi==ijout .OR. ij1==ijout .OR. ij2==ijout .OR. ij3==ijout ) & ! domain -> nei cannot compute it + & lsend_bdyint(ib_bdy,igrd,iSdiag,ir) = .TRUE. ! send rim point data to diag nei + ! take care of neighbourg in the exterior of the computational domain + IF( iibe==iiout .OR. ijbe==ijout ) & + & lsend_bdyext(ib_bdy,igrd,iSdiag,ir) = .TRUE. + ENDIF + ! Indirect send to diag (through so/no): rim point is the corner point of a so/no nei with which we communicate + IF( ii >= iiSstsono .AND. ii <= iiSndsono .AND. ij >= ijSstsono .AND. ij <= ijSndsono & + & .AND. mpiSnei(nn_hls,iSsono) > -1 .AND. nn_comm == 1 ) THEN + iiout = ii+iioutdir ; ijout = ij+ijoutdir ! in which direction do we go outside of the nei MPI domain? + ! take care of neighbourg(s) in the interior of the computational domain + IF( iibi==iiout .OR. ii1==iiout .OR. ii2==iiout .OR. ii3==iiout .OR. & ! Neib outside of so/no nei MPI + & ijbi==ijout .OR. ij1==ijout .OR. ij2==ijout .OR. ij3==ijout ) & ! domain -> nei cannot compute it + & lsend_bdyint(ib_bdy,igrd,iSsono,ir) = .TRUE. ! send rim point data to so/no nei + ! take care of neighbourg in the exterior of the computational domain + IF( iibe==iiout .OR. ijbe==ijout ) & + & lsend_bdyext(ib_bdy,igrd,iSsono,ir) = .TRUE. + ENDIF + ! + END DO ! 4 corners + END DO ! ib + END DO ! igrd + + ! Comment out for debug +!!$ DO ir = 0,1 +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'T', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyint(ib_bdy,1,:,ir), lrecv = lrecv_bdyint(ib_bdy,1,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug int T', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'U', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyint(ib_bdy,2,:,ir), lrecv = lrecv_bdyint(ib_bdy,2,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug int U', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'V', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyint(ib_bdy,3,:,ir), lrecv = lrecv_bdyint(ib_bdy,3,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug int V', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'T', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyext(ib_bdy,1,:,ir), lrecv = lrecv_bdyext(ib_bdy,1,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug ext T', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'U', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyext(ib_bdy,2,:,ir), lrecv = lrecv_bdyext(ib_bdy,2,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug ext U', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'V', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyext(ib_bdy,3,:,ir), lrecv = lrecv_bdyext(ib_bdy,3,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug ext V', ir ; CALL FLUSH(numout) +!!$ END DO + + END DO ! ib_bdy + + DO ib_bdy = 1,nb_bdy + IF( cn_dyn2d(ib_bdy) == 'orlanski' .OR. cn_dyn2d(ib_bdy) == 'orlanski_npo' .OR. & + & cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' .OR. & + & cn_tra(ib_bdy) == 'orlanski' .OR. cn_tra(ib_bdy) == 'orlanski_npo' ) THEN + DO igrd = 1, jpbgrd + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( mig0(ii) > 2 .AND. mig0(ii) < Ni0glo-2 .AND. mjg0(ij) > 2 .AND. mjg0(ij) < Nj0glo-2 ) THEN + WRITE(ctmp1,*) ' Orlanski is not safe when the open boundaries are on the interior of the computational domain' + CALL ctl_stop( ctmp1 ) + END IF + END DO + END DO + END IF + END DO + ! + DEALLOCATE( nbidta, nbjdta, nbrdta ) + ! + END SUBROUTINE bdy_def + + + SUBROUTINE bdy_rim_treat( pumask, pvmask, pfmask, lrim0 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_rim_treat *** + !! + !! ** Purpose : Initialize structures ( flagu, flagv, ntreat ) indicating how rim points + !! are to be handled in the boundary condition treatment + !! + !! ** Method : - to handle rim 0 zmasks must indicate ocean points (set at one on rim 0 and rim 1 and interior) + !! and bdymasks must be set at 0 on rim 0 (set at one on rim 1 and interior) + !! (as if rim 1 was free ocean) + !! - to handle rim 1 zmasks must be set at 0 on rim 0 (set at one on rim 1 and interior) + !! and bdymasks must indicate free ocean points (set at one on interior) + !! (as if rim 0 was land) + !! - we can then check in which direction the interior of the computational domain is with the difference + !! mask array values on both sides to compute flagu and flagv + !! - and look at the ocean neighbours to compute ntreat + !!---------------------------------------------------------------------- + REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pumask, pvmask ! temporary u/v mask array + REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pfmask ! temporary fmask excluding coastal boundary condition (shlat) + LOGICAL , INTENT (in ) :: lrim0 ! .true. -> rim 0 .false. -> rim 1 + INTEGER :: ib_bdy, ii, ij, igrd, ib, icount ! dummy loop indices + INTEGER :: i_offset, j_offset, inn ! local integer + INTEGER :: ibeg, iend ! local integer + LOGICAL :: llnon, llson, llean, llwen ! local logicals indicating the presence of a ocean neighbour + REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields + REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars + CHARACTER(LEN=1), DIMENSION(jpbgrd) :: cgrid + REAL(wp) , DIMENSION(jpi,jpj) :: ztmp + !!---------------------------------------------------------------------- + + cgrid = (/'t','u','v'/) + + DO ib_bdy = 1, nb_bdy ! Indices and directions of rim velocity components + + DO igrd = 1, jpbgrd + + IF( lrim0 ) THEN ! extent of rim 0 + ibeg = 1 ; iend = idx_bdy(ib_bdy)%nblenrim0(igrd) + ELSE ! extent of rim 1 + ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1 ; iend = idx_bdy(ib_bdy)%nblenrim(igrd) + END IF + + ! Calculate relationship of U direction to the local orientation of the boundary + ! flagu = -1 : u component is normal to the dynamical boundary and its direction is outward + ! flagu = 0 : u is tangential + ! flagu = 1 : u is normal to the boundary and is direction is inward + SELECT CASE( igrd ) + CASE( 1 ) ; zmask => pumask ; i_offset = 0 ! U(i-1) T(i) U(i ) + CASE( 2 ) ; zmask => bdytmask ; i_offset = 1 ! T(i ) U(i) T(i+1) + CASE( 3 ) ; zmask => pfmask ; i_offset = 0 ! F(i-1) V(i) F(i ) + END SELECT + icount = 0 + ztmp(:,:) = -999._wp + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( ii < Nis0 .OR. ii > Nie0 .OR. ij < Njs0 .OR. ij > Nje0 ) CYCLE ! call lbc_lnk -> no need to compute these pts + zwfl = zmask(ii+i_offset-1,ij) + zefl = zmask(ii+i_offset ,ij) + ! This error check only works if you are using the bdyXmask arrays (which are set to 0 on rims) + IF( i_offset == 1 .and. zefl + zwfl == 2._wp ) THEN + icount = icount + 1 + IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) + ELSE + ztmp(ii,ij) = -zwfl + zefl + ENDIF + END DO + IF( icount /= 0 ) THEN + WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,', & + ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy + CALL ctl_stop( ctmp1 ) + ENDIF + SELECT CASE( igrd ) + CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) + END SELECT + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + idx_bdy(ib_bdy)%flagu(ib,igrd) = ztmp(ii,ij) + END DO + + ! Calculate relationship of V direction to the local orientation of the boundary + ! flagv = -1 : v component is normal to the dynamical boundary but its direction is outward + ! flagv = 0 : v is tangential + ! flagv = 1 : v is normal to the boundary and is direction is inward + SELECT CASE( igrd ) + CASE( 1 ) ; zmask => pvmask ; j_offset = 0 + CASE( 2 ) ; zmask => pfmask ; j_offset = 0 + CASE( 3 ) ; zmask => bdytmask ; j_offset = 1 + END SELECT + icount = 0 + ztmp(:,:) = -999._wp + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( ii < Nis0 .OR. ii > Nie0 .OR. ij < Njs0 .OR. ij > Nje0 ) CYCLE ! call lbc_lnk -> no need to compute these pts + zsfl = zmask(ii,ij+j_offset-1) + znfl = zmask(ii,ij+j_offset ) + ! This error check only works if you are using the bdyXmask arrays (which are set to 0 on rims) + IF( j_offset == 1 .and. znfl + zsfl == 2._wp ) THEN + IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) + icount = icount + 1 + ELSE + ztmp(ii,ij) = -zsfl + znfl + END IF + END DO + IF( icount /= 0 ) THEN + WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,', & + ' are not boundary points (flagv calculation). Check nbi, nbj, indices for boundary set ',ib_bdy + CALL ctl_stop( ctmp1 ) + ENDIF + SELECT CASE( igrd ) + CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) + END SELECT + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + idx_bdy(ib_bdy)%flagv(ib,igrd) = ztmp(ii,ij) + END DO + + ! Calculate ntreat + SELECT CASE( igrd ) + CASE( 1 ) ; zmask => bdytmask + CASE( 2 ) ; zmask => bdyumask + CASE( 3 ) ; zmask => bdyvmask + END SELECT + ztmp(:,:) = -999._wp + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( ii < Nis0 .OR. ii > Nie0 .OR. ij < Njs0 .OR. ij > Nje0 ) CYCLE ! call lbc_lnk -> no need to compute these pts + llnon = zmask(ii ,ij+1) == 1._wp + llson = zmask(ii ,ij-1) == 1._wp + llean = zmask(ii+1,ij ) == 1._wp + llwen = zmask(ii-1,ij ) == 1._wp + inn = COUNT( (/ llnon, llson, llean, llwen /) ) + IF( inn == 0 ) THEN ! no neighbours -> interior of a corner or cluster of rim points + ! ! ! _____ ! _____ ! __ __ + ! 1 | o ! 2 o | ! 3 | x ! 4 x | ! | | -> error + ! |_x_ _ ! _ _x_| ! | o ! o | ! |x_x| + IF( zmask(ii+1,ij+1) == 1._wp ) THEN ; ztmp(ii,ij) = 1._wp + ELSEIF( zmask(ii-1,ij+1) == 1._wp ) THEN ; ztmp(ii,ij) = 2._wp + ELSEIF( zmask(ii+1,ij-1) == 1._wp ) THEN ; ztmp(ii,ij) = 3._wp + ELSEIF( zmask(ii-1,ij-1) == 1._wp ) THEN ; ztmp(ii,ij) = 4._wp + ELSE ; ztmp(ii,ij) = -1._wp + WRITE(ctmp1,*) 'Problem with ',cgrid(igrd) ,' grid point', ii, ij, & + ' on boundary set ', ib_bdy, ' has no free ocean neighbour' + IF( lrim0 ) THEN + WRITE(ctmp2,*) ' There seems to be a cluster of rim 0 points.' + ELSE + WRITE(ctmp2,*) ' There seems to be a cluster of rim 1 points.' + END IF + CALL ctl_warn( ctmp1, ctmp2 ) + END IF + END IF + IF( inn == 1 ) THEN ! middle of linear bdy or incomplete corner ! ___ o + ! | ! | ! o ! ______ ! |x___ + ! 5 | x o ! 6 o x | ! 7 __x__ ! 8 x + ! | ! | ! ! o + IF( llean ) ztmp(ii,ij) = 5._wp + IF( llwen ) ztmp(ii,ij) = 6._wp + IF( llnon ) ztmp(ii,ij) = 7._wp + IF( llson ) ztmp(ii,ij) = 8._wp + END IF + IF( inn == 2 ) THEN ! exterior of a corner + ! o ! o ! _____| ! |_____ + ! 9 ____x o ! 10 o x___ ! 11 x o ! 12 o x + ! | ! | ! o ! o + IF( llnon .AND. llean ) ztmp(ii,ij) = 9._wp + IF( llnon .AND. llwen ) ztmp(ii,ij) = 10._wp + IF( llson .AND. llean ) ztmp(ii,ij) = 11._wp + IF( llson .AND. llwen ) ztmp(ii,ij) = 12._wp + END IF + IF( inn == 3 ) THEN ! 3 neighbours __ __ + ! |_ o ! o _| ! |_| ! o + ! 13 _| x o ! 14 o x |_ ! 15 o x o ! 16 o x o + ! | o ! o | ! o ! __|¨|__ + IF( llnon .AND. llean .AND. llson ) ztmp(ii,ij) = 13._wp + IF( llnon .AND. llwen .AND. llson ) ztmp(ii,ij) = 14._wp + IF( llwen .AND. llson .AND. llean ) ztmp(ii,ij) = 15._wp + IF( llwen .AND. llnon .AND. llean ) ztmp(ii,ij) = 16._wp + END IF + IF( inn == 4 ) THEN + WRITE(ctmp1,*) 'Problem with ',cgrid(igrd) ,' grid point', ii, ij, & + ' on boundary set ', ib_bdy, ' have 4 neighbours' + CALL ctl_stop( ctmp1 ) + END IF + END DO + SELECT CASE( igrd ) + CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) + END SELECT + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + idx_bdy(ib_bdy)%ntreat(ib,igrd) = NINT(ztmp(ii,ij)) + END DO + ! + END DO ! jpbgrd + ! + END DO ! ib_bdy + + END SUBROUTINE bdy_rim_treat + + + SUBROUTINE find_neib( ii, ij, itreat, ii1, ij1, ii2, ij2, ii3, ij3 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE find_neib *** + !! + !! ** Purpose : get ii1, ij1, ii2, ij2, ii3, ij3, the indices of + !! the free ocean neighbours of (ii,ij) for bdy treatment + !! + !! ** Method : use itreat input to select a case + !! N.B. ntreat is defined for all bdy points in routine bdy_rim_treat + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: ii, ij, itreat + INTEGER, INTENT( out) :: ii1, ij1, ii2, ij2, ii3, ij3 + !!---------------------------------------------------------------------- + SELECT CASE( itreat ) ! points that will be used by bdy routines, -1 will be discarded + ! ! ! _____ ! _____ + ! 1 | o ! 2 o | ! 3 | x ! 4 x | + ! |_x_ _ ! _ _x_| ! | o ! o | + CASE( 1 ) ; ii1 = ii+1 ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 2 ) ; ii1 = ii-1 ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 3 ) ; ii1 = ii+1 ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 4 ) ; ii1 = ii-1 ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + ! | ! | ! o ! ______ ! or incomplete corner + ! 5 | x o ! 6 o x | ! 7 __x__ ! 8 x ! 7 ____ o + ! | ! | ! ! o ! |x___ + CASE( 5 ) ; ii1 = ii+1 ; ij1 = ij ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 6 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 7 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 8 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + ! o ! o ! _____| ! |_____ + ! 9 ____x o ! 10 o x___ ! 11 x o ! 12 o x + ! | ! | ! o ! o + CASE( 9 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 + CASE( 10 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 + CASE( 11 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 + CASE( 12 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 + ! |_ o ! o _| ! ¨¨|_|¨¨ ! o + ! 13 _| x o ! 14 o x |_ ! 15 o x o ! 16 o x o + ! | o ! o | ! o ! __|¨|__ + CASE( 13 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 + CASE( 14 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 + CASE( 15 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij-1 ; ii3 = ii+1 ; ij3 = ij + CASE( 16 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij+1 ; ii3 = ii+1 ; ij3 = ij + END SELECT + END SUBROUTINE find_neib + + + SUBROUTINE bdy_read_seg( kb_bdy, knblendta ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_read_seg *** + !! + !! ** Purpose : build bdy coordinates with segments defined in namelist + !! + !! ** Method : read namelist nambdy_index blocks + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT (in ) :: kb_bdy ! bdy number + INTEGER, DIMENSION(jpbgrd), INTENT ( out) :: knblendta ! length of index arrays + !! + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: nbdyind, nbdybeg, nbdyend + INTEGER :: nbdy_count, nbdy_rdstart, nbdy_loc + CHARACTER(LEN=1) :: ctypebdy ! - - + CHARACTER(LEN=50):: cerrmsg ! - - + NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend + !!---------------------------------------------------------------------- + ! Need to support possibility of reading more than one nambdy_index from + ! the namelist_cfg internal file. + ! Do this by finding the kb_bdy'th occurence of nambdy_index in the + ! character buffer as the starting point. + nbdy_rdstart = 1 + DO nbdy_count = 1, kb_bdy + nbdy_loc = INDEX( numnam_cfg( nbdy_rdstart: ), 'nambdy_index' ) + IF( nbdy_loc .GT. 0 ) THEN + nbdy_rdstart = nbdy_rdstart + nbdy_loc + ELSE + WRITE(cerrmsg,'(A,I4,A)') 'Error: entry number ',kb_bdy,' of nambdy_index not found' + ios = -1 + CALL ctl_nam ( ios , cerrmsg ) + ENDIF + END DO + nbdy_rdstart = MAX( 1, nbdy_rdstart - 2 ) + READ ( numnam_cfg( nbdy_rdstart: ), nambdy_index, IOSTAT = ios, ERR = 904) +904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_index in configuration namelist' ) + IF(lwm) WRITE ( numond, nambdy_index ) + + SELECT CASE ( TRIM(ctypebdy) ) + CASE( 'N' ) + IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 + nbdyind = Nj0glo - 2 ! set boundary to whole side of model domain. + nbdybeg = 2 + nbdyend = Ni0glo - 1 + ENDIF + nbdysegn = nbdysegn + 1 + npckgn(nbdysegn) = kb_bdy ! Save bdy package number + jpjnob(nbdysegn) = nbdyind + jpindt(nbdysegn) = nbdybeg + jpinft(nbdysegn) = nbdyend + ! + CASE( 'S' ) + IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 + nbdyind = 2 ! set boundary to whole side of model domain. + nbdybeg = 2 + nbdyend = Ni0glo - 1 + ENDIF + nbdysegs = nbdysegs + 1 + npckgs(nbdysegs) = kb_bdy ! Save bdy package number + jpjsob(nbdysegs) = nbdyind + jpisdt(nbdysegs) = nbdybeg + jpisft(nbdysegs) = nbdyend + ! + CASE( 'E' ) + IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 + nbdyind = Ni0glo - 2 ! set boundary to whole side of model domain. + nbdybeg = 2 + nbdyend = Nj0glo - 1 + ENDIF + nbdysege = nbdysege + 1 + npckge(nbdysege) = kb_bdy ! Save bdy package number + jpieob(nbdysege) = nbdyind + jpjedt(nbdysege) = nbdybeg + jpjeft(nbdysege) = nbdyend + ! + CASE( 'W' ) + IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 + nbdyind = 2 ! set boundary to whole side of model domain. + nbdybeg = 2 + nbdyend = Nj0glo - 1 + ENDIF + nbdysegw = nbdysegw + 1 + npckgw(nbdysegw) = kb_bdy ! Save bdy package number + jpiwob(nbdysegw) = nbdyind + jpjwdt(nbdysegw) = nbdybeg + jpjwft(nbdysegw) = nbdyend + ! + CASE DEFAULT ; CALL ctl_stop( 'ctypebdy must be N, S, E or W' ) + END SELECT + + ! For simplicity we assume that in case of straight bdy, arrays have the same length + ! (even if it is true that last tangential velocity points + ! are useless). This simplifies a little bit boundary data format (and agrees with format + ! used so far in obc package) + + knblendta(1:jpbgrd) = (nbdyend - nbdybeg + 1) * nn_rimwidth(kb_bdy) + + END SUBROUTINE bdy_read_seg + + + SUBROUTINE bdy_ctl_seg + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_ctl_seg *** + !! + !! ** Purpose : Check straight open boundary segments location + !! + !! ** Method : - Look for open boundary corners + !! - Check that segments start or end on land + !!---------------------------------------------------------------------- + INTEGER :: ib, ib1, ib2, ji ,jj, itest + INTEGER, DIMENSION(jp_nseg,2) :: icorne, icornw, icornn, icorns + REAL(wp), DIMENSION(2) :: ztestmask + !!---------------------------------------------------------------------- + ! + IF (lwp) WRITE(numout,*) ' ' + IF (lwp) WRITE(numout,*) 'bdy_ctl_seg: Check analytical segments' + IF (lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ! + IF(lwp) WRITE(numout,*) 'Number of east segments : ', nbdysege + IF(lwp) WRITE(numout,*) 'Number of west segments : ', nbdysegw + IF(lwp) WRITE(numout,*) 'Number of north segments : ', nbdysegn + IF(lwp) WRITE(numout,*) 'Number of south segments : ', nbdysegs + ! + ! 1. Check bounds + !---------------- + DO ib = 1, nbdysegn + IF (lwp) WRITE(numout,*) '**check north seg bounds pckg: ', npckgn(ib) + IF ((jpjnob(ib).ge.Nj0glo-1).or.& + &(jpjnob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) + IF (jpindt(ib).ge.jpinft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) + IF (jpindt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) + IF (jpinft(ib).gt.Ni0glo) CALL ctl_stop( 'End index out of domain' ) + END DO + ! + DO ib = 1, nbdysegs + IF (lwp) WRITE(numout,*) '**check south seg bounds pckg: ', npckgs(ib) + IF ((jpjsob(ib).ge.Nj0glo-1).or.& + &(jpjsob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) + IF (jpisdt(ib).ge.jpisft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) + IF (jpisdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) + IF (jpisft(ib).gt.Ni0glo) CALL ctl_stop( 'End index out of domain' ) + END DO + ! + DO ib = 1, nbdysege + IF (lwp) WRITE(numout,*) '**check east seg bounds pckg: ', npckge(ib) + IF ((jpieob(ib).ge.Ni0glo-1).or.& + &(jpieob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) + IF (jpjedt(ib).ge.jpjeft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) + IF (jpjedt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) + IF (jpjeft(ib).gt.Nj0glo) CALL ctl_stop( 'End index out of domain' ) + END DO + ! + DO ib = 1, nbdysegw + IF (lwp) WRITE(numout,*) '**check west seg bounds pckg: ', npckgw(ib) + IF ((jpiwob(ib).ge.Ni0glo-1).or.& + &(jpiwob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) + IF (jpjwdt(ib).ge.jpjwft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) + IF (jpjwdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) + IF (jpjwft(ib).gt.Nj0glo) CALL ctl_stop( 'End index out of domain' ) + ENDDO + ! + ! 2. Look for segment crossings + !------------------------------ + IF (lwp) WRITE(numout,*) '**Look for segments corners :' + ! + itest = 0 ! corner number + ! + ! flag to detect if start or end of open boundary belongs to a corner + ! if not (=0), it must be on land. + ! if a corner is detected, save bdy package number for further tests + icorne(:,:)=0. ; icornw(:,:)=0. ; icornn(:,:)=0. ; icorns(:,:)=0. + ! South/West crossings + IF ((nbdysegw > 0).AND.(nbdysegs > 0)) THEN + DO ib1 = 1, nbdysegw + DO ib2 = 1, nbdysegs + IF (( jpisdt(ib2)<=jpiwob(ib1)).AND. & + & ( jpisft(ib2)>=jpiwob(ib1)).AND. & + & ( jpjwdt(ib1)<=jpjsob(ib2)).AND. & + & ( jpjwft(ib1)>=jpjsob(ib2))) THEN + IF ((jpjwdt(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpiwob(ib1))) THEN + ! We have a possible South-West corner +! WRITE(numout,*) ' Found a South-West corner at (i,j): ', jpisdt(ib2), jpjwdt(ib1) +! WRITE(numout,*) ' between segments: ', npckgw(ib1), npckgs(ib2) + icornw(ib1,1) = npckgs(ib2) + icorns(ib2,1) = npckgw(ib1) + ELSEIF ((jpisft(ib2)==jpiwob(ib1)).AND.(jpjwft(ib1)==jpjsob(ib2))) THEN + WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & + & jpisft(ib2), jpjwft(ib1) + WRITE(ctmp2,*) ' Not allowed yet' + WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), & + & ' and South segment: ',npckgs(ib2) + CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) + ELSE + WRITE(ctmp1,*) ' Check South and West Open boundary indices' + WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1) , & + & ' and South segment: ',npckgs(ib2) + CALL ctl_stop( ctmp1, ctmp2 ) + END IF + END IF + END DO + END DO + END IF + ! + ! South/East crossings + IF ((nbdysege > 0).AND.(nbdysegs > 0)) THEN + DO ib1 = 1, nbdysege + DO ib2 = 1, nbdysegs + IF (( jpisdt(ib2)<=jpieob(ib1)+1).AND. & + & ( jpisft(ib2)>=jpieob(ib1)+1).AND. & + & ( jpjedt(ib1)<=jpjsob(ib2) ).AND. & + & ( jpjeft(ib1)>=jpjsob(ib2) )) THEN + IF ((jpjedt(ib1)==jpjsob(ib2)).AND.(jpisft(ib2)==jpieob(ib1)+1)) THEN + ! We have a possible South-East corner +! WRITE(numout,*) ' Found a South-East corner at (i,j): ', jpisft(ib2), jpjedt(ib1) +! WRITE(numout,*) ' between segments: ', npckge(ib1), npckgs(ib2) + icorne(ib1,1) = npckgs(ib2) + icorns(ib2,2) = npckge(ib1) + ELSEIF ((jpjeft(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpieob(ib1)+1)) THEN + WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & + & jpisdt(ib2), jpjeft(ib1) + WRITE(ctmp2,*) ' Not allowed yet' + WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & + & ' and South segment: ',npckgs(ib2) + CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) + ELSE + WRITE(ctmp1,*) ' Check South and East Open boundary indices' + WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & + & ' and South segment: ',npckgs(ib2) + CALL ctl_stop( ctmp1, ctmp2 ) + END IF + END IF + END DO + END DO + END IF + ! + ! North/West crossings + IF ((nbdysegn > 0).AND.(nbdysegw > 0)) THEN + DO ib1 = 1, nbdysegw + DO ib2 = 1, nbdysegn + IF (( jpindt(ib2)<=jpiwob(ib1) ).AND. & + & ( jpinft(ib2)>=jpiwob(ib1) ).AND. & + & ( jpjwdt(ib1)<=jpjnob(ib2)+1).AND. & + & ( jpjwft(ib1)>=jpjnob(ib2)+1)) THEN + IF ((jpjwft(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpiwob(ib1))) THEN + ! We have a possible North-West corner +! WRITE(numout,*) ' Found a North-West corner at (i,j): ', jpindt(ib2), jpjwft(ib1) +! WRITE(numout,*) ' between segments: ', npckgw(ib1), npckgn(ib2) + icornw(ib1,2) = npckgn(ib2) + icornn(ib2,1) = npckgw(ib1) + ELSEIF ((jpjwdt(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpiwob(ib1))) THEN + WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & + & jpinft(ib2), jpjwdt(ib1) + WRITE(ctmp2,*) ' Not allowed yet' + WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), & + & ' and North segment: ',npckgn(ib2) + CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) + ELSE + WRITE(ctmp1,*) ' Check North and West Open boundary indices' + WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1), & + & ' and North segment: ',npckgn(ib2) + CALL ctl_stop( ctmp1, ctmp2 ) + END IF + END IF + END DO + END DO + END IF + ! + ! North/East crossings + IF ((nbdysegn > 0).AND.(nbdysege > 0)) THEN + DO ib1 = 1, nbdysege + DO ib2 = 1, nbdysegn + IF (( jpindt(ib2)<=jpieob(ib1)+1).AND. & + & ( jpinft(ib2)>=jpieob(ib1)+1).AND. & + & ( jpjedt(ib1)<=jpjnob(ib2)+1).AND. & + & ( jpjeft(ib1)>=jpjnob(ib2)+1)) THEN + IF ((jpjeft(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpieob(ib1)+1)) THEN + ! We have a possible North-East corner +! WRITE(numout,*) ' Found a North-East corner at (i,j): ', jpinft(ib2), jpjeft(ib1) +! WRITE(numout,*) ' between segments: ', npckge(ib1), npckgn(ib2) + icorne(ib1,2) = npckgn(ib2) + icornn(ib2,2) = npckge(ib1) + ELSEIF ((jpjedt(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpieob(ib1)+1)) THEN + WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & + & jpindt(ib2), jpjedt(ib1) + WRITE(ctmp2,*) ' Not allowed yet' + WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & + & ' and North segment: ',npckgn(ib2) + CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) + ELSE + WRITE(ctmp1,*) ' Check North and East Open boundary indices' + WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & + & ' and North segment: ',npckgn(ib2) + CALL ctl_stop( ctmp1, ctmp2 ) + END IF + END IF + END DO + END DO + END IF + ! + ! 3. Check if segment extremities are on land + !-------------------------------------------- + ! + ! West segments + DO ib = 1, nbdysegw + ! get mask at boundary extremities: + ztestmask(1:2)=0. + DO ji = 1, jpi + DO jj = 1, jpj + IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwdt(ib) ) ztestmask(1) = tmask(ji,jj,1) + IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwft(ib) ) ztestmask(2) = tmask(ji,jj,1) + END DO + END DO + CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain + + IF (ztestmask(1)==1) THEN + IF (icornw(ib,1)==0) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) + CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) + ELSE + ! This is a corner + IF(lwp) WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) + CALL bdy_ctl_corn(npckgw(ib), icornw(ib,1)) + itest=itest+1 + ENDIF + ENDIF + IF (ztestmask(2)==1) THEN + IF (icornw(ib,2)==0) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) + CALL ctl_stop( ' ', ctmp1, ' does not end on land or on a corner' ) + ELSE + ! This is a corner + IF(lwp) WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) + CALL bdy_ctl_corn(npckgw(ib), icornw(ib,2)) + itest=itest+1 + ENDIF + ENDIF + END DO + ! + ! East segments + DO ib = 1, nbdysege + ! get mask at boundary extremities: + ztestmask(1:2)=0. + DO ji = 1, jpi + DO jj = 1, jpj + IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjedt(ib) ) ztestmask(1) = tmask(ji,jj,1) + IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjeft(ib) ) ztestmask(2) = tmask(ji,jj,1) + END DO + END DO + CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain + + IF (ztestmask(1)==1) THEN + IF (icorne(ib,1)==0) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) + CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) + ELSE + ! This is a corner + IF(lwp) WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) + CALL bdy_ctl_corn(npckge(ib), icorne(ib,1)) + itest=itest+1 + ENDIF + ENDIF + IF (ztestmask(2)==1) THEN + IF (icorne(ib,2)==0) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) + CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) + ELSE + ! This is a corner + IF(lwp) WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) + CALL bdy_ctl_corn(npckge(ib), icorne(ib,2)) + itest=itest+1 + ENDIF + ENDIF + END DO + ! + ! South segments + DO ib = 1, nbdysegs + ! get mask at boundary extremities: + ztestmask(1:2)=0. + DO ji = 1, jpi + DO jj = 1, jpj + IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisdt(ib) ) ztestmask(1) = tmask(ji,jj,1) + IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisft(ib) ) ztestmask(2) = tmask(ji,jj,1) + END DO + END DO + CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain + + IF ((ztestmask(1)==1).AND.(icorns(ib,1)==0)) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) + CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) + ENDIF + IF ((ztestmask(2)==1).AND.(icorns(ib,2)==0)) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) + CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) + ENDIF + END DO + ! + ! North segments + DO ib = 1, nbdysegn + ! get mask at boundary extremities: + ztestmask(1:2)=0. + DO ji = 1, jpi + DO jj = 1, jpj + IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpindt(ib) ) ztestmask(1) = tmask(ji,jj,1) + IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpinft(ib) ) ztestmask(2) = tmask(ji,jj,1) + END DO + END DO + CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain + + IF ((ztestmask(1)==1).AND.(icornn(ib,1)==0)) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) + CALL ctl_stop( ctmp1, ' does not start on land' ) + ENDIF + IF ((ztestmask(2)==1).AND.(icornn(ib,2)==0)) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) + CALL ctl_stop( ctmp1, ' does not end on land' ) + ENDIF + END DO + ! + IF ((itest==0).AND.(lwp)) WRITE(numout,*) 'NO open boundary corner found' + ! + ! Other tests TBD: + ! segments completly on land + ! optimized open boundary array length according to landmask + ! Nudging layers that overlap with interior domain + ! + END SUBROUTINE bdy_ctl_seg + + + SUBROUTINE bdy_coords_seg( nbidta, nbjdta, nbrdta ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_coords_seg *** + !! + !! ** Purpose : build nbidta, nbidta, nbrdta for bdy built with segments + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:,:), intent( out) :: nbidta, nbjdta, nbrdta ! Index arrays: i and j indices of bdy dta + !! + INTEGER :: ii, ij, ir, iseg + INTEGER :: igrd ! grid type (t=1, u=2, v=3) + INTEGER :: icount ! + INTEGER :: ib_bdy ! bdy number + !!---------------------------------------------------------------------- + + ! East + !----- + DO iseg = 1, nbdysege + ib_bdy = npckge(iseg) + ! + ! ------------ T points ------------- + igrd=1 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ij = jpjedt(iseg), jpjeft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ U points ------------- + igrd=2 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ij = jpjedt(iseg), jpjeft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ V points ------------- + igrd=3 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + ! DO ij = jpjedt(iseg), jpjeft(iseg) - 1 + DO ij = jpjedt(iseg), jpjeft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + ENDDO + ENDDO + ! + ! West + !----- + DO iseg = 1, nbdysegw + ib_bdy = npckgw(iseg) + ! + ! ------------ T points ------------- + igrd=1 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ij = jpjwdt(iseg), jpjwft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ U points ------------- + igrd=2 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ij = jpjwdt(iseg), jpjwft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ V points ------------- + igrd=3 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + ! DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 + DO ij = jpjwdt(iseg), jpjwft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + ENDDO + ENDDO + ! + ! North + !----- + DO iseg = 1, nbdysegn + ib_bdy = npckgn(iseg) + ! + ! ------------ T points ------------- + igrd=1 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ii = jpindt(iseg), jpinft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ U points ------------- + igrd=2 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + ! DO ii = jpindt(iseg), jpinft(iseg) - 1 + DO ii = jpindt(iseg), jpinft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + ENDDO + ! + ! ------------ V points ------------- + igrd=3 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ii = jpindt(iseg), jpinft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ENDDO + ! + ! South + !----- + DO iseg = 1, nbdysegs + ib_bdy = npckgs(iseg) + ! + ! ------------ T points ------------- + igrd=1 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ii = jpisdt(iseg), jpisft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ U points ------------- + igrd=2 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + ! DO ii = jpisdt(iseg), jpisft(iseg) - 1 + DO ii = jpisdt(iseg), jpisft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + ENDDO + ! + ! ------------ V points ------------- + igrd=3 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ii = jpisdt(iseg), jpisft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ENDDO + + + END SUBROUTINE bdy_coords_seg + + + SUBROUTINE bdy_ctl_corn( ib1, ib2 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_ctl_corn *** + !! + !! ** Purpose : Check numerical schemes consistency between + !! segments having a common corner + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: ib1, ib2 + INTEGER :: itest + !!---------------------------------------------------------------------- + itest = 0 + + IF( cn_dyn2d(ib1) /= cn_dyn2d(ib2) ) itest = itest + 1 + IF( cn_dyn3d(ib1) /= cn_dyn3d(ib2) ) itest = itest + 1 + IF( cn_tra (ib1) /= cn_tra (ib2) ) itest = itest + 1 + ! + IF( nn_dyn2d_dta(ib1) /= nn_dyn2d_dta(ib2) ) itest = itest + 1 + IF( nn_dyn3d_dta(ib1) /= nn_dyn3d_dta(ib2) ) itest = itest + 1 + IF( nn_tra_dta (ib1) /= nn_tra_dta (ib2) ) itest = itest + 1 + ! + IF( nn_rimwidth(ib1) /= nn_rimwidth(ib2) ) itest = itest + 1 + ! + IF( itest>0 ) THEN + WRITE(ctmp1,*) ' Segments ', ib1, 'and ', ib2 + CALL ctl_stop( ctmp1, ' have different open bdy schemes' ) + ENDIF + ! + END SUBROUTINE bdy_ctl_corn + + + SUBROUTINE bdy_meshwri() + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_meshwri *** + !! + !! ** Purpose : write netcdf file with nbr, flagu, flagv, ntreat for T, U + !! and V points in 2D arrays for easier visualisation/control + !! + !! ** Method : use iom_rstput as in domwri.F + !!---------------------------------------------------------------------- + INTEGER :: ib_bdy, ii, ij, igrd, ib ! dummy loop indices + INTEGER :: inum ! - - + REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields + REAL(wp) , DIMENSION(jpi,jpj) :: ztmp + CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid + !!---------------------------------------------------------------------- + cgrid = (/'t','u','v'/) + CALL iom_open( 'bdy_mesh', inum, ldwrt = .TRUE. ) + DO igrd = 1, jpbgrd + SELECT CASE( igrd ) + CASE( 1 ) ; zmask => tmask(:,:,1) + CASE( 2 ) ; zmask => umask(:,:,1) + CASE( 3 ) ; zmask => vmask(:,:,1) + END SELECT + ztmp(:,:) = zmask(:,:) + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) ! nbr deined for all rims + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%nbr(ib,igrd), wp) + 10. + IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) + END DO + END DO + CALL iom_rstput( 0, 0, inum, 'bdy_nbr_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) + ztmp(:,:) = zmask(:,:) + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagu defined only for rims 0 and 1 + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagu(ib,igrd), wp) + 10. + IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) + END DO + END DO + CALL iom_rstput( 0, 0, inum, 'flagu_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) + ztmp(:,:) = zmask(:,:) + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagv defined only for rims 0 and 1 + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagv(ib,igrd), wp) + 10. + IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) + END DO + END DO + CALL iom_rstput( 0, 0, inum, 'flagv_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) + ztmp(:,:) = zmask(:,:) + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! ntreat defined only for rims 0 and 1 + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%ntreat(ib,igrd), wp) + 10. + IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) + END DO + END DO + CALL iom_rstput( 0, 0, inum, 'ntreat_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) + END DO + CALL iom_close( inum ) + + END SUBROUTINE bdy_meshwri + + !!================================================================================= +END MODULE bdyini diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdylib.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdylib.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a2f31cb76c148203bdc011cb00ba38fc3b47f76d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdylib.f90 @@ -0,0 +1,531 @@ + + + + + + + + + + + + + +MODULE bdylib + !!====================================================================== + !! *** MODULE bdylib *** + !! Unstructured Open Boundary Cond. : Library module of generic boundary algorithms. + !!====================================================================== + !! History : 3.6 ! 2013 (D. Storkey) original code + !! 4.0 ! 2014 (T. Lovato) Generalize OBC structure + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! bdy_orlanski_2d + !! bdy_orlanski_3d + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE bdy_oce ! ocean open boundary conditions + USE phycst ! physical constants + USE bdyini + ! + USE in_out_manager ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp, ONLY: ctl_stop + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_frs, bdy_spe, bdy_nmn, bdy_orl + PUBLIC bdy_orlanski_2d + PUBLIC bdy_orlanski_3d + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdylib.F90 13527 2020-09-25 16:00:14Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_frs( idx, phia, dta ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_frs *** + !! + !! ** Purpose : Apply the Flow Relaxation Scheme for tracers at open boundaries. + !! + !! Reference : Engedahl H., 1995, Tellus, 365-382. + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend + !! + REAL(wp) :: zwgt ! boundary weight + INTEGER :: ib, ik, igrd ! dummy loop indices + INTEGER :: ii, ij ! 2D addresses + !!---------------------------------------------------------------------- + ! + igrd = 1 ! Everything is at T-points here + DO ib = 1, idx%nblen(igrd) + DO ik = 1, jpkm1 + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + zwgt = idx%nbw(ib,igrd) + phia(ii,ij,ik) = ( phia(ii,ij,ik) + zwgt * (dta(ib,ik) - phia(ii,ij,ik) ) ) * tmask(ii,ij,ik) + END DO + END DO + ! + END SUBROUTINE bdy_frs + + + SUBROUTINE bdy_spe( idx, phia, dta ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_spe *** + !! + !! ** Purpose : Apply a specified value for tracers at open boundaries. + !! + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend + !! + INTEGER :: ib, ik, igrd ! dummy loop indices + INTEGER :: ii, ij ! 2D addresses + !!---------------------------------------------------------------------- + ! + igrd = 1 ! Everything is at T-points here + DO ib = 1, idx%nblenrim(igrd) + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + DO ik = 1, jpkm1 + phia(ii,ij,ik) = dta(ib,ik) * tmask(ii,ij,ik) + END DO + END DO + ! + END SUBROUTINE bdy_spe + + + SUBROUTINE bdy_orl( idx, phib, phia, dta, lrim0, ll_npo ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_orl *** + !! + !! ** Purpose : Apply Orlanski radiation for tracers at open boundaries. + !! This is a wrapper routine for bdy_orlanski_3d below + !! + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices + REAL(wp), DIMENSION(:,:), POINTER, INTENT(in ) :: dta ! OBC external data + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phib ! before tracer field + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend + LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated + LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version + !! + INTEGER :: igrd ! grid index + !!---------------------------------------------------------------------- + ! + igrd = 1 ! Everything is at T-points here + ! + CALL bdy_orlanski_3d( idx, igrd, phib(:,:,:), phia(:,:,:), dta, lrim0, ll_npo ) + ! + END SUBROUTINE bdy_orl + + + SUBROUTINE bdy_orlanski_2d( idx, igrd, phib, phia, phi_ext, lrim0, ll_npo ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_orlanski_2d *** + !! + !! - Apply Orlanski radiation condition adaptively to 2D fields: + !! - radiation plus weak nudging at outflow points + !! - no radiation and strong nudging at inflow points + !! + !! + !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices + INTEGER , INTENT(in ) :: igrd ! grid index + REAL(wp), DIMENSION(:,:), INTENT(in ) :: phib ! model before 2D field + REAL(wp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated) + REAL(wp), DIMENSION(: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data + LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated + LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version + ! + INTEGER :: jb ! dummy loop indices + INTEGER :: ii, ij, iibm1, iibm2, ijbm1, ijbm2 ! 2D addresses + INTEGER :: iijm1, iijp1, ijjm1, ijjp1 ! 2D addresses + INTEGER :: iibm1jp1, iibm1jm1, ijbm1jp1, ijbm1jm1 ! 2D addresses + INTEGER :: ii_offset, ij_offset ! offsets for mask indices + INTEGER :: flagu, flagv ! short cuts + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) + REAL(wp) :: zmask_x, zmask_y1, zmask_y2 + REAL(wp) :: zex1, zex2, zey, zey1, zey2 + REAL(wp) :: zdt, zdx, zdy, znor2, zrx, zry ! intermediate calculations + REAL(dp) :: zout, zwgt, zdy_centred + REAL(wp) :: zdy_1, zdy_2, zsign_ups + REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value + REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! land/sea mask for field + REAL(wp), POINTER, DIMENSION(:,:) :: zmask_xdif ! land/sea mask for x-derivatives + REAL(wp), POINTER, DIMENSION(:,:) :: zmask_ydif ! land/sea mask for y-derivatives + REAL(dp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives + REAL(dp), POINTER, DIMENSION(:,:) :: pe_ydif ! scale factors for y-derivatives + !!---------------------------------------------------------------------- + ! + ! ----------------------------------! + ! Orlanski boundary conditions :! + ! ----------------------------------! + + SELECT CASE(igrd) + CASE(1) + zmask => tmask(:,:,1) + zmask_xdif => umask(:,:,1) + zmask_ydif => vmask(:,:,1) + pe_xdif => e1u(:,:) + pe_ydif => e2v(:,:) + ii_offset = 0 + ij_offset = 0 + CASE(2) + zmask => umask(:,:,1) + zmask_xdif => tmask(:,:,1) + zmask_ydif => fmask(:,:,1) + pe_xdif => e1t(:,:) + pe_ydif => e2f(:,:) + ii_offset = 1 + ij_offset = 0 + CASE(3) + zmask => vmask(:,:,1) + zmask_xdif => fmask(:,:,1) + zmask_ydif => tmask(:,:,1) + pe_xdif => e1f(:,:) + pe_ydif => e2t(:,:) + ii_offset = 0 + ij_offset = 1 + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' ) + END SELECT + ! + IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 + ENDIF + ! + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE + flagu = int( idx%flagu(jb,igrd) ) + flagv = int( idx%flagv(jb,igrd) ) + ! + ! Calculate positions of b-1 and b-2 points for this rim point + ! also (b-1,j-1) and (b-1,j+1) points + iibm1 = ii + flagu ; iibm2 = ii + 2*flagu + ijbm1 = ij + flagv ; ijbm2 = ij + 2*flagv + ! + iijm1 = ii - abs(flagv) ; iijp1 = ii + abs(flagv) + ijjm1 = ij - abs(flagu) ; ijjp1 = ij + abs(flagu) + ! + iibm1jm1 = ii + flagu - abs(flagv) ; iibm1jp1 = ii + flagu + abs(flagv) + ijbm1jm1 = ij + flagv - abs(flagu) ; ijbm1jp1 = ij + flagv + abs(flagu) + ! + ! Calculate scale factors for calculation of spatial derivatives. + zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & + & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1 +ij_offset) ) + zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 ) & + & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2 +ij_offset) ) + zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & + & + (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) + zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & + & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1 +ij_offset) ) + ! make sure scale factors are nonzero + if( zey1 .lt. rsmall ) zey1 = zey2 + if( zey2 .lt. rsmall ) zey2 = zey1 + zex1 = max(zex1,rsmall); zex2 = max(zex2,rsmall) + zey1 = max(zey1,rsmall); zey2 = max(zey2,rsmall); + ! + ! Calculate masks for calculation of spatial derivatives. + zmask_x = ( abs(iibm1-iibm2) * zmask_xdif(iibm2 +ii_offset,ijbm2 ) & + & + abs(ijbm1-ijbm2) * zmask_ydif(iibm2 ,ijbm2 +ij_offset) ) + zmask_y1 = ( (iibm1-iibm1jm1) * zmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & + & + (ijbm1-ijbm1jm1) * zmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) + zmask_y2 = ( (iibm1jp1-iibm1) * zmask_xdif(iibm1 +ii_offset,ijbm1 ) & + & + (ijbm1jp1-ijbm1) * zmask_ydif(iibm1 ,ijbm1 +ij_offset) ) + + ! Calculation of terms required for both versions of the scheme. + ! Mask derivatives to ensure correct land boundary conditions for each variable. + ! Centred derivative is calculated as average of "left" and "right" derivatives for + ! this reason. + ! Note no rn_Dt factor in expression for zdt because it cancels in the expressions for + ! zrx and zry. + zdt = phia(iibm1 ,ijbm1 ) - phib(iibm1 ,ijbm1 ) + zdx = ( ( phia(iibm1 ,ijbm1 ) - phia(iibm2 ,ijbm2 ) ) / zex2 ) * zmask_x + zdy_1 = ( ( phib(iibm1 ,ijbm1 ) - phib(iibm1jm1,ijbm1jm1) ) / zey1 ) * zmask_y1 + zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1) - phib(iibm1 ,ijbm1 ) ) / zey2 ) * zmask_y2 + zdy_centred = 0.5 * ( zdy_1 + zdy_2 ) +!!$ zdy_centred = phib(iibm1jp1,ijbm1jp1) - phib(iibm1jm1,ijbm1jm1) + ! upstream differencing for tangential derivatives + zsign_ups = sign( 1.0_wp, zdt * zdy_centred ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2 + znor2 = zdx * zdx + zdy * zdy + znor2 = max(znor2,zepsilon) + ! + zrx = zdt * zdx / ( zex1 * znor2 ) +!!$ zrx = min(zrx,2.0_wp) + zout = sign( 1.0_wp, zrx ) + zout = 0.5*( zout + abs(zout) ) + zwgt = 2.*rn_Dt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) ) + ! only apply radiation on outflow points + if( ll_npo ) then !! NPO version !! + phia(ii,ij) = (1.-zout) * ( phib(ii,ij) + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) & + & + zout * ( phib(ii,ij) + zrx*phia(iibm1,ijbm1) & + & + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) + else !! full oblique radiation !! + zsign_ups = sign( 1.0_wp, zdt * zdy ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 + zry = zdt * zdy / ( zey * znor2 ) + phia(ii,ij) = (1.-zout) * ( phib(ii,ij) + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) & + & + zout * ( phib(ii,ij) + zrx*phia(iibm1,ijbm1) & + & - zsign_ups * zry * ( phib(ii ,ij ) - phib(iijm1,ijjm1 ) ) & + & - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1) - phib(ii ,ij ) ) & + & + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) + endif + phia(ii,ij) = phia(ii,ij) * zmask(ii,ij) + END DO + ! + END SUBROUTINE bdy_orlanski_2d + + + SUBROUTINE bdy_orlanski_3d( idx, igrd, phib, phia, phi_ext, lrim0, ll_npo ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_orlanski_3d *** + !! + !! - Apply Orlanski radiation condition adaptively to 3D fields: + !! - radiation plus weak nudging at outflow points + !! - no radiation and strong nudging at inflow points + !! + !! + !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices + INTEGER , INTENT(in ) :: igrd ! grid index + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: phib ! model before 3D field + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated) + REAL(wp), DIMENSION(:,: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data + LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated + LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version + ! + INTEGER :: jb, jk ! dummy loop indices + INTEGER :: ii, ij, iibm1, iibm2, ijbm1, ijbm2 ! 2D addresses + INTEGER :: iijm1, iijp1, ijjm1, ijjp1 ! 2D addresses + INTEGER :: iibm1jp1, iibm1jm1, ijbm1jp1, ijbm1jm1 ! 2D addresses + INTEGER :: ii_offset, ij_offset ! offsets for mask indices + INTEGER :: flagu, flagv ! short cuts + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) + REAL(wp) :: zmask_x, zmask_y1, zmask_y2 + REAL(wp) :: zex1, zex2, zey, zey1, zey2 + REAL(wp) :: zdt, zdx, zdy, znor2, zrx, zry ! intermediate calculations + REAL(dp) :: zout, zwgt, zdy_centred + REAL(wp) :: zdy_1, zdy_2, zsign_ups + REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value + REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask ! land/sea mask for field + REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask_xdif ! land/sea mask for x-derivatives + REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask_ydif ! land/sea mask for y-derivatives + REAL(dp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives + REAL(dp), POINTER, DIMENSION(:,:) :: pe_ydif ! scale factors for y-derivatives + !!---------------------------------------------------------------------- + ! + ! ----------------------------------! + ! Orlanski boundary conditions :! + ! ----------------------------------! + ! + SELECT CASE(igrd) + CASE(1) + zmask => tmask(:,:,:) + zmask_xdif => umask(:,:,:) + zmask_ydif => vmask(:,:,:) + pe_xdif => e1u(:,:) + pe_ydif => e2v(:,:) + ii_offset = 0 + ij_offset = 0 + CASE(2) + zmask => umask(:,:,:) + zmask_xdif => tmask(:,:,:) + zmask_ydif => fmask(:,:,:) + pe_xdif => e1t(:,:) + pe_ydif => e2f(:,:) + ii_offset = 1 + ij_offset = 0 + CASE(3) + zmask => vmask(:,:,:) + zmask_xdif => fmask(:,:,:) + zmask_ydif => tmask(:,:,:) + pe_xdif => e1f(:,:) + pe_ydif => e2t(:,:) + ii_offset = 0 + ij_offset = 1 + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' ) + END SELECT + ! + IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 + ENDIF + ! + DO jk = 1, jpk + ! + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE + flagu = int( idx%flagu(jb,igrd) ) + flagv = int( idx%flagv(jb,igrd) ) + ! + ! calculate positions of b-1 and b-2 points for this rim point + ! also (b-1,j-1) and (b-1,j+1) points + iibm1 = ii + flagu ; iibm2 = ii + 2*flagu + ijbm1 = ij + flagv ; ijbm2 = ij + 2*flagv + ! + iijm1 = ii - abs(flagv) ; iijp1 = ii + abs(flagv) + ijjm1 = ij - abs(flagu) ; ijjp1 = ij + abs(flagu) + ! + iibm1jm1 = ii + flagu - abs(flagv) ; iibm1jp1 = ii + flagu + abs(flagv) + ijbm1jm1 = ij + flagv - abs(flagu) ; ijbm1jp1 = ij + flagv + abs(flagu) + ! + ! Calculate scale factors for calculation of spatial derivatives. + zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & + & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1+ij_offset ) ) + zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 ) & + & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2+ij_offset ) ) + zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & + & + (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) + zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & + & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1+ij_offset ) ) + ! make sure scale factors are nonzero + if( zey1 .lt. rsmall ) zey1 = zey2 + if( zey2 .lt. rsmall ) zey2 = zey1 + zex1 = max(zex1,rsmall); zex2 = max(zex2,rsmall); + zey1 = max(zey1,rsmall); zey2 = max(zey2,rsmall); + ! + ! Calculate masks for calculation of spatial derivatives. + zmask_x = ( abs(iibm1-iibm2) * zmask_xdif(iibm2 +ii_offset,ijbm2 ,jk) & + & + abs(ijbm1-ijbm2) * zmask_ydif(iibm2 ,ijbm2 +ij_offset,jk) ) + zmask_y1 = ( (iibm1-iibm1jm1) * zmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 ,jk) & + & + (ijbm1-ijbm1jm1) * zmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset,jk) ) + zmask_y2 = ( (iibm1jp1-iibm1) * zmask_xdif(iibm1 +ii_offset,ijbm1 ,jk) & + & + (ijbm1jp1-ijbm1) * zmask_ydif(iibm1 ,ijbm1 +ij_offset,jk) ) + ! + ! Calculate normal (zrx) and tangential (zry) components of radiation velocities. + ! Mask derivatives to ensure correct land boundary conditions for each variable. + ! Centred derivative is calculated as average of "left" and "right" derivatives for + ! this reason. + zdt = phia(iibm1 ,ijbm1 ,jk) - phib(iibm1 ,ijbm1 ,jk) + zdx = ( ( phia(iibm1 ,ijbm1 ,jk) - phia(iibm2 ,ijbm2 ,jk) ) / zex2 ) * zmask_x + zdy_1 = ( ( phib(iibm1 ,ijbm1 ,jk) - phib(iibm1jm1,ijbm1jm1,jk) ) / zey1 ) * zmask_y1 + zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1 ,ijbm1 ,jk) ) / zey2 ) * zmask_y2 + zdy_centred = 0.5 * ( zdy_1 + zdy_2 ) +!!$ zdy_centred = phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1jm1,ijbm1jm1,jk) + ! upstream differencing for tangential derivatives + zsign_ups = sign( 1.0_wp, zdt * zdy_centred ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2 + znor2 = zdx * zdx + zdy * zdy + znor2 = max(znor2,zepsilon) + ! + ! update boundary value: + zrx = zdt * zdx / ( zex1 * znor2 ) +!!$ zrx = min(zrx,2.0_wp) + zout = sign( 1.0_wp, zrx ) + zout = 0.5*( zout + abs(zout) ) + zwgt = 2.*rn_Dt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) ) + ! only apply radiation on outflow points + if( ll_npo ) then !! NPO version !! + phia(ii,ij,jk) = (1.-zout) * ( phib(ii,ij,jk) + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) & + & + zout * ( phib(ii,ij,jk) + zrx*phia(iibm1,ijbm1,jk) & + & + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) + else !! full oblique radiation !! + zsign_ups = sign( 1.0_wp, zdt * zdy ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 + zry = zdt * zdy / ( zey * znor2 ) + phia(ii,ij,jk) = (1.-zout) * ( phib(ii,ij,jk) + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) & + & + zout * ( phib(ii,ij,jk) + zrx*phia(iibm1,ijbm1,jk) & + & - zsign_ups * zry * ( phib(ii ,ij ,jk) - phib(iijm1,ijjm1,jk) ) & + & - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1,jk) - phib(ii ,ij ,jk) ) & + & + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) + endif + phia(ii,ij,jk) = phia(ii,ij,jk) * zmask(ii,ij,jk) + END DO + ! + END DO + ! + END SUBROUTINE bdy_orlanski_3d + + SUBROUTINE bdy_nmn( idx, igrd, phia, lrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_nmn *** + !! + !! ** Purpose : Duplicate the value at open boundaries, zero gradient. + !! + !! + !! ** Method : - take the average of free ocean neighbours + !! + !! ___ ! |_____| ! ___| ! __|x o ! |_ _| ! | + !! __|x ! x ! x o ! o ! |_| ! |x o + !! o ! o ! o ! ! o x o ! |x_x_ + !! ! o + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: igrd ! grid index + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated), must be masked + TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices + LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated + !! + REAL(wp) :: zweight + REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask ! land/sea mask for field + INTEGER :: ib, ik ! dummy loop indices + INTEGER :: ii, ij ! 2D addresses + INTEGER :: ipkm1 ! size of phia third dimension minus 1 + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) + INTEGER :: ii1, ii2, ii3, ij1, ij2, ij3, itreat + !!---------------------------------------------------------------------- + ! + ipkm1 = MAX( SIZE(phia,3) - 1, 1 ) + ! + SELECT CASE(igrd) + CASE(1) ; zmask => tmask(:,:,:) + CASE(2) ; zmask => umask(:,:,:) + CASE(3) ; zmask => vmask(:,:,:) + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_nmn' ) + END SELECT + ! + IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 + ENDIF + ! + DO ib = ibeg, iend + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + itreat = idx%ntreat(ib,igrd) + CALL find_neib( ii, ij, itreat, ii1, ij1, ii2, ij2, ii3, ij3 ) ! find free ocean neighbours + SELECT CASE( itreat ) + CASE( 1:8 ) + IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE + DO ik = 1, ipkm1 + IF( zmask(ii1,ij1,ik) /= 0. ) phia(ii,ij,ik) = phia(ii1,ij1,ik) + END DO + CASE( 9:12 ) + IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE + IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj ) CYCLE + DO ik = 1, ipkm1 + zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) + IF( zweight /= 0. ) phia(ii,ij,ik) = ( phia(ii1,ij1,ik) + phia(ii2,ij2,ik) ) / zweight + END DO + CASE( 13:16 ) + IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE + IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj ) CYCLE + IF( ii3 < 1 .OR. ii3 > jpi .OR. ij3 < 1 .OR. ij3 > jpj ) CYCLE + DO ik = 1, ipkm1 + zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) + zmask(ii3,ij3,ik) + IF( zweight /= 0. ) phia(ii,ij,ik) = ( phia(ii1,ij1,ik) + phia(ii2,ij2,ik) + phia(ii3,ij3,ik) ) / zweight + END DO + END SELECT + END DO + ! + END SUBROUTINE bdy_nmn + + !!====================================================================== +END MODULE bdylib diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdytides.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdytides.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9fcc5c8d6252bac20ac9e2c2dac3637c2c006087 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdytides.f90 @@ -0,0 +1,492 @@ + + + + + + + + + + + + + +MODULE bdytides + !!====================================================================== + !! *** MODULE bdytides *** + !! Ocean dynamics: Tidal forcing at open boundaries + !!====================================================================== + !! History : 2.0 ! 2007-01 (D.Storkey) Original code + !! 2.3 ! 2008-01 (J.Holt) Add date correction. Origins POLCOMS v6.3 2007 + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.3 ! 2010-09 (D.Storkey and E.O'Dea) bug fixes + !! 3.4 ! 2012-09 (G. Reffray and J. Chanut) New inputs + mods + !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes + !!---------------------------------------------------------------------- + !! bdytide_init : read of namelist and initialisation of tidal harmonics data + !! tide_update : calculation of tidal forcing at each timestep + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE bdy_oce ! ocean open boundary conditions + USE tide_mod ! + USE daymod ! calendar + ! + USE in_out_manager ! I/O units + USE iom ! xIO server + USE fldread ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC bdytide_init ! routine called in bdy_init + PUBLIC bdy_dta_tides ! routine called in dyn_spg_ts + + TYPE, PUBLIC :: TIDES_DATA !: Storage for external tidal harmonics data + REAL(wp), POINTER, DIMENSION(:,:,:) :: ssh0 !: Tidal constituents : SSH0 (read in file) + REAL(wp), POINTER, DIMENSION(:,:,:) :: u0, v0 !: Tidal constituents : U0, V0 (read in file) + REAL(wp), POINTER, DIMENSION(:,:,:) :: ssh !: Tidal constituents : SSH (after nodal cor.) + REAL(wp), POINTER, DIMENSION(:,:,:) :: u , v !: Tidal constituents : U , V (after nodal cor.) + END TYPE TIDES_DATA + +!$AGRIF_DO_NOT_TREAT + TYPE(TIDES_DATA), PUBLIC, DIMENSION(jp_bdy), TARGET :: tides !: External tidal harmonics data +!$AGRIF_END_DO_NOT_TREAT + TYPE(OBC_DATA) , PUBLIC, DIMENSION(jp_bdy) :: dta_bdy_s !: bdy external data (slow component) + + INTEGER :: kt_tide + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdytides.F90 14169 2020-12-14 18:32:36Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdytide_init + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdytide_init *** + !! + !! ** Purpose : - Read in namelist for tides and initialise external + !! tidal harmonics data + !! + !!---------------------------------------------------------------------- + !! namelist variables + !!------------------- + CHARACTER(len=80) :: filtide ! Filename root for tidal input files + LOGICAL :: ln_bdytide_2ddta ! If true, read 2d harmonic data + !! + INTEGER :: ib_bdy, itide, ib ! dummy loop indices + INTEGER :: ii, ij ! dummy loop indices + INTEGER :: inum, igrd + INTEGER :: isz ! bdy data size + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: nbdy_rdstart, nbdy_loc + CHARACTER(LEN=50) :: cerrmsg ! error string + CHARACTER(len=80) :: clfile ! full file name for tidal input file + REAL(wp),ALLOCATABLE, DIMENSION(:,:,:) :: dta_read ! work space to read in tidal harmonics data + REAL(wp),ALLOCATABLE, DIMENSION(:,:) :: ztr, zti ! " " " " " " " " + !! + TYPE(TIDES_DATA), POINTER :: td ! local short cut + TYPE( OBC_DATA), POINTER :: dta ! local short cut + !! + NAMELIST/nambdy_tide/filtide, ln_bdytide_2ddta + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'bdytide_init : initialization of tidal harmonic forcing at open boundaries' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + + + nbdy_rdstart = 1 + DO ib_bdy = 1, nb_bdy + IF( nn_dyn2d_dta(ib_bdy) >= 2 ) THEN + ! + td => tides(ib_bdy) + dta => dta_bdy(ib_bdy) + + ! Namelist nambdy_tide : tidal harmonic forcing at open boundaries + filtide(:) = '' + + READ ( numnam_ref, nambdy_tide, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_tide in reference namelist' ) + ! + ! Need to support possibility of reading more than one + ! nambdy_tide from the namelist_cfg internal file. + ! Do this by finding the ib_bdy'th occurence of nambdy_tide in the + ! character buffer as the starting point. + ! + nbdy_loc = INDEX( numnam_cfg( nbdy_rdstart: ), 'nambdy_tide' ) + IF( nbdy_loc .GT. 0 ) THEN + nbdy_rdstart = nbdy_rdstart + nbdy_loc + ELSE + WRITE(cerrmsg,'(A,I4,A)') 'Error: entry number ',ib_bdy,' of nambdy_tide not found' + ios = -1 + CALL ctl_nam ( ios , cerrmsg ) + ENDIF + READ ( numnam_cfg( MAX( 1, nbdy_rdstart - 2 ): ), nambdy_tide, IOSTAT = ios, ERR = 902) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_tide in configuration namelist' ) + IF(lwm) WRITE ( numond, nambdy_tide ) + ! ! Parameter control and print + IF(lwp) WRITE(numout,*) ' ' + IF(lwp) WRITE(numout,*) ' Namelist nambdy_tide : tidal harmonic forcing at open boundaries' + IF(lwp) WRITE(numout,*) ' read tidal data in 2d files: ', ln_bdytide_2ddta + IF(lwp) WRITE(numout,*) ' Number of tidal components to read: ', nb_harmo + IF(lwp) THEN + WRITE(numout,*) ' Tidal components: ' + DO itide = 1, nb_harmo + WRITE(numout,*) ' ', tide_harmonics(itide)%cname_tide + END DO + ENDIF + IF(lwp) WRITE(numout,*) ' ' + + ! Allocate space for tidal harmonics data - get size from BDY data arrays + ! Allocate also slow varying data in the case of time splitting: + ! Do it anyway because at this stage knowledge of free surface scheme is unknown + ! ----------------------------------------------------------------------- + IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain + isz = SIZE(dta%ssh) + ALLOCATE( td%ssh0( isz, nb_harmo, 2 ), td%ssh( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%ssh( isz ) ) + dta_bdy_s(ib_bdy)%ssh(:) = 0._wp ! needed? + ENDIF + IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain + isz = SIZE(dta%u2d) + ALLOCATE( td%u0 ( isz, nb_harmo, 2 ), td%u ( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%u2d( isz ) ) + dta_bdy_s(ib_bdy)%u2d(:) = 0._wp ! needed? + ENDIF + IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain + isz = SIZE(dta%v2d) + ALLOCATE( td%v0 ( isz, nb_harmo, 2 ), td%v ( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%v2d( isz ) ) + dta_bdy_s(ib_bdy)%v2d(:) = 0._wp ! needed? + ENDIF + + ! fill td%ssh0, td%u0, td%v0 + ! ----------------------------------------------------------------------- + IF( ln_bdytide_2ddta ) THEN + ! + ! It is assumed that each data file contains all complex harmonic amplitudes + ! given on the global domain (ie global, jpiglo x jpjglo) + ! + ALLOCATE( zti(jpi,jpj), ztr(jpi,jpj) ) + ! + ! SSH fields + clfile = TRIM(filtide)//'_grid_T.nc' + CALL iom_open( clfile , inum ) + igrd = 1 ! Everything is at T-points here + DO itide = 1, nb_harmo + CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z1', ztr(:,:) ) + CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z2', zti(:,:) ) + IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain + DO ib = 1, SIZE(dta%ssh) + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + td%ssh0(ib,itide,1) = ztr(ii,ij) + td%ssh0(ib,itide,2) = zti(ii,ij) + END DO + ENDIF + END DO + CALL iom_close( inum ) + ! + ! U fields + clfile = TRIM(filtide)//'_grid_U.nc' + CALL iom_open( clfile , inum ) + igrd = 2 ! Everything is at U-points here + DO itide = 1, nb_harmo + CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u1', ztr(:,:),cd_type='U',psgn=-1._dp) + CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u2', zti(:,:),cd_type='U',psgn=-1._dp) + IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain + DO ib = 1, SIZE(dta%u2d) + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + td%u0(ib,itide,1) = ztr(ii,ij) + td%u0(ib,itide,2) = zti(ii,ij) + END DO + ENDIF + END DO + CALL iom_close( inum ) + ! + ! V fields + clfile = TRIM(filtide)//'_grid_V.nc' + CALL iom_open( clfile , inum ) + igrd = 3 ! Everything is at V-points here + DO itide = 1, nb_harmo + CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v1', ztr(:,:),cd_type='V',psgn=-1._dp) + CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v2', zti(:,:),cd_type='V',psgn=-1._dp) + IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain + DO ib = 1, SIZE(dta%v2d) + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + td%v0(ib,itide,1) = ztr(ii,ij) + td%v0(ib,itide,2) = zti(ii,ij) + END DO + ENDIF + END DO + CALL iom_close( inum ) + ! + DEALLOCATE( ztr, zti ) + ! + ELSE + ! + ! Read tidal data only on bdy segments + ! + ALLOCATE( dta_read( MAXVAL( idx_bdy(ib_bdy)%nblen(:) ), 1, 1 ) ) + ! + ! Open files and read in tidal forcing data + ! ----------------------------------------- + + DO itide = 1, nb_harmo + ! ! SSH fields + IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain + isz = SIZE(dta%ssh) + clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_T.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'z1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) + td%ssh0(:,itide,1) = dta_read(1:isz,1,1) + CALL fld_map( inum, 'z2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) + td%ssh0(:,itide,2) = dta_read(1:isz,1,1) + CALL iom_close( inum ) + ENDIF + ! ! U fields + IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain + isz = SIZE(dta%u2d) + clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_U.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'u1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) + td%u0(:,itide,1) = dta_read(1:isz,1,1) + CALL fld_map( inum, 'u2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) + td%u0(:,itide,2) = dta_read(1:isz,1,1) + CALL iom_close( inum ) + ENDIF + ! ! V fields + IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain + isz = SIZE(dta%v2d) + clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_V.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'v1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) + td%v0(:,itide,1) = dta_read(1:isz,1,1) + CALL fld_map( inum, 'v2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) + td%v0(:,itide,2) = dta_read(1:isz,1,1) + CALL iom_close( inum ) + ENDIF + ! + END DO ! end loop on tidal components + ! + DEALLOCATE( dta_read ) + ! + ENDIF ! ln_bdytide_2ddta=.true. + ! + ENDIF ! nn_dyn2d_dta(ib_bdy) >= 2 + ! + END DO ! loop on ib_bdy + ! + END SUBROUTINE bdytide_init + + + SUBROUTINE bdy_dta_tides( kt, kit, pt_offset ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dta_tides *** + !! + !! ** Purpose : - Add tidal forcing to ssh, u2d and v2d OBC data arrays. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! Main timestep counter + INTEGER, OPTIONAL, INTENT(in) :: kit ! Barotropic timestep counter (for timesplitting option) + REAL(wp),OPTIONAL, INTENT(in) :: pt_offset ! time offset in units of timesteps + ! + LOGICAL :: lk_first_btstp ! =.TRUE. if time splitting and first barotropic step + INTEGER :: itide, ib_bdy, ib ! loop indices + REAL(wp) :: z_arg, z_sarg, zramp, zoff, z_cost, z_sist, zt_offset + !!---------------------------------------------------------------------- + ! + lk_first_btstp=.TRUE. + IF ( PRESENT(kit).AND.( kit /= 1 ) ) THEN ; lk_first_btstp=.FALSE. ; ENDIF + + zt_offset = 0._wp + IF( PRESENT(pt_offset) ) zt_offset = pt_offset + + ! Absolute time from model initialization: + IF( PRESENT(kit) ) THEN + z_arg = ( REAL(kt, wp) + ( REAL(kit, wp) + zt_offset - 1. ) / REAL(nn_e, wp) ) * rn_Dt + ELSE + z_arg = ( REAL(kt, wp) + zt_offset ) * rn_Dt + ENDIF + + ! Linear ramp on tidal component at open boundaries + zramp = 1. + IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg - REAL(nit000,wp)*rn_Dt)/(rn_tide_ramp_dt*rday),0.),1.) + + DO ib_bdy = 1,nb_bdy + ! + IF( nn_dyn2d_dta(ib_bdy) >= 2 ) THEN + ! + ! We refresh nodal factors every day below + ! This should be done somewhere else + IF ( ( nsec_day == NINT(0.5_wp * rn_Dt) .OR. kt==nit000 ) .AND. lk_first_btstp ) THEN + ! + kt_tide = kt - NINT((REAL(nsec_day,wp) - 0.5_wp * rn_Dt)/rn_Dt) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'bdy_tide_dta : Refresh nodal factors for tidal open bdy data at kt=',kt + WRITE(numout,*) '~~~~~~~~~~~~~~ ' + ENDIF + ! + CALL tide_init_elevation ( idx=idx_bdy(ib_bdy), td=tides(ib_bdy) ) + CALL tide_init_velocities( idx=idx_bdy(ib_bdy), td=tides(ib_bdy) ) + ! + ENDIF + zoff = REAL(-kt_tide,wp) * rn_Dt ! time offset relative to nodal factor computation time + ! + ! If time splitting, initialize arrays from slow varying open boundary data: + IF ( PRESENT(kit) ) THEN + IF ( ASSOCIATED(dta_bdy(ib_bdy)%ssh) ) dta_bdy(ib_bdy)%ssh(:) = dta_bdy_s(ib_bdy)%ssh(:) + IF ( ASSOCIATED(dta_bdy(ib_bdy)%u2d) ) dta_bdy(ib_bdy)%u2d(:) = dta_bdy_s(ib_bdy)%u2d(:) + IF ( ASSOCIATED(dta_bdy(ib_bdy)%v2d) ) dta_bdy(ib_bdy)%v2d(:) = dta_bdy_s(ib_bdy)%v2d(:) + ENDIF + ! + ! Update open boundary data arrays: + DO itide = 1, nb_harmo + ! + z_sarg = (z_arg + zoff) * tide_harmonics(itide)%omega + z_cost = zramp * COS( z_sarg ) + z_sist = zramp * SIN( z_sarg ) + ! + IF ( ASSOCIATED(dta_bdy(ib_bdy)%ssh) ) THEN ! SSH on tracer grid + DO ib = 1, SIZE(dta_bdy(ib_bdy)%ssh) + dta_bdy(ib_bdy)%ssh(ib) = dta_bdy(ib_bdy)%ssh(ib) + & + & ( tides(ib_bdy)%ssh(ib,itide,1)*z_cost + & + & tides(ib_bdy)%ssh(ib,itide,2)*z_sist ) + END DO + ENDIF + ! + IF ( ASSOCIATED(dta_bdy(ib_bdy)%u2d) ) THEN ! U grid + DO ib = 1, SIZE(dta_bdy(ib_bdy)%u2d) + dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) + & + & ( tides(ib_bdy)%u(ib,itide,1)*z_cost + & + & tides(ib_bdy)%u(ib,itide,2)*z_sist ) + END DO + ENDIF + ! + IF ( ASSOCIATED(dta_bdy(ib_bdy)%v2d) ) THEN ! V grid + DO ib = 1, SIZE(dta_bdy(ib_bdy)%v2d) + dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) + & + & ( tides(ib_bdy)%v(ib,itide,1)*z_cost + & + & tides(ib_bdy)%v(ib,itide,2)*z_sist ) + END DO + ENDIF + ! + END DO + ENDIF + END DO + ! + END SUBROUTINE bdy_dta_tides + + + SUBROUTINE tide_init_elevation( idx, td ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_elevation *** + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX) , INTENT(in ) :: idx ! OBC indices + TYPE(TIDES_DATA), INTENT(inout) :: td ! tidal harmonics data + ! + INTEGER :: itide, isz, ib ! dummy loop indices + REAL(wp),ALLOCATABLE, DIMENSION(:) :: mod_tide, phi_tide + !!---------------------------------------------------------------------- + ! + IF( ASSOCIATED(td%ssh0) ) THEN ! SSH on tracer grid. + ! + isz = SIZE( td%ssh0, dim = 1 ) + ALLOCATE( mod_tide(isz), phi_tide(isz) ) + ! + DO itide = 1, nb_harmo + DO ib = 1, isz + mod_tide(ib)=SQRT( td%ssh0(ib,itide,1)*td%ssh0(ib,itide,1) + td%ssh0(ib,itide,2)*td%ssh0(ib,itide,2) ) + phi_tide(ib)=ATAN2(-td%ssh0(ib,itide,2),td%ssh0(ib,itide,1)) + END DO + DO ib = 1, isz + mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f + phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0+tide_harmonics(itide)%u + END DO + DO ib = 1, isz + td%ssh(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib)) + td%ssh(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib)) + END DO + END DO + ! + DEALLOCATE( mod_tide, phi_tide ) + ! + ENDIF + ! + END SUBROUTINE tide_init_elevation + + + SUBROUTINE tide_init_velocities( idx, td ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_elevation *** + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX) , INTENT(in ) :: idx ! OBC indices + TYPE(TIDES_DATA), INTENT(inout) :: td ! tidal harmonics data + ! + INTEGER :: itide, isz, ib ! dummy loop indices + REAL(wp),ALLOCATABLE, DIMENSION(:) :: mod_tide, phi_tide + !!---------------------------------------------------------------------- + ! + IF( ASSOCIATED(td%u0) ) THEN ! U grid. we use bdy u2d on this mpi subdomain + ! + isz = SIZE( td%u0, dim = 1 ) + ALLOCATE( mod_tide(isz), phi_tide(isz) ) + ! + DO itide = 1, nb_harmo + DO ib = 1, isz + mod_tide(ib)=SQRT( td%u0(ib,itide,1)*td%u0(ib,itide,1) + td%u0(ib,itide,2)*td%u0(ib,itide,2) ) + phi_tide(ib)=ATAN2(-td%u0(ib,itide,2),td%u0(ib,itide,1)) + END DO + DO ib = 1, isz + mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f + phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0 + tide_harmonics(itide)%u + END DO + DO ib = 1, isz + td%u(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib)) + td%u(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib)) + END DO + END DO + ! + DEALLOCATE( mod_tide, phi_tide ) + ! + ENDIF + ! + IF( ASSOCIATED(td%v0) ) THEN ! V grid. we use bdy u2d on this mpi subdomain + ! + isz = SIZE( td%v0, dim = 1 ) + ALLOCATE( mod_tide(isz), phi_tide(isz) ) + ! + DO itide = 1, nb_harmo + DO ib = 1, isz + mod_tide(ib)=SQRT( td%v0(ib,itide,1)*td%v0(ib,itide,1) + td%v0(ib,itide,2)*td%v0(ib,itide,2) ) + phi_tide(ib)=ATAN2(-td%v0(ib,itide,2),td%v0(ib,itide,1)) + END DO + DO ib = 1, isz + mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f + phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0 + tide_harmonics(itide)%u + END DO + DO ib = 1, isz + td%v(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib)) + td%v(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib)) + END DO + END DO + ! + DEALLOCATE( mod_tide, phi_tide ) + ! + ENDIF + ! + END SUBROUTINE tide_init_velocities + + !!====================================================================== +END MODULE bdytides diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdytra.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdytra.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a85a31f4211d523bbaf524bcb6ed5a583b8d8c10 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdytra.f90 @@ -0,0 +1,199 @@ + + + + + + + + + + + + + +MODULE bdytra + !!====================================================================== + !! *** MODULE bdytra *** + !! Ocean tracers: Apply boundary conditions for tracers + !!====================================================================== + !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) Optimization of BDY communications + !! 4.0 ! 2016 (T. Lovato) Generalize OBC structure + !!---------------------------------------------------------------------- + !! bdy_tra : Apply open boundary conditions & damping to T and S + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE bdy_oce ! ocean open boundary conditions + USE bdylib ! for orlanski library routines + ! + USE in_out_manager ! I/O manager + USE lib_mpp, ONLY: jpfillnothing + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp, ONLY: ctl_stop + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + ! Local structure to rearrange tracers data + TYPE, PUBLIC :: ztrabdy + REAL(wp), POINTER, DIMENSION(:,:) :: tra + END TYPE + + PUBLIC bdy_tra ! called in tranxt.F90 + PUBLIC bdy_tra_dmp ! called in step.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdytra.F90 15354 2021-10-12 13:44:46Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_tra( kt, Kbb, pts, Kaa ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_tra *** + !! + !! ** Purpose : - Apply open boundary conditions for temperature and salinity + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! Main time step counter + INTEGER , INTENT(in) :: Kbb, Kaa ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! tracer fields + ! + INTEGER :: ib_bdy, jn, igrd, ir ! Loop indeces + TYPE(ztrabdy), DIMENSION(jpts) :: zdta ! Temporary data structure + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(8) :: llsend1, llrecv1 ! indicate how communications are to be carried out + !!---------------------------------------------------------------------- + igrd = 1 + llsend1(:) = .false. ; llrecv1(:) = .false. + DO ir = 1, 0, -1 ! treat rim 1 before rim 0 + IF( ir == 0 ) THEN ; llrim0 = .TRUE. + ELSE ; llrim0 = .FALSE. + ENDIF + DO ib_bdy=1, nb_bdy + ! + zdta(1)%tra => dta_bdy(ib_bdy)%tem + zdta(2)%tra => dta_bdy(ib_bdy)%sal + ! + DO jn = 1, jpts + ! + SELECT CASE( cn_tra(ib_bdy) ) + CASE('none' ) ; CYCLE + CASE('frs' ) ! treat the whole boundary at once + IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra ) + CASE('specified' ) ! treat the whole rim at once + IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra ) + CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , pts(:,:,:,jn,Kaa), llrim0 ) ! tsa masked + CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, & + & llrim0, ll_npo=.FALSE. ) + CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, & + & llrim0, ll_npo=.TRUE. ) + CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), jn, llrim0 ) + CASE DEFAULT ; CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) + END SELECT + ! + END DO + END DO + ! + IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 + IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; ENDIF + DO ib_bdy=1, nb_bdy + SELECT CASE( cn_tra(ib_bdy) ) + CASE('neumann','runoff') + llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points + llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points + CASE('orlanski', 'orlanski_npo') + llsend1(:) = llsend1(:) .OR. lsend_bdyolr(ib_bdy,1,:,ir) ! possibly every direction, T points + llrecv1(:) = llrecv1(:) .OR. lrecv_bdyolr(ib_bdy,1,:,ir) ! possibly every direction, T points + END SELECT + END DO + IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T', 1.0_dp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + ENDIF + ! + END DO ! ir + ! + END SUBROUTINE bdy_tra + + + SUBROUTINE bdy_rnf( idx, pt, jpa, llrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_rnf *** + !! + !! ** Purpose : Specialized routine to apply TRA runoff values at OBs: + !! - duplicate the neighbour value for the temperature + !! - specified to 0.1 PSU for the salinity + !! + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt ! tracer trend + INTEGER, INTENT(in) :: jpa ! TRA index + LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated + ! + INTEGER :: ib, ii, ij, igrd ! dummy loop indices + !!---------------------------------------------------------------------- + ! + igrd = 1 ! Everything is at T-points here + IF( jpa == jp_tem ) THEN + CALL bdy_nmn( idx, igrd, pt, llrim0 ) + ELSE IF( jpa == jp_sal ) THEN + IF( .NOT. llrim0 ) RETURN + DO ib = 1, idx%nblenrim(igrd) ! if llrim0 then treat the whole rim + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + pt(ii,ij,1:jpkm1) = 0.1 * tmask(ii,ij,1:jpkm1) + END DO + ENDIF + ! + END SUBROUTINE bdy_rnf + + + SUBROUTINE bdy_tra_dmp( kt, Kbb, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_tra_dmp *** + !! + !! ** Purpose : Apply damping for tracers at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step + INTEGER , INTENT(in) :: Kbb, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + REAL(wp) :: zwgt ! boundary weight + REAL(wp) :: zta, zsa, ztime + INTEGER :: ib, ik, igrd ! dummy loop indices + INTEGER :: ii, ij ! 2D addresses + INTEGER :: ib_bdy ! Loop index + !!---------------------------------------------------------------------- + IF( l_istiled .AND. ntile /= 1 ) RETURN ! Do only for the full domain + ! + IF( ln_timing ) CALL timing_start('bdy_tra_dmp') + ! + DO ib_bdy = 1, nb_bdy + IF( ln_tra_dmp(ib_bdy) ) THEN + igrd = 1 ! Everything is at T-points here + DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + zwgt = idx_bdy(ib_bdy)%nbd(ib,igrd) + DO ik = 1, jpkm1 + zta = zwgt * ( dta_bdy(ib_bdy)%tem(ib,ik) - pts(ii,ij,ik,jp_tem,Kbb) ) * tmask(ii,ij,ik) + zsa = zwgt * ( dta_bdy(ib_bdy)%sal(ib,ik) - pts(ii,ij,ik,jp_sal,Kbb) ) * tmask(ii,ij,ik) + pts(ii,ij,ik,jp_tem,Krhs) = pts(ii,ij,ik,jp_tem,Krhs) + zta + pts(ii,ij,ik,jp_sal,Krhs) = pts(ii,ij,ik,jp_sal,Krhs) + zsa + END DO + END DO + ENDIF + END DO + ! + IF( ln_timing ) CALL timing_stop('bdy_tra_dmp') + ! + END SUBROUTINE bdy_tra_dmp + + !!====================================================================== +END MODULE bdytra diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdyvol.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdyvol.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d8845766b9a4b076f545a81a52caf001baf8d7d1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/bdyvol.f90 @@ -0,0 +1,242 @@ + + + + + + + + + + + + + +MODULE bdyvol + !!====================================================================== + !! *** MODULE bdyvol *** + !! Ocean dynamic : Volume constraint when unstructured boundary + !! and filtered free surface are used + !!====================================================================== + !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code + !! - ! 2006-01 (J. Chanut) Bug correction + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !! 4.0 ! 2019-01 (P. Mathiot) adapted to time splitting + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE bdy_oce ! ocean open boundary conditions + USE sbc_oce ! ocean surface boundary conditions + USE isf_oce, ONLY : fwfisf_cav, fwfisf_par ! ice shelf + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! for mppsum + USE lib_fortran ! Fortran routines library + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_vol2d ! called by dynspg_ts + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdyvol.F90 15004 2021-06-16 10:33:18Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_vol2d( kt, kc, pua2d, pva2d, phu, phv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdyvol *** + !! + !! ** Purpose : This routine controls the volume of the system. + !! A correction velocity is calculated to correct the total transport + !! through the unstructured OBC. + !! + !! ** Method : The correction velocity (zubtpecor here) is defined calculating + !! the total transport through all open boundaries (trans_bdy) minus + !! the cumulate E-P flux (z_cflxemp) divided by the total lateral + !! surface (bdysurftot) of the unstructured boundary. + !! zubtpecor = [trans_bdy - z_cflxemp ]*(1./bdysurftot) + !! with z_cflxemp => sum of (Evaporation minus Precipitation) + !! over all the domain in m3/s at each time step. + !! z_cflxemp < 0 when precipitation dominate + !! z_cflxemp > 0 when evaporation dominate + !! + !! There are 2 options (user's desiderata): + !! 1/ The volume changes according to E-P, this is the default + !! option. In this case the cumulate E-P flux are setting to + !! zero (z_cflxemp=0) to calculate the correction velocity. So + !! it will only balance the flux through open boundaries. + !! (set nn_volctl to 0 in tne namelist for this option) + !! 2/ The volume is constant even with E-P flux. In this case + !! the correction velocity must balance both the flux + !! through open boundaries and the ones through the free + !! surface. + !! (set nn_volctl to 1 in tne namelist for this option) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, kc ! ocean time-step index, cycle time-step + ! + INTEGER :: ji, jj, jk, jb, jgrd + INTEGER :: ib_bdy, ii, ij + REAL(wp) :: zubtpecor, ztranst + REAL(wp), SAVE :: z_cflxemp ! cumulated emp flux + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d ! Barotropic velocities + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phu, phv ! Ocean depth at U- and V-points + TYPE(OBC_INDEX), POINTER :: idx + !!----------------------------------------------------------------------------- + ! + ! Calculate the cumulate surface Flux z_cflxemp (m3/s) over all the domain + ! ----------------------------------------------------------------------- + IF ( kc == 1 ) z_cflxemp = glob_sum( 'bdyvol', ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) ) * bdytmask(:,:) * e1e2t(:,:) ) / rho0 + + ! Compute bdy surface each cycle if non linear free surface + ! --------------------------------------------------------- + IF ( .NOT. ln_linssh ) THEN + ! compute area each time step + bdysurftot = bdy_segs_surf( phu, phv ) + ELSE + ! compute area only the first time + IF ( ( kt == nit000 ) .AND. ( kc == 1 ) ) bdysurftot = bdy_segs_surf( phu, phv ) + END IF + + ! Transport through the unstructured open boundary + ! ------------------------------------------------ + zubtpecor = 0._wp + DO ib_bdy = 1, nb_bdy + idx => idx_bdy(ib_bdy) + ! + jgrd = 2 ! cumulate u component contribution first + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! sum : else halo couted twice + zubtpecor = zubtpecor + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij) + END DO + jgrd = 3 ! then add v component contribution + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! sum : else halo couted twice + zubtpecor = zubtpecor + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1) + END DO + ! + END DO + IF( lk_mpp ) CALL mpp_sum( 'bdyvol', zubtpecor ) ! sum over the global domain + + ! The normal velocity correction + ! ------------------------------ + IF( nn_volctl==1 ) THEN ; zubtpecor = ( zubtpecor - z_cflxemp ) / bdysurftot ! maybe should be apply only once at the end + ELSE ; zubtpecor = zubtpecor / bdysurftot + END IF + + ! Correction of the total velocity on the unstructured boundary to respect the mass flux conservation + ! ------------------------------------------------------------- + DO ib_bdy = 1, nb_bdy + idx => idx_bdy(ib_bdy) + ! + jgrd = 2 ! correct u component + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + !IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove ? + pua2d(ii,ij) = pua2d(ii,ij) - idx%flagu(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii+1,ij) + END DO + jgrd = 3 ! correct v component + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + !IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove ? + pva2d(ii,ij) = pva2d(ii,ij) - idx%flagv(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii,ij+1) + END DO + ! + END DO + ! + ! Check the cumulated transport through unstructured OBC once barotropic velocities corrected + ! ------------------------------------------------------ + IF( MOD( kt, MAX(nn_write,1) ) == 0 .AND. ( kc == 1 ) ) THEN + ! + ! compute residual transport across boundary + ztranst = 0._wp + DO ib_bdy = 1, nb_bdy + idx => idx_bdy(ib_bdy) + ! + jgrd = 2 ! correct u component + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE + ztranst = ztranst + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij) + END DO + jgrd = 3 ! correct v component + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE + ztranst = ztranst + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1) + END DO + ! + END DO + IF( lk_mpp ) CALL mpp_sum('bdyvol', ztranst ) ! sum over the global domain + + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'bdy_vol : time step :', kt + IF(lwp) WRITE(numout,*)'~~~~~~~ ' + IF(lwp) WRITE(numout,*)' cumulate flux EMP =', z_cflxemp , ' (m3/s)' + IF(lwp) WRITE(numout,*)' total lateral surface of OBC =', bdysurftot, '(m2)' + IF(lwp) WRITE(numout,*)' correction velocity zubtpecor =', zubtpecor , '(m/s)' + IF(lwp) WRITE(numout,*)' cumulated transport ztranst =', ztranst , '(m3/s)' + END IF + ! + END SUBROUTINE bdy_vol2d + ! + REAL(wp) FUNCTION bdy_segs_surf(phu, phv) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_ctl_seg *** + !! + !! ** Purpose : Compute total lateral surface for volume correction + !! + !!---------------------------------------------------------------------- + + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phu, phv ! water column thickness at U and V points + INTEGER :: igrd, ib_bdy, ib ! loop indexes + INTEGER , POINTER :: nbi, nbj ! short cuts + REAL(wp), POINTER :: zflagu, zflagv ! - - + + ! Compute total lateral surface for volume correction: + ! ---------------------------------------------------- + bdy_segs_surf = 0._wp + igrd = 2 ! Lateral surface at U-points + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) + nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) + nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( nbi == 1 .OR. nbi == jpi .OR. nbj == 1 .OR. nbj == jpj ) CYCLE + zflagu => idx_bdy(ib_bdy)%flagu(ib,igrd) + bdy_segs_surf = bdy_segs_surf + phu(nbi, nbj) & + & * e2u(nbi, nbj) * ABS( zflagu ) & + & * tmask_i(nbi, nbj) * tmask_i(nbi+1, nbj) + END DO + END DO + + igrd=3 ! Add lateral surface at V-points + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) + nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) + nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( nbi == 1 .OR. nbi == jpi .OR. nbj == 1 .OR. nbj == jpj ) CYCLE + zflagv => idx_bdy(ib_bdy)%flagv(ib,igrd) + bdy_segs_surf = bdy_segs_surf + phv(nbi, nbj) & + & * e1v(nbi, nbj) * ABS( zflagv ) & + & * tmask_i(nbi, nbj) * tmask_i(nbi, nbj+1) + END DO + END DO + ! + ! redirect the time to bdyvol as this variable is only used by bdyvol + IF( lk_mpp ) CALL mpp_sum( 'bdyvol', bdy_segs_surf ) ! sum over the global domain + ! + END FUNCTION bdy_segs_surf + !!====================================================================== +END MODULE bdyvol diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/c1d.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/c1d.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7645827603dcc91be93e9963e36db5916a0c7888 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/c1d.f90 @@ -0,0 +1,79 @@ + + + + + + + + + + + + + +MODULE c1d + !!====================================================================== + !! *** MODULE c1d *** + !! Ocean domain : 1D configuration + !!===================================================================== + !! History : 2.0 ! 2004-09 (C. Ethe) Original code + !! 3.0 ! 2008-04 (G. Madec) adaptation to SBC + !! 3.5 ! 2013-10 (D. Calvert) add namelist + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! c1d_init : read in the C1D namelist + !!---------------------------------------------------------------------- + USE par_kind ! kind parameters + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC c1d_init ! called by nemogcm.F90 + + REAL(wp), PUBLIC :: rn_lat1d !: Column latitude + REAL(wp), PUBLIC :: rn_lon1d !: Column longitude + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: c1d.F90 15023 2021-06-18 14:35:25Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +CONTAINS + + SUBROUTINE c1d_init + !!---------------------------------------------------------------------- + !! *** ROUTINE c1d_init *** + !! + !! ** Purpose : Initialization of C1D options + !! + !! ** Method : Read namelist namc1d + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namc1d/ rn_lat1d, rn_lon1d + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namc1d, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d in reference namelist' ) + ! + READ ( numnam_cfg, namc1d, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d in configuration namelist' ) + IF(lwm) WRITE ( numond, namc1d ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'c1d_init : Initialize 1D model configuration options' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist namc1d : set options for the C1D model' + WRITE(numout,*) ' column latitude rn_lat1d = ', rn_lat1d + WRITE(numout,*) ' column longitude rn_lon1d = ', rn_lon1d + ENDIF + ! + END SUBROUTINE c1d_init + + !!====================================================================== +END MODULE c1d diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/closea.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/closea.f90 new file mode 100644 index 0000000000000000000000000000000000000000..70f979a746e0cb5808e625246e0304eb008576e5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/closea.f90 @@ -0,0 +1,276 @@ + + + + + + + + + + + + + +MODULE closea + !!====================================================================== + !! *** MODULE closea *** + !! + !! User define : specific treatments associated with closed seas + !!====================================================================== + !! History : 8.2 ! 2000-05 (O. Marti) Original code + !! NEMO 1.0 ! 2002-06 (E. Durand, G. Madec) F90 + !! 3.0 ! 2006-07 (G. Madec) add clo_rnf, clo_ups, clo_bat + !! 3.4 ! 2014-12 (P.G. Fogli) sbc_clo bug fix & mpp reproducibility + !! 4.0 ! 2016-06 (G. Madec) move to usrdef_closea, remove clo_ups + !! 4.0 ! 2017-12 (D. Storkey) new formulation based on masks read from file + !! 4.1 ! 2019-07 (P. Mathiot) update to the new domcfg.nc input file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_clo : read in masks which define closed seas and runoff areas + !! clo_rnf : set close sea outflows as river mouths (see sbcrnf) + !! clo_msk : set to zero a field over closed sea (see domzgr) + !!---------------------------------------------------------------------- + USE in_out_manager ! I/O manager + ! + USE diu_bulk , ONLY: ln_diurnal_only ! used for sanity check + USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_global ! I/O routines + USE lib_fortran , ONLY: glob_sum ! fortran library + USE lib_mpp , ONLY: mpp_max, ctl_nam, ctl_stop ! MPP library + + IMPLICIT NONE + + PRIVATE + + PUBLIC dom_clo ! called by domain module + PUBLIC clo_rnf ! called by sbcrnf module + PUBLIC clo_msk ! called in domzgr module + + LOGICAL, PUBLIC :: ln_maskcs !: logical to mask all closed sea + LOGICAL, PUBLIC :: ln_mask_csundef !: logical to mask all undefined closed sea + LOGICAL, PUBLIC :: ln_clo_rnf !: closed sea treated as runoff (update rnf mask) + + ! WARNING: keep default definitions in the following lines as dom_clo is called only if ln_closea = .true. + LOGICAL, PUBLIC :: l_sbc_clo = .FALSE. !: T => net evap/precip over closed seas spread outover the globe/river mouth + LOGICAL, PUBLIC :: l_clo_rnf = .FALSE. !: T => Some closed seas output freshwater (RNF) to specified runoff points. + + INTEGER, PUBLIC :: ncsg = 0 !: number of closed seas global mappings (inferred from closea_mask_glo field) + INTEGER, PUBLIC :: ncsr = 0 !: number of closed seas rnf mappings (inferred from closea_mask_rnf field) + INTEGER, PUBLIC :: ncse = 0 !: number of closed seas empmr mappings (inferred from closea_mask_emp field) + + INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_opnsea, mask_csundef !: mask defining the open sea and the undefined closed sea + + INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_csglo , mask_csgrpglo !: mask of integers defining closed seas + INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_csrnf , mask_csgrprnf !: mask of integers defining closed seas rnf mappings + INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_csemp , mask_csgrpemp !: mask of integers defining closed seas empmr mappings + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: closea.F90 13558 2020-10-02 15:30:22Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_clo() + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_clo *** + !! + !! ** Purpose : Closed sea domain initialization + !! + !! ** Action : Read mask_cs* fields (if needed) from domain_cfg file and infer + !! number of closed seas for each case (glo, rnf, emp) from mask_cs* field. + !! + !! ** Output : mask_csglo and mask_csgrpglo : integer values defining mappings from closed seas and associated groups to the open ocean for net fluxes. + !! mask_csrnf and mask_csgrprnf : integer values defining mappings from closed seas and associated groups to a runoff area for downwards flux only. + !! mask_csemp and mask_csgrpemp : integer values defining mappings from closed seas and associated groups to a runoff area for net fluxes. + !!---------------------------------------------------------------------- + INTEGER :: ios ! io status + !! + NAMELIST/namclo/ ln_maskcs, ln_mask_csundef, ln_clo_rnf + !!--------------------------------------------------------------------- + !! + READ ( numnam_ref, namclo, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namclo in reference namelist' ) + READ ( numnam_cfg, namclo, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namclo in configuration namelist' ) + IF(lwm) WRITE ( numond, namclo ) + !! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'dom_clo : read in masks to define closed seas ' + IF(lwp) WRITE(numout,*)'~~~~~~~' + IF(lwp) WRITE(numout,*) + !! + !! check option compatibility + IF( .NOT. ln_read_cfg ) THEN + CALL ctl_stop('Suppression of closed seas does not work with ln_read_cfg = .true. . Set ln_closea = .false. .') + ENDIF + !! + IF( (.NOT. ln_maskcs) .AND. ln_diurnal_only ) THEN + CALL ctl_stop('Special handling of freshwater fluxes over closed seas not compatible with ln_diurnal_only.') + END IF + ! + ! read the closed seas masks (if they exist) from domain_cfg file (if it exists) + ! ------------------------------------------------------------------------------ + ! + ! load mask of open sea + CALL alloc_csmask( mask_opnsea ) + CALL read_csmask( cn_domcfg, 'mask_opensea' , mask_opnsea ) + ! + IF ( ln_maskcs ) THEN + ! closed sea are masked + IF(lwp) WRITE(numout,*)' ln_maskcs = T : all closed seas are masked' + IF(lwp) WRITE(numout,*) + ! no special treatment of closed sea + ! no redistribution of emp unbalance over closed sea into river mouth/open ocean + l_sbc_clo = .false. ; l_clo_rnf = .false. + ELSE + ! redistribution of emp unbalance over closed sea into river mouth/open ocean + IF(lwp) WRITE(numout,*)' ln_maskcs = F : net emp is corrected over defined closed seas' + ! + l_sbc_clo = .true. + ! + ! river mouth from lakes added to rnf mask for special treatment + IF ( ln_clo_rnf) l_clo_rnf = .true. + ! + IF ( ln_mask_csundef) THEN + ! closed sea not defined (ie not in the domcfg namelist used to build the domcfg.nc file) are masked + IF(lwp) WRITE(numout,*)' ln_mask_csundef = T : all undefined closed seas are masked' + ! + CALL alloc_csmask( mask_csundef ) + CALL read_csmask( cn_domcfg, 'mask_csundef', mask_csundef ) + ! revert the mask for masking of undefined closed seas in domzgr + ! (0 over the undefined closed sea and 1 elsewhere) + mask_csundef(:,:) = 1 - mask_csundef(:,:) + END IF + IF(lwp) WRITE(numout,*) + ! + ! allocate source mask for each cases + CALL alloc_csmask( mask_csglo ) + CALL alloc_csmask( mask_csrnf ) + CALL alloc_csmask( mask_csemp ) + ! + ! load source mask of cs for each cases + CALL read_csmask( cn_domcfg, 'mask_csglo', mask_csglo ) + CALL read_csmask( cn_domcfg, 'mask_csrnf', mask_csrnf ) + CALL read_csmask( cn_domcfg, 'mask_csemp', mask_csemp ) + ! + ! compute number of cs for each cases + ncsg = MAXVAL( mask_csglo(:,:) ) ; CALL mpp_max( 'closea', ncsg ) + ncsr = MAXVAL( mask_csrnf(:,:) ) ; CALL mpp_max( 'closea', ncsr ) + ncse = MAXVAL( mask_csemp(:,:) ) ; CALL mpp_max( 'closea', ncse ) + ! + ! allocate closed sea group masks + !(used to defined the target area in case multiple lakes have the same river mouth (great lakes for example)) + CALL alloc_csmask( mask_csgrpglo ) + CALL alloc_csmask( mask_csgrprnf ) + CALL alloc_csmask( mask_csgrpemp ) + + ! load mask of cs group for each cases + CALL read_csmask( cn_domcfg, 'mask_csgrpglo', mask_csgrpglo ) + CALL read_csmask( cn_domcfg, 'mask_csgrprnf', mask_csgrprnf ) + CALL read_csmask( cn_domcfg, 'mask_csgrpemp', mask_csgrpemp ) + ! + END IF + END SUBROUTINE dom_clo + + SUBROUTINE clo_rnf( p_rnfmsk ) + !!--------------------------------------------------------------------- + !! *** ROUTINE clo_rnf *** + !! + !! ** Purpose : allow the treatment of closed sea outflow grid-points + !! to be the same as river mouth grid-points + !! + !! ** Method : set to 1 the runoff mask (mskrnf, see sbcrnf module) + !! at the closed sea outflow grid-point. + !! + !! ** Action : update (p_)mskrnf (set 1 at closed sea outflow) + !!---------------------------------------------------------------------- + !! subroutine parameter + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: p_rnfmsk ! river runoff mask (rnfmsk array) + !! + !! local variables + REAL(wp), DIMENSION(jpi,jpj) :: zmsk + !!---------------------------------------------------------------------- + ! + ! zmsk > 0 where cs river mouth defined (case rnf and emp) + zmsk(:,:) = ( mask_csgrprnf (:,:) + mask_csgrpemp(:,:) ) * mask_opnsea(:,:) + WHERE( zmsk(:,:) > 0 ) + p_rnfmsk(:,:) = 1.0_wp + END WHERE + ! + END SUBROUTINE clo_rnf + + SUBROUTINE clo_msk( k_top, k_bot, k_mask, cd_prt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE clo_msk *** + !! + !! ** Purpose : Suppress closed sea from the domain + !! + !! ** Method : Where closea_mask > 0 set first and last ocean level to 0 + !! (As currently coded you can't define a closea_mask field in + !! usr_def_zgr). + !! + !! ** Action : set k_top=0 and k_bot=0 over closed seas + !!---------------------------------------------------------------------- + !! subroutine parameter + INTEGER, DIMENSION(:,:), INTENT(inout) :: k_top, k_bot ! ocean first and last level indices + INTEGER, DIMENSION(:,:), INTENT(in ) :: k_mask ! mask used to mask ktop and k_bot + CHARACTER(LEN=*), INTENT(in ) :: cd_prt ! text for control print + !! + !! local variables + !!---------------------------------------------------------------------- + !! + IF ( lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'clo_msk : Suppression closed seas based on ',TRIM(cd_prt),' field.' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) + ENDIF + !! + k_top(:,:) = k_top(:,:) * k_mask(:,:) + k_bot(:,:) = k_bot(:,:) * k_mask(:,:) + !! + END SUBROUTINE clo_msk + + SUBROUTINE read_csmask(cd_file, cd_var, k_mskout) + !!--------------------------------------------------------------------- + !! *** ROUTINE read_csmask *** + !! + !! ** Purpose : read mask in cd_filec file + !!---------------------------------------------------------------------- + ! subroutine parameter + CHARACTER(LEN=256), INTENT(in ) :: cd_file ! netcdf file name + CHARACTER(LEN= * ), INTENT(in ) :: cd_var ! netcdf variable name + INTEGER, DIMENSION(:,:), INTENT( out) :: k_mskout ! output mask variable + ! + ! local variables + INTEGER :: ics ! netcdf id + REAL(wp), DIMENSION(jpi,jpj) :: zdta ! netcdf data + !!---------------------------------------------------------------------- + ! + CALL iom_open ( cd_file, ics ) + CALL iom_get ( ics, jpdom_global, TRIM(cd_var), zdta ) + CALL iom_close( ics ) + k_mskout(:,:) = NINT(zdta(:,:)) + ! + END SUBROUTINE read_csmask + + SUBROUTINE alloc_csmask( kmask ) + !!--------------------------------------------------------------------- + !! *** ROUTINE alloc_csmask *** + !! + !! ** Purpose : allocated cs mask + !!---------------------------------------------------------------------- + ! subroutine parameter + INTEGER, ALLOCATABLE, DIMENSION(:,:), INTENT(inout) :: kmask + ! + ! local variables + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + ALLOCATE( kmask(jpi,jpj) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'alloc_csmask: failed to allocate surf array') + ! + END SUBROUTINE alloc_csmask + +END MODULE closea diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/cpl_oasis3.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/cpl_oasis3.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e36e1a5e4f79bbb62815c827851f6b97a7d717a1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/cpl_oasis3.f90 @@ -0,0 +1,565 @@ + + + + + + + + + + + + + +MODULE cpl_oasis3 + !!====================================================================== + !! *** MODULE cpl_oasis *** + !! Coupled O/A : coupled ocean-atmosphere case using OASIS3-MCT + !!===================================================================== + !! History : 1.0 ! 2004-06 (R. Redler, NEC Laboratories Europe, Germany) Original code + !! - ! 2004-11 (R. Redler, NEC Laboratories Europe; N. Keenlyside, W. Park, IFM-GEOMAR, Germany) revision + !! - ! 2004-11 (V. Gayler, MPI M&D) Grid writing + !! 2.0 ! 2005-08 (R. Redler, W. Park) frld initialization, paral(2) revision + !! - ! 2005-09 (R. Redler) extended to allow for communication over root only + !! - ! 2006-01 (W. Park) modification of physical part + !! - ! 2006-02 (R. Redler, W. Park) buffer array fix for root exchange + !! 3.4 ! 2011-11 (C. Harris) Changes to allow mutiple category fields + !! 3.6 ! 2014-11 (S. Masson) OASIS3-MCT + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 'key_oasis3' coupled Ocean/Atmosphere via OASIS3-MCT + !!---------------------------------------------------------------------- + !! cpl_init : initialization of coupled mode communication + !! cpl_define : definition of grid and fields + !! cpl_snd : snd out fields in coupled mode + !! cpl_rcv : receive fields in coupled mode + !! cpl_finalize : finalize the coupled mode communication + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC cpl_init + PUBLIC cpl_define + PUBLIC cpl_snd + PUBLIC cpl_rcv + PUBLIC cpl_freq + PUBLIC cpl_finalize + + INTEGER, PUBLIC :: OASIS_Rcv = 1 !: return code if received field + INTEGER, PUBLIC :: OASIS_idle = 0 !: return code if nothing done by oasis + INTEGER :: ncomp_id ! id returned by oasis_init_comp + INTEGER :: nerror ! return error code + ! OASIS Variables not used. defined only for compilation purpose + INTEGER :: OASIS_Out = -1 + INTEGER :: OASIS_REAL = -1 + INTEGER :: OASIS_Ok = -1 + INTEGER :: OASIS_In = -1 + INTEGER :: OASIS_Sent = -1 + INTEGER :: OASIS_SentOut = -1 + INTEGER :: OASIS_ToRest = -1 + INTEGER :: OASIS_ToRestOut = -1 + INTEGER :: OASIS_Recvd = -1 + INTEGER :: OASIS_RecvOut = -1 + INTEGER :: OASIS_FromRest = -1 + INTEGER :: OASIS_FromRestOut = -1 + + INTEGER :: nrcv ! total number of fields received + INTEGER :: nsnd ! total number of fields sent + INTEGER :: ncplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data + INTEGER, PUBLIC, PARAMETER :: nmaxfld=62 ! Maximum number of coupling fields + INTEGER, PUBLIC, PARAMETER :: nmaxcat=5 ! Maximum number of coupling fields + INTEGER, PUBLIC, PARAMETER :: nmaxcpl=5 ! Maximum number of coupling fields + + TYPE, PUBLIC :: FLD_CPL !: Type for coupling field information + LOGICAL :: laction ! To be coupled or not + CHARACTER(len = 8) :: clname ! Name of the coupling field + CHARACTER(len = 1) :: clgrid ! Grid type + REAL(wp) :: nsgn ! Control of the sign change + INTEGER, DIMENSION(nmaxcat,nmaxcpl) :: nid ! Id of the field (no more than 9 categories and 9 extrena models) + INTEGER :: nct ! Number of categories in field + INTEGER :: ncplmodel ! Maximum number of models to/from which this variable may be sent/received + END TYPE FLD_CPL + + TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC :: srcv, ssnd !: Coupling fields + + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: exfld ! Temporary buffer for receiving + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: cpl_oasis3.F90 14434 2021-02-11 08:20:52Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE cpl_init( cd_modname, kl_comm ) + !!------------------------------------------------------------------- + !! *** ROUTINE cpl_init *** + !! + !! ** Purpose : Initialize coupled mode communication for ocean + !! exchange between AGCM, OGCM and COUPLER. (OASIS3 software) + !! + !! ** Method : OASIS3 MPI communication + !!-------------------------------------------------------------------- + CHARACTER(len = *), INTENT(in ) :: cd_modname ! model name as set in namcouple file + INTEGER , INTENT( out) :: kl_comm ! local communicator of the model + !!-------------------------------------------------------------------- + + ! WARNING: No write in numout in this routine + !============================================ + + !------------------------------------------------------------------ + ! 1st Initialize the OASIS system for the application + !------------------------------------------------------------------ + CALL oasis_init_comp ( ncomp_id, TRIM(cd_modname), nerror ) + IF( nerror /= OASIS_Ok ) & + CALL oasis_abort (ncomp_id, 'cpl_init', 'Failure in oasis_init_comp') + + !------------------------------------------------------------------ + ! 3rd Get an MPI communicator for OCE local communication + !------------------------------------------------------------------ + + CALL oasis_get_localcomm ( kl_comm, nerror ) + IF( nerror /= OASIS_Ok ) & + CALL oasis_abort (ncomp_id, 'cpl_init','Failure in oasis_get_localcomm' ) + ! + END SUBROUTINE cpl_init + + + SUBROUTINE cpl_define( krcv, ksnd, kcplmodel ) + !!------------------------------------------------------------------- + !! *** ROUTINE cpl_define *** + !! + !! ** Purpose : Define grid and field information for ocean + !! exchange between AGCM, OGCM and COUPLER. (OASIS3 software) + !! + !! ** Method : OASIS3 MPI communication + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: krcv, ksnd ! Number of received and sent coupling fields + INTEGER, INTENT(in) :: kcplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data + ! + INTEGER :: id_part + INTEGER :: paral(5) ! OASIS3 box partition + INTEGER :: ishape(4) ! shape of arrays passed to PSMILe + INTEGER :: ji,jc,jm ! local loop indicees + CHARACTER(LEN=64) :: zclname + CHARACTER(LEN=2) :: cli2 + !!-------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'cpl_define : initialization in coupled ocean/atmosphere case' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) + + ncplmodel = kcplmodel + IF( kcplmodel > nmaxcpl ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'ncplmodel is larger than nmaxcpl, increase nmaxcpl') ; RETURN + ENDIF + + nrcv = krcv + IF( nrcv > nmaxfld ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'nrcv is larger than nmaxfld, increase nmaxfld') ; RETURN + ENDIF + + nsnd = ksnd + IF( nsnd > nmaxfld ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'nsnd is larger than nmaxfld, increase nmaxfld') ; RETURN + ENDIF + ! + ! ... Define the shape for the area that excludes the halo as we don't want them to be "seen" by oasis + ! + ishape(1) = 1 + ishape(2) = Ni_0 + ishape(3) = 1 + ishape(4) = Nj_0 + ! + ! ... Allocate memory for data exchange + ! + ALLOCATE(exfld(Ni_0, Nj_0), stat = nerror) ! allocate only inner domain (without halos) + IF( nerror > 0 ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld') ; RETURN + ENDIF + ! + ! ----------------------------------------------------------------- + ! ... Define the partition, excluding halos as we don't want them to be "seen" by oasis + ! ----------------------------------------------------------------- + + paral(1) = 2 ! box partitioning + paral(2) = Ni0glo * mjg0(nn_hls) + mig0(nn_hls) ! NEMO lower left corner global offset, without halos + paral(3) = Ni_0 ! local extent in i, excluding halos + paral(4) = Nj_0 ! local extent in j, excluding halos + paral(5) = Ni0glo ! global extent in x, excluding halos + + IF( sn_cfctl%l_oasout ) THEN + WRITE(numout,*) ' multiexchg: paral (1:5)', paral + WRITE(numout,*) ' multiexchg: Ni_0, Nj_0 =', Ni_0, Nj_0 + WRITE(numout,*) ' multiexchg: Nis0, Nie0, nimpp =', Nis0, Nie0, nimpp + WRITE(numout,*) ' multiexchg: Njs0, Nje0, njmpp =', Njs0, Nje0, njmpp + ENDIF + + CALL oasis_def_partition ( id_part, paral, nerror, Ni0glo*Nj0glo ) ! global number of points, excluding halos + ! + ! ... Announce send variables. + ! + ssnd(:)%ncplmodel = kcplmodel + ! + DO ji = 1, ksnd + IF( ssnd(ji)%laction ) THEN + + IF( ssnd(ji)%nct > nmaxcat ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '// & + & TRIM(ssnd(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' ) + RETURN + ENDIF + + DO jc = 1, ssnd(ji)%nct + DO jm = 1, kcplmodel + + IF( ssnd(ji)%nct .GT. 1 ) THEN + WRITE(cli2,'(i2.2)') jc + zclname = TRIM(ssnd(ji)%clname)//'_cat'//cli2 + ELSE + zclname = ssnd(ji)%clname + ENDIF + IF( kcplmodel > 1 ) THEN + WRITE(cli2,'(i2.2)') jm + zclname = 'model'//cli2//'_'//TRIM(zclname) + ENDIF + IF( sn_cfctl%l_oasout ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_Out + CALL oasis_def_var (ssnd(ji)%nid(jc,jm), zclname, id_part , (/ 2, 1 /), & + & OASIS_Out , ishape , OASIS_REAL, nerror ) + IF( nerror /= OASIS_Ok ) THEN + WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname) + CALL oasis_abort ( ssnd(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' ) + ENDIF + IF( sn_cfctl%l_oasout .AND. ssnd(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple" + IF( sn_cfctl%l_oasout .AND. ssnd(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple" + END DO + END DO + ENDIF + END DO + ! + ! ... Announce received variables. + ! + srcv(:)%ncplmodel = kcplmodel + ! + DO ji = 1, krcv + IF( srcv(ji)%laction ) THEN + + IF( srcv(ji)%nct > nmaxcat ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '// & + & TRIM(srcv(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' ) + RETURN + ENDIF + + DO jc = 1, srcv(ji)%nct + DO jm = 1, kcplmodel + + IF( srcv(ji)%nct .GT. 1 ) THEN + WRITE(cli2,'(i2.2)') jc + zclname = TRIM(srcv(ji)%clname)//'_cat'//cli2 + ELSE + zclname = srcv(ji)%clname + ENDIF + IF( kcplmodel > 1 ) THEN + WRITE(cli2,'(i2.2)') jm + zclname = 'model'//cli2//'_'//TRIM(zclname) + ENDIF + IF( sn_cfctl%l_oasout ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_In + CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part , (/ 2, 1 /), & + & OASIS_In , ishape , OASIS_REAL, nerror ) + IF( nerror /= OASIS_Ok ) THEN + WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname) + CALL oasis_abort ( srcv(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' ) + ENDIF + IF( sn_cfctl%l_oasout .AND. srcv(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple" + IF( sn_cfctl%l_oasout .AND. srcv(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple" + + END DO + END DO + ENDIF + END DO + + !------------------------------------------------------------------ + ! End of definition phase + !------------------------------------------------------------------ + ! + CALL oasis_enddef(nerror) + IF( nerror /= OASIS_Ok ) CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in oasis_enddef') + ! + END SUBROUTINE cpl_define + + + SUBROUTINE cpl_snd( kid, kstep, pdata, kinfo ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cpl_snd *** + !! + !! ** Purpose : - At each coupling time-step,this routine sends fields + !! like sst or ice cover to the coupler or remote application. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kid ! variable index in the array + INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument + INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdata + !! + INTEGER :: jc,jm ! local loop index + !!-------------------------------------------------------------------- + ! + ! snd data to OASIS3 + ! + DO jc = 1, ssnd(kid)%nct + DO jm = 1, ssnd(kid)%ncplmodel + + IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN ! exclude halos from data sent to oasis + CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(Nis0:Nie0, Njs0:Nje0,jc), kinfo ) + + IF ( sn_cfctl%l_oasout ) THEN + IF ( kinfo == OASIS_Sent .OR. kinfo == OASIS_ToRest .OR. & + & kinfo == OASIS_SentOut .OR. kinfo == OASIS_ToRestOut ) THEN + WRITE(numout,*) '****************' + WRITE(numout,*) 'oasis_put: Outgoing ', ssnd(kid)%clname + WRITE(numout,*) 'oasis_put: ivarid ', ssnd(kid)%nid(jc,jm) + WRITE(numout,*) 'oasis_put: kstep ', kstep + WRITE(numout,*) 'oasis_put: info ', kinfo + WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) ' - Sum value is ', SUM(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) '****************' + ENDIF + ENDIF + + ENDIF + + ENDDO + ENDDO + ! + END SUBROUTINE cpl_snd + + + SUBROUTINE cpl_rcv( kid, kstep, pdata, pmask, kinfo ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cpl_rcv *** + !! + !! ** Purpose : - At each coupling time-step,this routine receives fields + !! like stresses and fluxes from the coupler or remote application. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kid ! variable index in the array + INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdata ! IN to keep the value if nothing is done + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! coupling mask + INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument + !! + INTEGER :: jc,jm ! local loop index + LOGICAL :: llaction, ll_1st + !!-------------------------------------------------------------------- + ! + ! receive local data from OASIS3 on every process + ! + kinfo = OASIS_idle + ! + DO jc = 1, srcv(kid)%nct + ll_1st = .TRUE. + + DO jm = 1, srcv(kid)%ncplmodel + + IF( srcv(kid)%nid(jc,jm) /= -1 ) THEN + + CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, exfld, kinfo ) + + llaction = kinfo == OASIS_Recvd .OR. kinfo == OASIS_FromRest .OR. & + & kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut + + IF ( sn_cfctl%l_oasout ) & + & WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm) + + IF( llaction ) THEN ! data received from oasis do not include halos + + kinfo = OASIS_Rcv + IF( ll_1st ) THEN + pdata(Nis0:Nie0,Njs0:Nje0,jc) = exfld(:,:) * pmask(Nis0:Nie0,Njs0:Nje0,jm) + ll_1st = .FALSE. + ELSE + pdata(Nis0:Nie0,Njs0:Nje0,jc) = pdata(Nis0:Nie0,Njs0:Nje0,jc) & + & + exfld(:,:) * pmask(Nis0:Nie0,Njs0:Nje0,jm) + ENDIF + + IF ( sn_cfctl%l_oasout ) THEN + WRITE(numout,*) '****************' + WRITE(numout,*) 'oasis_get: Incoming ', srcv(kid)%clname + WRITE(numout,*) 'oasis_get: ivarid ' , srcv(kid)%nid(jc,jm) + WRITE(numout,*) 'oasis_get: kstep', kstep + WRITE(numout,*) 'oasis_get: info ', kinfo + WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) ' - Sum value is ', SUM(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) '****************' + ENDIF + + ENDIF + + ENDIF + + ENDDO + + !--- we must call lbc_lnk to fill the halos that where not received. + IF( .NOT. ll_1st ) THEN + CALL lbc_lnk( 'cpl_oasis3', pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn ) + ENDIF + + ENDDO + ! + END SUBROUTINE cpl_rcv + + + INTEGER FUNCTION cpl_freq( cdfieldname ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cpl_freq *** + !! + !! ** Purpose : - send back the coupling frequency for a particular field + !!---------------------------------------------------------------------- + CHARACTER(len = *), INTENT(in) :: cdfieldname ! field name as set in namcouple file + !! + INTEGER :: id + INTEGER :: info + INTEGER, DIMENSION(1) :: itmp + INTEGER :: ji,jm ! local loop index + INTEGER :: mop + !!---------------------------------------------------------------------- + cpl_freq = 0 ! defaut definition + id = -1 ! defaut definition + ! + DO ji = 1, nsnd + IF(ssnd(ji)%laction ) THEN + DO jm = 1, ncplmodel + IF( ssnd(ji)%nid(1,jm) /= -1 ) THEN + IF( TRIM(cdfieldname) == TRIM(ssnd(ji)%clname) ) THEN + id = ssnd(ji)%nid(1,jm) + mop = OASIS_Out + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + DO ji = 1, nrcv + IF(srcv(ji)%laction ) THEN + DO jm = 1, ncplmodel + IF( srcv(ji)%nid(1,jm) /= -1 ) THEN + IF( TRIM(cdfieldname) == TRIM(srcv(ji)%clname) ) THEN + id = srcv(ji)%nid(1,jm) + mop = OASIS_In + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + ! + IF( id /= -1 ) THEN + CALL oasis_get_freqs(id, mop, 1, itmp, info) + cpl_freq = itmp(1) + ENDIF + ! + END FUNCTION cpl_freq + + + SUBROUTINE cpl_finalize + !!--------------------------------------------------------------------- + !! *** ROUTINE cpl_finalize *** + !! + !! ** Purpose : - Finalizes the coupling. If MPI_init has not been + !! called explicitly before cpl_init it will also close + !! MPI communication. + !!---------------------------------------------------------------------- + ! + DEALLOCATE( exfld ) + IF(nstop == 0) THEN + CALL oasis_terminate( nerror ) + ELSE + CALL oasis_abort( ncomp_id, "cpl_finalize", "NEMO ABORT STOP" ) + ENDIF + ! + END SUBROUTINE cpl_finalize + + + !!---------------------------------------------------------------------- + !! No OASIS Library OASIS3 Dummy module... + !!---------------------------------------------------------------------- + + SUBROUTINE oasis_init_comp(k1,cd1,k2) + CHARACTER(*), INTENT(in ) :: cd1 + INTEGER , INTENT( out) :: k1,k2 + k1 = -1 ; k2 = -1 + WRITE(numout,*) 'oasis_init_comp: Error you sould not be there...', cd1 + END SUBROUTINE oasis_init_comp + + SUBROUTINE oasis_abort(k1,cd1,cd2) + INTEGER , INTENT(in ) :: k1 + CHARACTER(*), INTENT(in ) :: cd1,cd2 + WRITE(numout,*) 'oasis_abort: Error you sould not be there...', cd1, cd2 + END SUBROUTINE oasis_abort + + SUBROUTINE oasis_get_localcomm(k1,k2) + INTEGER , INTENT( out) :: k1,k2 + k1 = -1 ; k2 = -1 + WRITE(numout,*) 'oasis_get_localcomm: Error you sould not be there...' + END SUBROUTINE oasis_get_localcomm + + SUBROUTINE oasis_def_partition(k1,k2,k3,k4) + INTEGER , INTENT( out) :: k1,k3 + INTEGER , INTENT(in ) :: k2(5) + INTEGER , INTENT(in ) :: k4 + k1 = k2(1) ; k3 = k2(5)+k4 + WRITE(numout,*) 'oasis_def_partition: Error you sould not be there...' + END SUBROUTINE oasis_def_partition + + SUBROUTINE oasis_def_var(k1,cd1,k2,k3,k4,k5,k6,k7) + CHARACTER(*), INTENT(in ) :: cd1 + INTEGER , INTENT(in ) :: k2,k3(2),k4,k5(2,2),k6 + INTEGER , INTENT( out) :: k1,k7 + k1 = -1 ; k7 = -1 + WRITE(numout,*) 'oasis_def_var: Error you sould not be there...', cd1 + END SUBROUTINE oasis_def_var + + SUBROUTINE oasis_enddef(k1) + INTEGER , INTENT( out) :: k1 + k1 = -1 + WRITE(numout,*) 'oasis_enddef: Error you sould not be there...' + END SUBROUTINE oasis_enddef + + SUBROUTINE oasis_put(k1,k2,p1,k3) + REAL(wp), DIMENSION(:,:), INTENT(in ) :: p1 + INTEGER , INTENT(in ) :: k1,k2 + INTEGER , INTENT( out) :: k3 + k3 = -1 + WRITE(numout,*) 'oasis_put: Error you sould not be there...' + END SUBROUTINE oasis_put + + SUBROUTINE oasis_get(k1,k2,p1,k3) + REAL(wp), DIMENSION(:,:), INTENT( out) :: p1 + INTEGER , INTENT(in ) :: k1,k2 + INTEGER , INTENT( out) :: k3 + p1(1,1) = -1. ; k3 = -1 + WRITE(numout,*) 'oasis_get: Error you sould not be there...' + END SUBROUTINE oasis_get + + SUBROUTINE oasis_get_freqs(k1,k5,k2,k3,k4) + INTEGER , INTENT(in ) :: k1,k2 + INTEGER, DIMENSION(1), INTENT( out) :: k3 + INTEGER , INTENT( out) :: k4,k5 + k3(1) = k1 ; k4 = k2 ; k5 = k2 + WRITE(numout,*) 'oasis_get_freqs: Error you sould not be there...' + END SUBROUTINE oasis_get_freqs + + SUBROUTINE oasis_terminate(k1) + INTEGER , INTENT( out) :: k1 + k1 = -1 + WRITE(numout,*) 'oasis_terminate: Error you sould not be there...' + END SUBROUTINE oasis_terminate + + + !!===================================================================== +END MODULE cpl_oasis3 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crs.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crs.f90 new file mode 100644 index 0000000000000000000000000000000000000000..755dbdc0566b3b46381369b1a2d26854721b9920 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crs.f90 @@ -0,0 +1,331 @@ + + + + + + + + + + + + + +MODULE crs + !!====================================================================== + !! *** MODULE crs_dom *** + !! Declare the coarse grid domain and other public variables + !! then allocate them if needed. + !!====================================================================== + !! History 2012-06 Editing (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code + !!---------------------------------------------------------------------- + USE par_oce + USE dom_oce + USE in_out_manager + + IMPLICIT NONE + PUBLIC + + PUBLIC crs_dom_alloc ! Called from crsini.F90 + PUBLIC crs_dom_alloc2 ! Called from crsini.F90 + PUBLIC dom_grid_glo + PUBLIC dom_grid_crs + + ! Domain variables + INTEGER :: jpiglo_crs , & !: 1st dimension of global coarse grid domain + jpjglo_crs !: 2nd dimension of global coarse grid domain + INTEGER :: jpi_crs , & !: 1st dimension of local coarse grid domain + jpj_crs !: 2nd dimension of local coarse grid domain + INTEGER :: jpi_full , & !: 1st dimension of local parent grid domain + jpj_full !: 2nd dimension of local parent grid domain + + INTEGER :: nistr , njstr + INTEGER :: niend , njend + + INTEGER :: jpi_crsm1, jpj_crsm1 !: loop indices + INTEGER :: jpiglo_crsm1, jpjglo_crsm1 !: loop indices +!!$ INTEGER :: nperio_full, nperio_crs !: jperio of parent and coarse grids +!!$ INTEGER :: npolj_full, npolj_crs !: north fold mark + INTEGER :: jpiglo_full, jpjglo_full !: jpiglo / jpjglo + INTEGER :: npiglo, npjglo !: jpjglo + INTEGER :: Nis0_full, Njs0_full !: starting indices of internal sub-domain on parent grid + INTEGER :: Nie0_full, Nje0_full !: ending indices of internal sub-domain on parent grid + INTEGER :: Nis0_crs , Njs0_crs !: starting indices of internal sub-domain on coarse grid + INTEGER :: Nie0_crs , Nje0_crs !: ending indices of internal sub-domain on coarse grid + + INTEGER :: narea_full, narea_crs !: node + INTEGER :: jpnij_full, jpnij_crs !: =jpni*jpnj, the pe decomposition +!!$ INTEGER :: jpim1_full, jpjm1_full !: + INTEGER :: nimpp_full, njmpp_full !: global position of point (1,1) of subdomain on parent grid + INTEGER :: nimpp_crs, njmpp_crs !: set to 1,1 for now . Valid only for monoproc + + INTEGER, DIMENSION(:), ALLOCATABLE :: mis_crs, mie_crs, mis2_crs, mie2_crs ! starting and ending i-indices of parent subset + INTEGER, DIMENSION(:), ALLOCATABLE :: mjs_crs, mje_crs, mjs2_crs, mje2_crs ! starting and ending j-indices of parent subset + INTEGER, DIMENSION(:), ALLOCATABLE :: mjg_crs, mig_crs + INTEGER, DIMENSION(:), ALLOCATABLE :: mi0_crs, mi1_crs, mj0_crs, mj1_crs + INTEGER :: mxbinctr, mybinctr ! central point in grid box +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: jpiall_crs, jpiall_full !: dimensions of every subdomain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nis0all_crs, nis0all_full !: first, last indoor index for each i-domain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nie0all_crs, nie0all_full !: first, last indoor index for each j-domain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nimppt_crs, nimppt_full !: first, last indoor index for each j-domain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: jpjall_crs, jpjall_full !: dimensions of every subdomain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: njs0all_crs, njs0all_full !: first, last indoor index for each i-domain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nje0all_crs, nje0all_full !: first, last indoor index for each j-domain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: njmppt_crs, njmppt_full !: first, last indoor index for each j-domain + + + ! Masks + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_crs, umask_crs, vmask_crs, fmask_crs + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: rnfmsk_crs + + ! Scale factors + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1t_crs, e2t_crs, e1e2t_crs ! horizontal scale factors grid type T + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1u_crs, e2u_crs ! horizontal scale factors grid type U + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1v_crs, e2v_crs ! horizontal scale factors grid type V + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1f_crs, e2f_crs ! horizontal scale factors grid type F + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_crs, e3u_crs, e3v_crs, e3f_crs, e3w_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_max_crs, e3u_max_crs, e3v_max_crs, e3f_max_crs, e3w_max_crs + + ! Surface + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e1e2w_crs, e2e3u_crs, e1e3v_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e1e2w_msk, e2e3u_msk, e1e3v_msk + ! vertical scale factors + ! Coordinates + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphit_crs, glamt_crs, gphif_crs, glamf_crs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphiu_crs, glamu_crs, gphiv_crs, glamv_crs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ff_crs + INTEGER, DIMENSION(:,:), ALLOCATABLE :: mbathy_crs, mbkt_crs, mbku_crs, mbkv_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: gdept_crs, gdepu_crs, gdepv_crs, gdepw_crs + + ! Weights + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: facsurfv, facsurfu, facvol_t, facvol_w + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ocean_volume_crs_t, ocean_volume_crs_w, bt_crs, r1_bt_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: crs_surfu_wgt, crs_surfv_wgt, crs_surfw_wgt, crs_volt_wgt + + ! CRS Namelist + INTEGER :: nn_factx = 3 !: reduction factor of x-dimension of the parent grid + INTEGER :: nn_facty = 3 !: reduction factor of y-dimension of the parent grid + INTEGER :: nn_binref = 0 !: 0 = binning starts north fold (equator could be asymmetric) + !: 1 = binning centers at equator (north fold my have artifacts) + !: for even reduction factors, equator placed in bin biased south + LOGICAL :: ln_msh_crs = .TRUE. !: =T Create a meshmask file for CRS + INTEGER :: nn_crs_kz = 0 !: type of Kz coarsening ( =0->VOL ; =1->MAX ; =2->MIN) + LOGICAL :: ln_crs_wn = .FALSE. !: coarsening wn or computation using horizontal divergence + ! + INTEGER :: nrestx, nresty !: for determining odd or even reduction factor + + + ! Grid reduction factors + REAL(wp) :: rfactx_r !: inverse of x-dim reduction factor + REAL(wp) :: rfacty_r !: inverse of y-dim reduction factor + REAL(wp) :: rfactxy + + ! Physical and dynamical ocean fields for output or passing to TOP, time-mean fields + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tsn_crs + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: un_crs, vn_crs, wn_crs + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: hdivn_crs + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: sshn_crs + ! + ! Surface fluxes to pass to TOP + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: qsr_crs, fr_i_crs, wndm_crs + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: emp_crs, emp_b_crs, sfx_crs + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: utau_crs, vtau_crs + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: rnf_crs + + ! Vertical diffusion + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_crs !: temperature vertical diffusivity coeff. [m2/s] at w-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avs_crs !: salinity vertical diffusivity coeff. [m2/s] at w-point + + ! Mixing and Mixed Layer Depth + INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: nmln_crs, hmld_crs, hmlp_crs, hmlpt_crs + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crs.F90 15033 2021-06-21 10:24:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION crs_dom_alloc() + !!------------------------------------------------------------------- + !! *** FUNCTION crs_dom_alloc *** + !! ** Purpose : Allocate public crs arrays + !!------------------------------------------------------------------- + !! Local variables + INTEGER, DIMENSION(17) :: ierr + + ierr(:) = 0 + + ! Set up bins for coarse grid, horizontal only. + ALLOCATE( mis2_crs(jpiglo_crs), mie2_crs(jpiglo_crs), & + & mjs2_crs(jpjglo_crs), mje2_crs(jpjglo_crs), & + & mi0_crs (jpiglo_crs), mi1_crs (jpiglo_crs), & + & mj0_crs (jpjglo_crs), mj1_crs (jpjglo_crs), & + & mig_crs (jpi_crs) , mjg_crs (jpj_crs) , STAT=ierr(1) ) + + + ! Set up Mask and Mesh + ALLOCATE( tmask_crs(jpi_crs,jpj_crs,jpk) , fmask_crs(jpi_crs,jpj_crs,jpk) , & + & umask_crs(jpi_crs,jpj_crs,jpk) , vmask_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(2)) + + ALLOCATE( rnfmsk_crs(jpi_crs,jpj_crs), STAT=ierr(3) ) + + ALLOCATE( gphit_crs(jpi_crs,jpj_crs) , glamt_crs(jpi_crs,jpj_crs) , & + & gphiu_crs(jpi_crs,jpj_crs) , glamu_crs(jpi_crs,jpj_crs) , & + & gphiv_crs(jpi_crs,jpj_crs) , glamv_crs(jpi_crs,jpj_crs) , & + & gphif_crs(jpi_crs,jpj_crs) , glamf_crs(jpi_crs,jpj_crs) , & + & ff_crs(jpi_crs,jpj_crs) , STAT=ierr(4)) + + ALLOCATE( e1t_crs(jpi_crs,jpj_crs) , e2t_crs(jpi_crs,jpj_crs) , & + & e1u_crs(jpi_crs,jpj_crs) , e2u_crs(jpi_crs,jpj_crs) , & + & e1v_crs(jpi_crs,jpj_crs) , e2v_crs(jpi_crs,jpj_crs) , & + & e1f_crs(jpi_crs,jpj_crs) , e2f_crs(jpi_crs,jpj_crs) , & + & e1e2t_crs(jpi_crs,jpj_crs), STAT=ierr(5)) + + ALLOCATE( e3t_crs(jpi_crs,jpj_crs,jpk) , e3w_crs(jpi_crs,jpj_crs,jpk) , & + & e3u_crs(jpi_crs,jpj_crs,jpk) , e3v_crs(jpi_crs,jpj_crs,jpk) , & + & e3f_crs(jpi_crs,jpj_crs,jpk) , e1e2w_msk(jpi_crs,jpj_crs,jpk) , & + & e2e3u_msk(jpi_crs,jpj_crs,jpk) , e1e3v_msk(jpi_crs,jpj_crs,jpk) , & + & e1e2w_crs(jpi_crs,jpj_crs,jpk) , e2e3u_crs(jpi_crs,jpj_crs,jpk) , & + & e1e3v_crs(jpi_crs,jpj_crs,jpk) , e3t_max_crs(jpi_crs,jpj_crs,jpk), & + & e3w_max_crs(jpi_crs,jpj_crs,jpk), e3u_max_crs(jpi_crs,jpj_crs,jpk), & + & e3v_max_crs(jpi_crs,jpj_crs,jpk), STAT=ierr(6)) + + + ALLOCATE( facsurfv(jpi_crs,jpj_crs,jpk), facsurfu(jpi_crs,jpj_crs,jpk) , & + & facvol_t(jpi_crs,jpj_crs,jpk), facvol_w(jpi_crs,jpj_crs,jpk) , & + & ocean_volume_crs_t(jpi_crs,jpj_crs,jpk), ocean_volume_crs_w(jpi_crs,jpj_crs,jpk), & + & bt_crs(jpi_crs,jpj_crs,jpk) , r1_bt_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(7)) + + + ALLOCATE( crs_surfu_wgt(jpi_crs,jpj_crs,jpk), crs_surfv_wgt(jpi_crs,jpj_crs,jpk) , & + & crs_surfw_wgt(jpi_crs,jpj_crs,jpk), crs_volt_wgt(jpi_crs,jpj_crs,jpk) , STAT=ierr(8)) + + + ALLOCATE( mbathy_crs(jpi_crs,jpj_crs), mbkt_crs(jpi_crs,jpj_crs) , & + & mbku_crs(jpi_crs,jpj_crs) , mbkv_crs(jpi_crs,jpj_crs) , STAT=ierr(9)) + + ALLOCATE( gdept_crs(jpi_crs,jpj_crs,jpk), gdepu_crs(jpi_crs,jpj_crs,jpk) , & + & gdepv_crs(jpi_crs,jpj_crs,jpk), gdepw_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(10) ) + + + ALLOCATE( un_crs(jpi_crs,jpj_crs,jpk) , vn_crs (jpi_crs,jpj_crs,jpk) , & + & wn_crs(jpi_crs,jpj_crs,jpk) , hdivn_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(11)) + + ALLOCATE( sshn_crs(jpi_crs,jpj_crs), emp_crs (jpi_crs,jpj_crs), emp_b_crs(jpi_crs,jpj_crs), & + & qsr_crs(jpi_crs ,jpj_crs), wndm_crs(jpi_crs,jpj_crs), utau_crs(jpi_crs,jpj_crs) , & + & vtau_crs(jpi_crs,jpj_crs), rnf_crs(jpi_crs ,jpj_crs), & + & fr_i_crs(jpi_crs,jpj_crs), sfx_crs(jpi_crs ,jpj_crs), STAT=ierr(12) ) + + ALLOCATE( tsn_crs(jpi_crs,jpj_crs,jpk,jpts), avt_crs(jpi_crs,jpj_crs,jpk), & + & avs_crs(jpi_crs,jpj_crs,jpk), STAT=ierr(13) ) + + ALLOCATE( nmln_crs(jpi_crs,jpj_crs) , hmld_crs(jpi_crs,jpj_crs) , & + & hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(14) ) + +!!$ ALLOCATE( nimppt_crs (jpnij) , jpiall_crs (jpnij) , nis0all_crs (jpnij) , nie0all_crs (jpnij), & +!!$ & nimppt_full(jpnij) , jpiall_full(jpnij) , nis0all_full(jpnij) , nie0all_full(jpnij), & +!!$ njmppt_crs (jpnij) , jpjall_crs (jpnij) , njs0all_crs (jpnij) , nje0all_crs (jpnij), & +!!$ & njmppt_full(jpnij) , jpjall_full(jpnij) , njs0all_full(jpnij) , nje0all_full(jpnij) , STAT=ierr(15) ) + + crs_dom_alloc = MAXVAL(ierr) + ! + END FUNCTION crs_dom_alloc + + + INTEGER FUNCTION crs_dom_alloc2() + !!------------------------------------------------------------------- + !! *** FUNCTION crs_dom_alloc *** + !! ** Purpose : Allocate public crs arrays + !!------------------------------------------------------------------- + !! Local variables + INTEGER, DIMENSION(1) :: ierr + + ierr(:) = 0 + + ALLOCATE( mjs_crs(Nje0_crs) , mje_crs(Nje0_crs), mis_crs(Nie0_crs) , mie_crs(Nie0_crs), STAT=ierr(1) ) + crs_dom_alloc2 = MAXVAL(ierr) + + END FUNCTION crs_dom_alloc2 + + + SUBROUTINE dom_grid_glo + !!-------------------------------------------------------------------- + !! *** MODULE dom_grid_glo *** + !! + !! ** Purpose : +Return back to parent grid domain + !!--------------------------------------------------------------------- + + ! Return to parent grid domain + jpi = jpi_full + jpj = jpj_full +!!$ jpim1 = jpim1_full +!!$ jpjm1 = jpjm1_full +!!$ jperio = nperio_full + +!!$ npolj = npolj_full + jpiglo = jpiglo_full + jpjglo = jpjglo_full + + jpi = jpi_full + jpj = jpj_full + Nis0 = Nis0_full + Njs0 = Njs0_full + Nie0 = Nie0_full + Nje0 = Nje0_full + nimpp = nimpp_full + njmpp = njmpp_full + +!!$ jpiall (:) = jpiall_full (:) +!!$ nis0all(:) = nis0all_full(:) +!!$ nie0all(:) = nie0all_full(:) +!!$ nimppt (:) = nimppt_full (:) +!!$ jpjall (:) = jpjall_full (:) +!!$ njs0all(:) = njs0all_full(:) +!!$ nje0all(:) = nje0all_full(:) +!!$ njmppt (:) = njmppt_full (:) + + END SUBROUTINE dom_grid_glo + + + SUBROUTINE dom_grid_crs + !!-------------------------------------------------------------------- + !! *** MODULE dom_grid_crs *** + !! + !! ** Purpose : Save the parent grid information & Switch to coarse grid domain + !!--------------------------------------------------------------------- + ! + ! Switch to coarse grid domain + jpi = jpi_crs + jpj = jpj_crs +!!$ jpim1 = jpi_crsm1 +!!$ jpjm1 = jpj_crsm1 +!!$ jperio = nperio_crs + +!!$ npolj = npolj_crs + jpiglo = jpiglo_crs + jpjglo = jpjglo_crs + + + jpi = jpi_crs + jpj = jpj_crs + Nis0 = Nis0_crs + Nie0 = Nie0_crs + Nje0 = Nje0_crs + Njs0 = Njs0_crs + nimpp = nimpp_crs + njmpp = njmpp_crs + +!!$ jpiall (:) = jpiall_crs (:) +!!$ nis0all(:) = nis0all_crs(:) +!!$ nie0all(:) = nie0all_crs(:) +!!$ nimppt (:) = nimppt_crs (:) +!!$ jpjall (:) = jpjall_crs (:) +!!$ njs0all(:) = njs0all_crs(:) +!!$ nje0all(:) = nje0all_crs(:) +!!$ njmppt (:) = njmppt_crs (:) + ! + END SUBROUTINE dom_grid_crs + + !!====================================================================== +END MODULE crs diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsdom.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsdom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..906f2dccbf7415973fa39ada5e23796c7c4181b8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsdom.f90 @@ -0,0 +1,2283 @@ + + + + + + + + + + + + + +MODULE crsdom + !!=================================================================== + !! *** crs.F90 *** + !! Purpose: Interface for calculating quantities from a + !! higher-resolution grid for the coarse grid. + !! + !! Method: Given the user-defined reduction factor, + !! the averaging bins are set: + !! - nn_binref = 0, starting from the north + !! to the south in the model interior domain, + !! in this way the north fold and redundant halo cells + !! could be handled in a consistent manner and + !! the irregularities of bin size can be handled + !! more naturally by the presence of land + !! in the southern boundary. Thus the southernmost bin + !! could be of an irregular bin size. + !! Information on the parent grid is retained, specifically, + !! each coarse grid cell's volume and ocean surface + !! at the faces, relative to the parent grid. + !! - nn_binref = 1 (not yet available), starting + !! at a centralized bin at the equator, being only + !! truly centered for odd-numbered j-direction reduction + !! factors. + !! References: Aumont, O., J.C. Orr, D. Jamous, P. Monfray + !! O. Marti and G. Madec, 1998. A degradation + !! approach to accelerate simulations to steady-state + !! in a 3-D tracer transport model of the global ocean. + !! Climate Dynamics, 14:101-116. + !! History: + !! Original. May 2012. (J. Simeon, C. Calone, G. Madec, C. Ethe) + !!=================================================================== + USE dom_oce ! ocean space and time domain + USE crs ! domain for coarse grid + ! + USE in_out_manager + USE par_kind + USE crslbclnk + USE lib_mpp + + IMPLICIT NONE + + PRIVATE + + PUBLIC crs_dom_ope + PUBLIC crs_dom_e3, crs_dom_sfc, crs_dom_msk, crs_dom_hgr, crs_dom_coordinates + PUBLIC crs_dom_facvol, crs_dom_def, crs_dom_bat + + INTERFACE crs_dom_ope + MODULE PROCEDURE crs_dom_ope_3d, crs_dom_ope_2d + END INTERFACE + + REAL(wp) :: r_inf = 1e+36 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crsdom.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_dom_msk + + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie,ijis,ijje,ijjs,ij,je_2 + REAL(wp) :: zmask + + ! Initialize + + tmask_crs(:,:,:) = 0.0 + vmask_crs(:,:,:) = 0.0 + umask_crs(:,:,:) = 0.0 + fmask_crs(:,:,:) = 0.0 + + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) ; ij = je_2 + ENDIF + ELSE + je_2 = mje_crs(2) ; ij = mjs_crs(2) + ENDIF + DO jk = 1, jpkm1 + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) ; ijie = mie_crs(ji) + ! + zmask = 0.0 + zmask = SUM( tmask(ijis:ijie,ij:je_2,jk) ) + IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0_wp + + zmask = 0.0 + zmask = SUM( vmask(ijis:ijie,je_2 ,jk) ) + IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0_wp + + zmask = 0.0 + zmask = SUM(umask(ijie,ij:je_2,jk)) + IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0_wp + + fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk) + ENDDO + ENDDO + ! + DO jk = 1, jpkm1 + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) ; ijie = mie_crs(ji) + DO jj = 3, Nje0_crs + ijjs = mjs_crs(jj) ; ijje = mje_crs(jj) + + zmask = 0.0 + zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) + IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0_wp + + zmask = 0.0 + zmask = SUM( vmask(ijis:ijie,ijje ,jk) ) + IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0_wp + + zmask = 0.0 + zmask = SUM( umask(ijie ,ijjs:ijje,jk) ) + IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0_wp + + fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) + ENDDO + ENDDO + ENDDO + + ! + CALL crs_lbc_lnk( tmask_crs, 'T', 1.0_wp ) + CALL crs_lbc_lnk( vmask_crs, 'V', 1.0_wp ) + CALL crs_lbc_lnk( umask_crs, 'U', 1.0_wp ) + CALL crs_lbc_lnk( fmask_crs, 'F', 1.0_wp ) + ! + END SUBROUTINE crs_dom_msk + + + SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crs_coordinates *** + !! ** Purpose : Determine the coordinates for the coarse grid + !! + !! ** Method : From the parent grid subset, search for the central + !! point. For an odd-numbered reduction factor, + !! the coordinate will be that of the central T-cell. + !! For an even-numbered reduction factor, of a non-square + !! coarse grid box, the coordinate will be that of + !! the east or north face or more likely. For a square + !! coarse grid box, the coordinate will be that of + !! the central f-corner. + !! + !! ** Input : p_gphi = parent grid gphi[t|u|v|f] + !! p_glam = parent grid glam[t|u|v|f] + !! cd_type = grid type (T,U,V,F) + !! ** Output : p_gphi_crs = coarse grid gphi[t|u|v|f] + !! p_glam_crs = coarse grid glam[t|u|v|f] + !! + !! History. 1 Jun. + !!---------------------------------------------------------------- + !! Arguments + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_gphi ! Parent grid latitude + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_glam ! Parent grid longitude + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type (T,U,V,F) + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs ! Coarse grid latitude + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs ! Coarse grid longitude + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijis, ijjs + + + SELECT CASE ( cd_type ) + CASE ( 'T' ) + DO jj = Njs0_crs, Nje0_crs + ijjs = mjs_crs(jj) + mybinctr + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + mxbinctr + p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) + p_glam_crs(ji,jj) = p_glam(ijis,ijjs) + ENDDO + ENDDO + CASE ( 'U' ) + DO jj = Njs0_crs, Nje0_crs + ijjs = mjs_crs(jj) + mybinctr + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) + p_glam_crs(ji,jj) = p_glam(ijis,ijjs) + ENDDO + ENDDO + CASE ( 'V' ) + DO jj = Njs0_crs, Nje0_crs + ijjs = mjs_crs(jj) + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + mxbinctr + p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) + p_glam_crs(ji,jj) = p_glam(ijis,ijjs) + ENDDO + ENDDO + CASE ( 'F' ) + DO jj = Njs0_crs, Nje0_crs + ijjs = mjs_crs(jj) + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) + p_glam_crs(ji,jj) = p_glam(ijis,ijjs) + ENDDO + ENDDO + END SELECT + + ! Retroactively add back the boundary halo cells. + CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0_wp ) + CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0_wp ) + + ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd + SELECT CASE ( cd_type ) + CASE ( 'T', 'V' ) + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + mxbinctr + p_gphi_crs(ji,1) = p_gphi(ijis,1) + p_glam_crs(ji,1) = p_glam(ijis,1) + ENDDO + CASE ( 'U', 'F' ) + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + p_gphi_crs(ji,1) = p_gphi(ijis,1) + p_glam_crs(ji,1) = p_glam(ijis,1) + ENDDO + END SELECT + ! + END SUBROUTINE crs_dom_coordinates + + SUBROUTINE crs_dom_hgr( p_e1, p_e2, cd_type, p_e1_crs, p_e2_crs ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crs_dom_hgr *** + !! + !! ** Purpose : Get coarse grid horizontal scale factors and unmasked fraction + !! + !! ** Method : For grid types T,U,V,Fthe 2D scale factors of + !! the coarse grid are the sum of the east or north faces of the + !! parent grid subset comprising the coarse grid box. + !! - e1,e2 Scale factors + !! Valid arguments: + !! ** Inputs : p_e1, p_e2 = parent grid e1 or e2 (t,u,v,f) + !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) + !! ** Outputs : p_e1_crs, p_e2_crs = parent grid e1 or e2 (t,u,v,f) + !! + !! History. 4 Jun. Write for WGT and scale factors only + !!---------------------------------------------------------------- + !! + !! Arguments + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1 ! Parent grid U,V scale factors (e1) + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e2 ! Parent grid U,V scale factors (e2) + CHARACTER(len=1) , INTENT(in) :: cd_type ! grid type U,V + + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e1_crs ! Coarse grid box 2D quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e2_crs ! Coarse grid box 2D quantity + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie,ijje,ijrs + + !!---------------------------------------------------------------- + ! Initialize + + DO jk = 1, jpk + DO ji = 2, Nie0_crs + ijie = mie_crs(ji) + DO jj = Njs0_crs, Nje0_crs + ijje = mje_crs(jj) ; ijrs = mje_crs(jj) - mjs_crs(jj) + ! Only for a factro 3 coarsening + SELECT CASE ( cd_type ) + CASE ( 'T' ) + IF( ijrs == 0 .OR. ijrs == 1 ) THEN + ! Si à la frontière sud on a pas assez de maille de la grille mère + p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty + ELSE + p_e1_crs(ji,jj) = p_e1(ijie-1,ijje-1) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie-1,ijje-1) * nn_facty + ENDIF + CASE ( 'U' ) + IF( ijrs == 0 .OR. ijrs == 1 ) THEN + ! Si à la frontière sud on a pas assez de maille de la grille mère + p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty + ELSE + p_e1_crs(ji,jj) = p_e1(ijie,ijje-1) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie,ijje-1) * nn_facty + ENDIF + CASE ( 'V' ) + p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty + CASE ( 'F' ) + p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty + END SELECT + ENDDO + ENDDO + ENDDO + + CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) + + END SUBROUTINE crs_dom_hgr + + + SUBROUTINE crs_dom_facvol( p_mask, cd_type, p_e1, p_e2, p_e3, p_fld1_crs, p_fld2_crs ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crsfun_wgt *** + !! ** Purpose : Three applications. + !! 1) SUM. Get coarse grid horizontal scale factors and unmasked fraction + !! 2) VOL. Get coarse grid box volumes + !! 3) WGT. Weighting multiplier for volume-weighted and/or + !! area-weighted averages. + !! Weights (i.e. the denominator) calculated here + !! to avoid IF-tests and division. + !! ** Method : 1) SUM. For grid types T,U,V,F (and W) the 2D scale factors of + !! the coarse grid are the sum of the east or north faces of the + !! parent grid subset comprising the coarse grid box. + !! The fractions of masked:total surface (3D) on the east, + !! north and top faces is, optionally, also output. + !! - Top face area sum + !! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2 + !! - Top face ocean surface fraction + !! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2 + !! - e1,e2 Scale factors + !! Valid arguments: + !! 2) VOL. For grid types W and T, the coarse grid box + !! volumes are output. Also optionally, the fraction of + !! masked:total volume of the parent grid subset is output (i.e. facvol). + !! 3) WGT. Based on the grid type, the denominator is pre-determined here to + !! perform area- or volume- weighted averages, + !! to avoid IF-tests and divisions. + !! ** Inputs : p_e1, p_e2 = parent grid e1 or e2 (t,u,v,f) + !! p_pmask = parent grid mask (T,U,V,F) + !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) + !! cd_op = applied operation (SUM, VOL, WGT) + !! p_e3 = (Optional) parent grid vertical level thickness (e3u or e3v) + !! ** Outputs : p_cfield2d_1 = (Optional) 2D field on coarse grid + !! p_cfield2d_2 = (Optional) 2D field on coarse grid + !! p_cfield3d_1 = (Optional) 3D field on coarse grid + !! p_cfield3d_2 = (Optional) 3D field on coarse grid + !! + !! History. 4 Jun. Write for WGT and scale factors only + !!---------------------------------------------------------------- + CHARACTER(len=1), INTENT(in ) :: cd_type ! grid type U,V + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_mask ! Parent grid U,V mask + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: p_e1 ! Parent grid U,V scale factors (e1) + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: p_e2 ! Parent grid U,V scale factors (e2) + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld1_crs ! Coarse grid box 3D quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld2_crs ! Coarse grid box 3D quantity + ! + INTEGER :: ji, jj, jk , ii, ij, je_2 + REAL(wp) :: zdAm + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvol, zmask + !!---------------------------------------------------------------- + ! + ! + p_fld1_crs(:,:,:) = 0._wp + p_fld2_crs(:,:,:) = 0._wp + + DO jk = 1, jpk + zvol(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) + END DO + + zmask(:,:,:) = 0._wp + IF( cd_type == 'W' ) THEN + zmask(:,:,1) = p_mask(:,:,1) + DO jk = 2, jpk + zmask(:,:,jk) = p_mask(:,:,jk-1) + ENDDO + ELSE + DO jk = 1, jpk + zmask(:,:,jk) = p_mask(:,:,jk) + ENDDO + ENDIF + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + p_fld1_crs(ii,2,jk) = zvol(ji,je_2 ,jk) + zvol(ji+1,je_2 ,jk) + zvol(ji+2,je_2 ,jk) & + & + zvol(ji,je_2-1,jk) + zvol(ji+1,je_2-1,jk) + zvol(ji+2,je_2-1,jk) + ! + zdAm = zvol(ji ,je_2,jk) * zmask(ji ,je_2,jk) & + & + zvol(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) & + & + zvol(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + ! + p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + p_fld1_crs(ii,2,jk) = zvol(ji,je_2 ,jk) + zvol(ji+1,je_2 ,jk) + zvol(ji+2,je_2 ,jk) & + & + zvol(ji,je_2+1,jk) + zvol(ji+1,je_2+1,jk) + zvol(ji+2,je_2+1,jk) & + & + zvol(ji,je_2+2,jk) + zvol(ji+1,je_2+2,jk) + zvol(ji+2,je_2+2,jk) + ! + zdAm = zvol(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) & + & + zvol(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) & + & + zvol(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) & + & + zvol(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) & + & + zvol(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) & + & + zvol(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) & + & + zvol(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) & + & + zvol(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) & + & + zvol(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) + ! + p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) + ENDDO + ENDDO + ENDIF + + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + ! + p_fld1_crs(ii,ij,jk) = zvol(ji,jj ,jk) + zvol(ji+1,jj ,jk) + zvol(ji+2,jj ,jk) & + & + zvol(ji,jj+1,jk) + zvol(ji+1,jj+1,jk) + zvol(ji+2,jj+1,jk) & + & + zvol(ji,jj+2,jk) + zvol(ji+1,jj+2,jk) + zvol(ji+2,jj+2,jk) + ! + zdAm = zvol(ji ,jj ,jk) * zmask(ji ,jj ,jk) & + & + zvol(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) & + & + zvol(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) & + & + zvol(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) & + & + zvol(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) & + & + zvol(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) & + & + zvol(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) & + & + zvol(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) & + & + zvol(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + ! + p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk) + ENDDO + ENDDO + ENDDO + ! ! Retroactively add back the boundary halo cells. + CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0_wp ) + CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0_wp ) + ! + ! + END SUBROUTINE crs_dom_facvol + + + SUBROUTINE crs_dom_ope_3d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs, psgn ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crsfun_UV *** + !! ** Purpose : Average, area-weighted, of U or V on the east and north faces + !! + !! ** Method : The U and V velocities (3D) are determined as the area-weighted averages + !! on the east and north faces, respectively, + !! of the parent grid subset comprising the coarse grid box. + !! In the case of the V and F grid, the last jrow minus 1 is spurious. + !! ** Inputs : p_e1_e2 = parent grid e1 or e2 (t,u,v,f) + !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) + !! psgn = sign change over north fold (See lbclnk.F90) + !! p_pmask = parent grid mask (T,U,V,F) for scale factors; + !! for velocities (U or V) + !! p_e3 = parent grid vertical level thickness (e3u or e3v) + !! p_pfield = U or V on the parent grid + !! p_surf_crs = (Optional) Coarse grid weight for averaging + !! ** Outputs : p_cfield3d = 3D field on coarse grid + !! + !! History. 29 May. completed draft. + !! 4 Jun. Revision for WGT + !! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights. + !!---------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_fld ! T, U, V or W on parent grid + CHARACTER(len=3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask + REAL(dp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2) + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V maska + REAL(wp), INTENT(in) :: psgn ! sign + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld_crs ! Coarse grid box 3D quantity + ! + INTEGER :: ji, jj, jk + INTEGER :: ii, ij, ijie, ijje, je_2 + REAL(wp) :: zflcrs, zsfcrs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zsurf, zsurfmsk, zmask + !!---------------------------------------------------------------- + ! + p_fld_crs(:,:,:) = 0._wp + ! + SELECT CASE ( cd_op ) + ! + CASE ( 'VOL' ) + ! + ALLOCATE( zsurf(jpi,jpj,jpk), zsurfmsk(jpi,jpj,jpk) ) + ! + SELECT CASE ( cd_type ) + ! + CASE( 'T', 'W' ) + IF( cd_type == 'T' ) THEN + DO jk = 1, jpk + zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) + zsurfmsk(:,:,jk) = zsurf(:,:,jk) + ENDDO + ELSE + zsurf (:,:,1) = p_e12(:,:) * p_e3(:,:,1) + zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) + DO jk = 2, jpk + zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) + ENDDO + ENDIF + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2,jk) * zsurfmsk(ji ,je_2,jk) & + & + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) & + & + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) + + zsfcrs = zsurf(ji,je_2,jk) + zsurf(ji+1,je_2,jk) + zsurf(ji+2,je_2,jk) + ! + p_fld_crs(ii,2,jk) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2 ,jk) * zsurfmsk(ji ,je_2 ,jk) & + & + p_fld(ji+1,je_2 ,jk) * zsurfmsk(ji+1,je_2 ,jk) & + & + p_fld(ji+2,je_2 ,jk) * zsurfmsk(ji+2,je_2 ,jk) & + & + p_fld(ji ,je_2+1,jk) * zsurfmsk(ji ,je_2+1,jk) & + & + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & + & + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & + & + p_fld(ji ,je_2+2,jk) * zsurfmsk(ji ,je_2+2,jk) & + & + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & + & + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) + + zsfcrs = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & + & + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & + & + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) + ! + p_fld_crs(ii,2,jk) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = p_fld(ji ,jj ,jk) * zsurfmsk(ji ,jj ,jk) & + & + p_fld(ji+1,jj ,jk) * zsurfmsk(ji+1,jj ,jk) & + & + p_fld(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) & + & + p_fld(ji ,jj+1,jk) * zsurfmsk(ji ,jj+1,jk) & + & + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & + & + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & + & + p_fld(ji ,jj+2,jk) * zsurfmsk(ji ,jj+2,jk) & + & + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & + & + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) + + zsfcrs = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & + & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & + & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) + ! + p_fld_crs(ii,ij,jk) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs + ENDDO + ENDDO + ENDDO + CASE DEFAULT + CALL ctl_stop( 'STOP', 'error from crs_dom_ope_3d, you should not be there...' ) + END SELECT + + DEALLOCATE( zsurf, zsurfmsk ) + + CASE ( 'SUM' ) + + ALLOCATE( zsurfmsk(jpi,jpj,jpk) ) + + SELECT CASE ( cd_type ) + CASE( 'W' ) + IF( PRESENT( p_e3 ) ) THEN + zsurfmsk(:,:,1) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) + DO jk = 2, jpk + zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk-1) + ENDDO + ELSE + zsurfmsk(:,:,1) = p_e12(:,:) * p_mask(:,:,1) + DO jk = 2, jpk + zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk-1) + ENDDO + ENDIF + CASE DEFAULT + IF( PRESENT( p_e3 ) ) THEN + DO jk = 1, jpk + zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) + ENDDO + ELSE + DO jk = 1, jpk + zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk) + ENDDO + ENDIF + END SELECT + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2,jk) * zsurfmsk(ji ,je_2,jk) & + & + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) & + & + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2 ,jk) * zsurfmsk(ji ,je_2 ,jk) & + & + p_fld(ji+1,je_2 ,jk) * zsurfmsk(ji+1,je_2 ,jk) & + & + p_fld(ji+2,je_2 ,jk) * zsurfmsk(ji+2,je_2 ,jk) & + & + p_fld(ji ,je_2+1,jk) * zsurfmsk(ji ,je_2+1,jk) & + & + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & + & + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & + & + p_fld(ji ,je_2+2,jk) * zsurfmsk(ji ,je_2+2,jk) & + & + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & + & + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = p_fld(ji ,jj ,jk) * zsurfmsk(ji ,jj ,jk) & + & + p_fld(ji+1,jj ,jk) * zsurfmsk(ji+1,jj ,jk) & + & + p_fld(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) & + & + p_fld(ji ,jj+1,jk) * zsurfmsk(ji ,jj+1,jk) & + & + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & + & + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & + & + p_fld(ji ,jj+2,jk) * zsurfmsk(ji ,jj+2,jk) & + & + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & + & + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + ! + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,ijje,jk) * zsurfmsk(ji ,ijje,jk) & + & + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) & + & + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + zflcrs = p_fld(ji ,ijje,jk) * zsurfmsk(ji ,ijje,jk) & + & + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) & + & + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2,jk) * zsurfmsk(ijie,je_2,jk) + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2 ,jk) * zsurfmsk(ijie,je_2 ,jk) & + & + p_fld(ijie,je_2+1,jk) * zsurfmsk(ijie,je_2+1,jk) & + & + p_fld(ijie,je_2+2,jk) * zsurfmsk(ijie,je_2+2,jk) + + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,jj ,jk) * zsurfmsk(ijie,jj ,jk) & + & + p_fld(ijie,jj+1,jk) * zsurfmsk(ijie,jj+1,jk) & + & + p_fld(ijie,jj+2,jk) * zsurfmsk(ijie,jj+2,jk) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + END SELECT + + IF( PRESENT( p_surf_crs ) ) THEN + WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:,:) = p_fld_crs(:,:,:) / p_surf_crs(:,:,:) + ENDIF + + DEALLOCATE( zsurfmsk ) + + CASE ( 'MAX' ) ! search the max of unmasked grid cells + + ALLOCATE( zmask(jpi,jpj,jpk) ) + + SELECT CASE ( cd_type ) + CASE( 'W' ) + zmask(:,:,1) = p_mask(:,:,1) + DO jk = 2, jpk + zmask(:,:,jk) = p_mask(:,:,jk-1) + ENDDO + CASE ( 'T' ) + DO jk = 1, jpk + zmask(:,:,jk) = p_mask(:,:,jk) + ENDDO + END SELECT + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MAX( p_fld(ji ,je_2,jk) * zmask(ji ,je_2,jk) - ( 1.- zmask(ji ,je_2,jk) ) * r_inf , & + & p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) - ( 1.- zmask(ji+1,je_2,jk) ) * r_inf , & + & p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) - ( 1.- zmask(ji+2,je_2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MAX( p_fld(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) - ( 1.- zmask(ji ,je_2 ,jk) ) * r_inf , & + & p_fld(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) - ( 1.- zmask(ji+1,je_2 ,jk) ) * r_inf , & + & p_fld(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) - ( 1.- zmask(ji+2,je_2 ,jk) ) * r_inf , & + & p_fld(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) - ( 1.- zmask(ji ,je_2+1,jk) ) * r_inf , & + & p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) - ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf , & + & p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) - ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf , & + & p_fld(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) - ( 1.- zmask(ji ,je_2+2,jk) ) * r_inf , & + & p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) - ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf , & + & p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) - ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = & + & MAX( p_fld(ji ,jj ,jk) * zmask(ji ,jj ,jk) - ( 1.- zmask(ji ,jj ,jk) ) * r_inf , & + & p_fld(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) - ( 1.- zmask(ji+1,jj ,jk) ) * r_inf , & + & p_fld(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) - ( 1.- zmask(ji+2,jj ,jk) ) * r_inf , & + & p_fld(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) - ( 1.- zmask(ji ,jj+1,jk) ) * r_inf , & + & p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) - ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf , & + & p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) - ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf , & + & p_fld(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) - ( 1.- zmask(ji ,jj+2,jk) ) * r_inf , & + & p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) - ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf , & + & p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) - ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MAX( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + ! + zflcrs = & + & MAX( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = & + & MAX( p_fld(ijie,je_2 ,jk) * p_mask(ijie,je_2 ,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & + & p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & + & p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = & + & MAX( p_fld(ijie,jj ,jk) * p_mask(ijie,jj ,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & + & p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & + & p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + END SELECT + + DEALLOCATE( zmask ) + + CASE ( 'MIN' ) ! Search the min of unmasked grid cells + + ALLOCATE( zmask(jpi,jpj,jpk) ) + + SELECT CASE ( cd_type ) + CASE( 'W' ) + zmask(:,:,1) = p_mask(:,:,1) + DO jk = 2, jpk + zmask(:,:,jk) = p_mask(:,:,jk-1) + ENDDO + CASE ( 'T' ) + DO jk = 1, jpk + zmask(:,:,jk) = p_mask(:,:,jk) + ENDDO + END SELECT + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MIN( p_fld(ji ,je_2,jk) * zmask(ji ,je_2,jk) + ( 1.- zmask(ji ,je_2,jk) ) * r_inf , & + & p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) + ( 1.- zmask(ji+1,je_2,jk) ) * r_inf , & + & p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + ( 1.- zmask(ji+2,je_2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MIN( p_fld(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) + ( 1.- zmask(ji ,je_2 ,jk) ) * r_inf , & + & p_fld(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) + ( 1.- zmask(ji+1,je_2 ,jk) ) * r_inf , & + & p_fld(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) + ( 1.- zmask(ji+2,je_2 ,jk) ) * r_inf , & + & p_fld(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) + ( 1.- zmask(ji ,je_2+1,jk) ) * r_inf , & + & p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) + ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf , & + & p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) + ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf , & + & p_fld(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) + ( 1.- zmask(ji ,je_2+2,jk) ) * r_inf , & + & p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) + ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf , & + & p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) + ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = & + & MIN( p_fld(ji ,jj ,jk) * zmask(ji ,jj ,jk) + ( 1.- zmask(ji ,jj ,jk) ) * r_inf , & + & p_fld(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) + ( 1.- zmask(ji+1,jj ,jk) ) * r_inf , & + & p_fld(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) + ( 1.- zmask(ji+2,jj ,jk) ) * r_inf , & + & p_fld(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) + ( 1.- zmask(ji ,jj+1,jk) ) * r_inf , & + & p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) + ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf , & + & p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) + ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf , & + & p_fld(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) + ( 1.- zmask(ji ,jj+2,jk) ) * r_inf , & + & p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) + ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf , & + & p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MIN( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + zflcrs = & + & MIN( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = & + & MIN( p_fld(ijie,je_2 ,jk) * p_mask(ijie,je_2 ,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & + & p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & + & p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = & + & MIN( p_fld(ijie,jj ,jk) * p_mask(ijie,jj ,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & + & p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & + & p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + END SELECT + ! + DEALLOCATE( zmask ) + ! + END SELECT + ! + CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn ) + ! + END SUBROUTINE crs_dom_ope_3d + + SUBROUTINE crs_dom_ope_2d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs, psgn ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crsfun_UV *** + !! ** Purpose : Average, area-weighted, of U or V on the east and north faces + !! + !! ** Method : The U and V velocities (3D) are determined as the area-weighted averages + !! on the east and north faces, respectively, + !! of the parent grid subset comprising the coarse grid box. + !! In the case of the V and F grid, the last jrow minus 1 is spurious. + !! ** Inputs : p_e1_e2 = parent grid e1 or e2 (t,u,v,f) + !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) + !! psgn = sign change over north fold (See lbclnk.F90) + !! p_pmask = parent grid mask (T,U,V,F) for scale factors; + !! for velocities (U or V) + !! p_e3 = parent grid vertical level thickness (e3u or e3v) + !! p_pfield = U or V on the parent grid + !! p_surf_crs = (Optional) Coarse grid weight for averaging + !! ** Outputs : p_cfield3d = 3D field on coarse grid + !! + !! History. 29 May. completed draft. + !! 4 Jun. Revision for WGT + !! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights. + !!---------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_fld ! T, U, V or W on parent grid + CHARACTER(len=3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask + REAL(dp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2) + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V mask + REAL(wp), INTENT(in) :: psgn + REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie, ijje, ii, ij, je_2 + REAL(wp) :: zflcrs, zsfcrs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsurfmsk + !!---------------------------------------------------------------- + ! + p_fld_crs(:,:) = 0._wp + ! + SELECT CASE ( cd_op ) + + CASE ( 'VOL' ) + + ALLOCATE( zsurfmsk(jpi,jpj) ) + zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2) * zsurfmsk(ji ,je_2) & + & + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) & + & + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) + + zsfcrs = zsurfmsk(ji,je_2) + zsurfmsk(ji+1,je_2) + zsurfmsk(ji+2,je_2) + ! + p_fld_crs(ii,2) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2) = zflcrs / zsfcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2 ) * zsurfmsk(ji ,je_2 ) & + & + p_fld(ji+1,je_2 ) * zsurfmsk(ji+1,je_2 ) & + & + p_fld(ji+2,je_2 ) * zsurfmsk(ji+2,je_2 ) & + & + p_fld(ji ,je_2+1) * zsurfmsk(ji ,je_2+1) & + & + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) & + & + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) & + & + p_fld(ji ,je_2+2) * zsurfmsk(ji ,je_2+2) & + & + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) & + & + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) + + zsfcrs = zsurfmsk(ji,je_2 ) + zsurfmsk(ji+1,je_2 ) + zsurfmsk(ji+2,je_2 ) & + & + zsurfmsk(ji,je_2+1) + zsurfmsk(ji+1,je_2+1) + zsurfmsk(ji+2,je_2+1) & + & + zsurfmsk(ji,je_2+2) + zsurfmsk(ji+1,je_2+2) + zsurfmsk(ji+2,je_2+2) + ! + p_fld_crs(ii,2) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2) = zflcrs / zsfcrs + ENDDO + ENDIF + ! + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = p_fld(ji ,jj ) * zsurfmsk(ji ,jj ) & + & + p_fld(ji+1,jj ) * zsurfmsk(ji+1,jj ) & + & + p_fld(ji+2,jj ) * zsurfmsk(ji+2,jj ) & + & + p_fld(ji ,jj+1) * zsurfmsk(ji ,jj+1) & + & + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) & + & + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) & + & + p_fld(ji ,jj+2) * zsurfmsk(ji ,jj+2) & + & + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) & + & + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) + + zsfcrs = zsurfmsk(ji,jj ) + zsurfmsk(ji+1,jj ) + zsurfmsk(ji+2,jj ) & + & + zsurfmsk(ji,jj+1) + zsurfmsk(ji+1,jj+1) + zsurfmsk(ji+2,jj+1) & + & + zsurfmsk(ji,jj+2) + zsurfmsk(ji+1,jj+2) + zsurfmsk(ji+2,jj+2) + ! + p_fld_crs(ii,ij) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij) = zflcrs / zsfcrs + ENDDO + ENDDO + + DEALLOCATE( zsurfmsk ) + + CASE ( 'SUM' ) + + ALLOCATE( zsurfmsk(jpi,jpj) ) + IF( PRESENT( p_e3 ) ) THEN + zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) + ELSE + zsurfmsk(:,:) = p_e12(:,:) * p_mask(:,:,1) + ENDIF + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2) * zsurfmsk(ji ,je_2) & + & + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) & + & + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2 ) * zsurfmsk(ji ,je_2 ) & + & + p_fld(ji+1,je_2 ) * zsurfmsk(ji+1,je_2 ) & + & + p_fld(ji+2,je_2 ) * zsurfmsk(ji+2,je_2 ) & + & + p_fld(ji ,je_2+1) * zsurfmsk(ji ,je_2+1) & + & + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) & + & + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) & + & + p_fld(ji ,je_2+2) * zsurfmsk(ji ,je_2+2) & + & + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) & + & + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ! + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = p_fld(ji ,jj ) * zsurfmsk(ji ,jj ) & + & + p_fld(ji+1,jj ) * zsurfmsk(ji+1,jj ) & + & + p_fld(ji+2,jj ) * zsurfmsk(ji+2,jj ) & + & + p_fld(ji ,jj+1) * zsurfmsk(ji ,jj+1) & + & + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) & + & + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) & + & + p_fld(ji ,jj+2) * zsurfmsk(ji ,jj+2) & + & + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) & + & + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,ijje) * zsurfmsk(ji ,ijje) & + & + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) & + & + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + zflcrs = p_fld(ji ,ijje) * zsurfmsk(ji ,ijje) & + & + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) & + & + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2) * zsurfmsk(ijie,je_2) + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2 ) * zsurfmsk(ijie,je_2 ) & + & + p_fld(ijie,je_2+1) * zsurfmsk(ijie,je_2+1) & + & + p_fld(ijie,je_2+2) * zsurfmsk(ijie,je_2+2) + + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,jj ) * zsurfmsk(ijie,jj ) & + & + p_fld(ijie,jj+1) * zsurfmsk(ijie,jj+1) & + & + p_fld(ijie,jj+2) * zsurfmsk(ijie,jj+2) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + END SELECT + + IF( PRESENT( p_surf_crs ) ) THEN + WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:) = p_fld_crs(:,:) / p_surf_crs(:,:) + ENDIF + + DEALLOCATE( zsurfmsk ) + + CASE ( 'MAX' ) + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MAX( p_fld(ji ,je_2) * p_mask(ji ,je_2,1) - ( 1.- p_mask(ji ,je_2,1) ) * r_inf , & + & p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) - ( 1.- p_mask(ji+1,je_2,1) ) * r_inf , & + & p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) - ( 1.- p_mask(ji+2,je_2,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + zflcrs = & + & MAX( p_fld(ji ,je_2 ) * p_mask(ji ,je_2 ,1) - ( 1.- p_mask(ji ,je_2 ,1) ) * r_inf , & + & p_fld(ji+1,je_2 ) * p_mask(ji+1,je_2 ,1) - ( 1.- p_mask(ji+1,je_2 ,1) ) * r_inf , & + & p_fld(ji+2,je_2 ) * p_mask(ji+2,je_2 ,1) - ( 1.- p_mask(ji+2,je_2 ,1) ) * r_inf , & + & p_fld(ji ,je_2+1) * p_mask(ji ,je_2+1,1) - ( 1.- p_mask(ji ,je_2+1,1) ) * r_inf , & + & p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) - ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf , & + & p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) - ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf , & + & p_fld(ji ,je_2+2) * p_mask(ji ,je_2+2,1) - ( 1.- p_mask(ji ,je_2+2,1) ) * r_inf , & + & p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) - ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf , & + & p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) - ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDIF + + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = & + & MAX( p_fld(ji ,jj ) * p_mask(ji ,jj ,1) - ( 1.- p_mask(ji ,jj ,1) ) * r_inf , & + & p_fld(ji+1,jj ) * p_mask(ji+1,jj ,1) - ( 1.- p_mask(ji+1,jj ,1) ) * r_inf , & + & p_fld(ji+2,jj ) * p_mask(ji+2,jj ,1) - ( 1.- p_mask(ji+2,jj ,1) ) * r_inf , & + & p_fld(ji ,jj+1) * p_mask(ji ,jj+1,1) - ( 1.- p_mask(ji ,jj+1,1) ) * r_inf , & + & p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) - ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf , & + & p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) - ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf , & + & p_fld(ji ,jj+2) * p_mask(ji ,jj+2,1) - ( 1.- p_mask(ji ,jj+2,1) ) * r_inf , & + & p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) - ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf , & + & p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) - ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf ) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = MAX( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + ! + zflcrs = MAX( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2) * p_mask(ijie,je_2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = & + & MAX( p_fld(ijie,je_2 ) * p_mask(ijie,je_2 ,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & + & p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & + & p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf ) + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = & + & MAX( p_fld(ijie,jj ) * p_mask(ijie,jj ,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf , & + & p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf , & + & p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf ) + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + END SELECT + + CASE ( 'MIN' ) ! Search the min of unmasked grid cells + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MIN( p_fld(ji ,je_2) * p_mask(ji ,je_2,1) + ( 1.- p_mask(ji ,je_2,1) ) * r_inf , & + & p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) + ( 1.- p_mask(ji+1,je_2,1) ) * r_inf , & + & p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) + ( 1.- p_mask(ji+2,je_2,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + zflcrs = & + & MIN( p_fld(ji ,je_2 ) * p_mask(ji ,je_2 ,1) + ( 1.- p_mask(ji ,je_2 ,1) ) * r_inf , & + & p_fld(ji+1,je_2 ) * p_mask(ji+1,je_2 ,1) + ( 1.- p_mask(ji+1,je_2 ,1) ) * r_inf , & + & p_fld(ji+2,je_2 ) * p_mask(ji+2,je_2 ,1) + ( 1.- p_mask(ji+2,je_2 ,1) ) * r_inf , & + & p_fld(ji ,je_2+1) * p_mask(ji ,je_2+1,1) + ( 1.- p_mask(ji ,je_2+1,1) ) * r_inf , & + & p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) + ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf , & + & p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) + ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf , & + & p_fld(ji ,je_2+2) * p_mask(ji ,je_2+2,1) + ( 1.- p_mask(ji ,je_2+2,1) ) * r_inf , & + & p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) + ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf , & + & p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) + ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDIF + + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = & + & MIN( p_fld(ji ,jj ) * p_mask(ji ,jj ,1) + ( 1.- p_mask(ji ,jj ,1) ) * r_inf , & + & p_fld(ji+1,jj ) * p_mask(ji+1,jj ,1) + ( 1.- p_mask(ji+1,jj ,1) ) * r_inf , & + & p_fld(ji+2,jj ) * p_mask(ji+2,jj ,1) + ( 1.- p_mask(ji+2,jj ,1) ) * r_inf , & + & p_fld(ji ,jj+1) * p_mask(ji ,jj+1,1) + ( 1.- p_mask(ji ,jj+1,1) ) * r_inf , & + & p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) + ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf , & + & p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) + ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf , & + & p_fld(ji ,jj+2) * p_mask(ji ,jj+2,1) + ( 1.- p_mask(ji ,jj+2,1) ) * r_inf , & + & p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) + ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf , & + & p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) + ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf ) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = MIN( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + ! + zflcrs = MIN( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2) * p_mask(ijie,je_2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf + + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = & + & MIN( p_fld(ijie,je_2 ) * p_mask(ijie,je_2 ,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & + & p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & + & p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf ) + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = & + & MIN( p_fld(ijie,jj ) * p_mask(ijie,jj ,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf , & + & p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf , & + & p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf ) + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + END SELECT + ! + END SELECT + ! + CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn ) + ! + END SUBROUTINE crs_dom_ope_2d + + SUBROUTINE crs_dom_e3( p_e1, p_e2, p_e3, p_sfc_crs, cd_type, p_mask, p_e3_crs, p_e3_max_crs) + !!---------------------------------------------------------------- + !! Arguments + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T mask + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1, p_e2 ! 2D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in) :: p_sfc_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie, ijje, ii, ij, je_2 + REAL(wp) :: ze3crs + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask, zsurf + + !!---------------------------------------------------------------- + + p_e3_crs (:,:,:) = 0. + p_e3_max_crs(:,:,:) = 1. + + + SELECT CASE ( cd_type ) + CASE( 'W' ) + zmask(:,:,1) = p_mask(:,:,1) + DO jk = 2, jpk + zmask(:,:,jk) = p_mask(:,:,jk-1) + ENDDO + CASE DEFAULT + DO jk = 1, jpk + zmask(:,:,jk) = p_mask(:,:,jk) + ENDDO + END SELECT + + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) + ENDDO + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1 , jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ze3crs = zsurf(ji ,je_2,jk) * zmask(ji ,je_2,jk) & + & + zsurf(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) & + & + zsurf(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + + p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,ij,jk) + ! + ze3crs = MAX( p_e3(ji ,je_2,jk) * zmask(ji ,je_2,jk), & + & p_e3(ji+1,je_2,jk) * zmask(ji+1,je_2,jk), & + & p_e3(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) ) + ! + p_e3_max_crs(ii,2,jk) = ze3crs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1 , jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ze3crs = zsurf(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) & + & + zsurf(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) & + & + zsurf(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) & + & + zsurf(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) & + & + zsurf(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) & + & + zsurf(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) & + & + zsurf(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) & + & + zsurf(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) & + & + zsurf(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) + + p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) + ! + ze3crs = MAX( p_e3(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk), & + & p_e3(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk), & + & p_e3(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk), & + & p_e3(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk), & + & p_e3(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk), & + & p_e3(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk), & + & p_e3(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk), & + & p_e3(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk), & + & p_e3(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) ) + + p_e3_max_crs(ii,2,jk) = ze3crs + ENDDO + ENDDO + ENDIF + DO jk = 1 , jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ze3crs = zsurf(ji ,jj ,jk) * zmask(ji ,jj ,jk) & + & + zsurf(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) & + & + zsurf(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) & + & + zsurf(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) & + & + zsurf(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) & + & + zsurf(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) & + & + zsurf(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) & + & + zsurf(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) & + & + zsurf(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + + p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) + ! + ze3crs = MAX( p_e3(ji ,jj ,jk) * zmask(ji ,jj ,jk), & + & p_e3(ji+1,jj ,jk) * zmask(ji+1,jj ,jk), & + & p_e3(ji+2,jj ,jk) * zmask(ji+2,jj ,jk), & + & p_e3(ji ,jj+1,jk) * zmask(ji ,jj+1,jk), & + & p_e3(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk), & + & p_e3(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk), & + & p_e3(ji ,jj+2,jk) * zmask(ji ,jj+2,jk), & + & p_e3(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk), & + & p_e3(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) ) + + p_e3_max_crs(ii,ij,jk) = ze3crs + ENDDO + ENDDO + ENDDO + + CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) + ! + ! + END SUBROUTINE crs_dom_e3 + + SUBROUTINE crs_dom_sfc( p_mask, cd_type, p_surf_crs, p_surf_crs_msk, p_e1, p_e2, p_e3 ) + + !! Arguments + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_mask ! Parent grid T mask + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in), OPTIONAL :: p_e1, p_e2 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in), OPTIONAL :: p_e3 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs_msk ! Coarse grid box east or north face quantity + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ii, ij, je_2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsurf, zsurfmsk + !!---------------------------------------------------------------- + ! Initialize + + ! + SELECT CASE ( cd_type ) + + CASE ('W') + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) + ENDDO + zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) + DO jk = 2, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) + ENDDO + + CASE ('V') + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk) + ENDDO + DO jk = 1, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) + ENDDO + + CASE ('U') + DO jk = 1, jpk + zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk) + ENDDO + DO jk = 1, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) + ENDDO + + CASE DEFAULT + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) + ENDDO + DO jk = 1, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) + ENDDO + END SELECT + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ! + p_surf_crs (ii,2,jk) = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & + & + zsurf(ji,je_2-1,jk) + zsurf(ji+1,je_2-1,jk) + zsurf(ji+2,je_2-1,jk) ! Why ????? + ! + p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk) + ! + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ! + p_surf_crs (ii,2,jk) = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & + & + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & + & + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) + + p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2 ,jk) + zsurfmsk(ji+1,je_2 ,jk) + zsurfmsk(ji+2,je_2 ,jk) & + & + zsurfmsk(ji,je_2+1,jk) + zsurfmsk(ji+1,je_2+1,jk) + zsurfmsk(ji+2,je_2+1,jk) & + & + zsurfmsk(ji,je_2+2,jk) + zsurfmsk(ji+1,je_2+2,jk) + zsurfmsk(ji+2,je_2+2,jk) + ENDDO + ENDDO + ENDIF + + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ! + p_surf_crs (ii,ij,jk) = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & + & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & + & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) + + p_surf_crs_msk(ii,ij,jk) = zsurfmsk(ji,jj ,jk) + zsurfmsk(ji+1,jj ,jk) + zsurfmsk(ji+2,jj ,jk) & + & + zsurfmsk(ji,jj+1,jk) + zsurfmsk(ji+1,jj+1,jk) + zsurfmsk(ji+2,jj+1,jk) & + & + zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) + ENDDO + ENDDO + ENDDO + + CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0_wp, pfillval=1.0_wp ) + + END SUBROUTINE crs_dom_sfc + + SUBROUTINE crs_dom_def + !!---------------------------------------------------------------- + !! *** SUBROUTINE crs_dom_def *** + !! ** Purpose : Three applications. + !! 1) Define global domain indice of the croasening grid + !! 2) Define local domain indice of the croasening grid + !! 3) Define the processor domain indice for a croasening grid + !!---------------------------------------------------------------- + !! + !! local variables + + INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn ! dummy indices + INTEGER :: ierr ! allocation error status + + +!!$ ! 1.a. Define global domain indices : take into account the interior domain only ( removes i/j=1 , i/j=jpiglo/jpjglo ) then add 2/3 grid points +!!$ jpiglo_crs = INT( (jpiglo - 2) / nn_factx ) + 2 +!!$ ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj +!!$ ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 3 +!!$ jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 3 +!!$ jpiglo_crsm1 = jpiglo_crs - 1 +!!$ jpjglo_crsm1 = jpjglo_crs - 1 +!!$ +!!$ jpi_crs = ( jpiglo_crs - 2 * nn_hls + (jpni-1) ) / jpni + 2 * nn_hls +!!$ jpj_crs = ( jpjglo_crsm1 - 2 * nn_hls + (jpnj-1) ) / jpnj + 2 * nn_hls +!!$ +!!$ IF( noso < 0 ) jpj_crs = jpj_crs + 1 ! add a local band on southern processors +!!$ +!!$ jpi_crsm1 = jpi_crs - 1 +!!$ jpj_crsm1 = jpj_crs - 1 +!!$ nperio_crs = jperio +!!$ npolj_crs = npolj +!!$ +!!$ ierr = crs_dom_alloc() ! allocate most coarse grid arrays +!!$ +!!$ ! 2.a Define processor domain +!!$ IF( .NOT. lk_mpp ) THEN +!!$ nimpp_crs = 1 +!!$ njmpp_crs = 1 +!!$ Nis0_crs = 1 +!!$ Njs0_crs = 1 +!!$ Nie0_crs = jpi_crs +!!$ Nje0_crs = jpj_crs +!!$ ELSE +!!$ ! Initialisation of most local variables - +!!$ nimpp_crs = 1 +!!$ njmpp_crs = 1 +!!$ Nis0_crs = 1 +!!$ Njs0_crs = 1 +!!$ Nie0_crs = jpi_crs +!!$ Nje0_crs = jpj_crs +!!$ +!!$ ! Calculs suivant une découpage en j +!!$ DO jn = 1, jpnij, jpni +!!$ IF( jn < ( jpnij - jpni + 1 ) ) THEN +!!$ nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) & +!!$ & - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) ) +!!$ ELSE +!!$ nje0all_crs(jn) = AINT( REAL( nje0all(jn) / nn_facty, wp ) ) + 1 +!!$ ENDIF +!!$ IF( noso < 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 +!!$ SELECT CASE( ibonjt(jn) ) +!!$ CASE ( -1 ) +!!$ IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 +!!$ jpjall_crs (jn) = nje0all_crs(jn) + nn_hls +!!$ njs0all_crs(jn) = njs0all(jn) +!!$ +!!$ CASE ( 0 ) +!!$ +!!$ njs0all_crs(jn) = njs0all(jn) +!!$ IF( njs0all(jn) == 1 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 +!!$ nje0all_crs(jn) = nje0all_crs(jn) + nn_hls +!!$ jpjall_crs (jn) = nje0all_crs(jn) + nn_hls +!!$ +!!$ CASE ( 1, 2 ) +!!$ +!!$ nje0all_crs(jn) = nje0all_crs(jn) + nn_hls +!!$ jpjall_crs (jn) = nje0all_crs(jn) +!!$ njs0all_crs(jn) = njs0all(jn) +!!$ +!!$ CASE DEFAULT +!!$ CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' ) +!!$ END SELECT +!!$ IF( jpjall_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 1 +!!$ +!!$ IF(njs0all_crs(jn) == 1 ) THEN +!!$ njmppt_crs(jn) = 1 +!!$ ELSE +!!$ njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) ) +!!$ ENDIF +!!$ +!!$ DO jj = jn + 1, jn + jpni - 1 +!!$ nje0all_crs(jj) = nje0all_crs(jn) +!!$ jpjall_crs (jj) = jpjall_crs(jn) +!!$ njs0all_crs(jj) = njs0all_crs(jn) +!!$ njmppt_crs (jj) = njmppt_crs(jn) +!!$ ENDDO +!!$ ENDDO +!!$ Nje0_crs = nje0all_crs(narea) +!!$ jpj_crs = jpjall_crs (narea) +!!$ Njs0_crs = njs0all_crs(narea) +!!$ njmpp_crs = njmppt_crs (narea) +!!$ +!!$ ! Calcul suivant un decoupage en i +!!$ DO jn = 1, jpni +!!$ IF( jn == 1 ) THEN +!!$ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) +!!$ ELSE +!!$ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) & +!!$ & - AINT( REAL( ( nimppt(jn-1) - 1 + jpiall(jn-1) ) / nn_factx, wp) ) +!!$ ENDIF +!!$ +!!$ SELECT CASE( ibonit(jn) ) +!!$ CASE ( -1 ) +!!$ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls +!!$ jpiall_crs (jn) = nie0all_crs(jn) + nn_hls +!!$ nis0all_crs(jn) = nis0all(jn) +!!$ +!!$ CASE ( 0 ) +!!$ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls +!!$ jpiall_crs (jn) = nie0all_crs(jn) + nn_hls +!!$ nis0all_crs(jn) = nis0all(jn) +!!$ +!!$ CASE ( 1, 2 ) +!!$ IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 ) nie0all_crs(jn) = nie0all_crs(jn) + 1 +!!$ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls +!!$ jpiall_crs (jn) = nie0all_crs(jn) +!!$ nis0all_crs(jn) = nis0all(jn) +!!$ +!!$ CASE DEFAULT +!!$ CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' ) +!!$ END SELECT +!!$ +!!$ nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1 +!!$ DO jj = jn + jpni , jpnij, jpni +!!$ nie0all_crs(jj) = nie0all_crs(jn) +!!$ jpiall_crs (jj) = jpiall_crs (jn) +!!$ nis0all_crs(jj) = nis0all_crs(jn) +!!$ nimppt_crs (jj) = nimppt_crs (jn) +!!$ ENDDO +!!$ ENDDO +!!$ +!!$ Nie0_crs = nie0all_crs(narea) +!!$ jpi_crs = jpiall_crs (narea) +!!$ Nis0_crs = nis0all_crs(narea) +!!$ nimpp_crs = nimppt_crs (narea) +!!$ +!!$ DO ji = 1, jpi_crs +!!$ mig_crs(ji) = ji + nimpp_crs - 1 +!!$ ENDDO +!!$ DO jj = 1, jpj_crs +!!$ mjg_crs(jj) = jj + njmpp_crs - 1! +!!$ ENDDO +!!$ +!!$ DO ji = 1, jpiglo_crs +!!$ mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) ) +!!$ mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) ) +!!$ ENDDO +!!$ +!!$ DO jj = 1, jpjglo_crs +!!$ mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) +!!$ mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) ) +!!$ ENDDO +!!$ +!!$ ENDIF +!!$ +!!$ ! Save the parent grid information +!!$ jpi_full = jpi +!!$ jpj_full = jpj +!!$ jpim1_full = jpim1 +!!$ jpjm1_full = jpjm1 +!!$ nperio_full = jperio +!!$ +!!$ npolj_full = npolj +!!$ jpiglo_full = jpiglo +!!$ jpjglo_full = jpjglo +!!$ +!!$ jpj_full = jpj +!!$ jpi_full = jpi +!!$ Nis0_full = Nis0 +!!$ Njs0_full = Njs0 +!!$ Nie0_full = Nie0 +!!$ Nje0_full = Nje0 +!!$ nimpp_full = nimpp +!!$ njmpp_full = njmpp +!!$ +!!$ jpiall_full (:) = jpiall (:) +!!$ nis0all_full(:) = nis0all(:) +!!$ nie0all_full(:) = nie0all(:) +!!$ nimppt_full (:) = nimppt (:) +!!$ jpjall_full (:) = jpjall (:) +!!$ njs0all_full(:) = njs0all(:) +!!$ nje0all_full(:) = nje0all(:) +!!$ njmppt_full (:) = njmppt (:) + + CALL dom_grid_crs !swich de grille + + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'crs_init : coarse grid dimensions' + WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo = ', jpjglo + WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo = ', jpiglo + WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi = ', jpi + WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj = ', jpj + WRITE(numout,*) + WRITE(numout,*) ' narea = ' , narea + WRITE(numout,*) ' jpi = ' , jpi + WRITE(numout,*) ' jpj = ' , jpj + WRITE(numout,*) ' Nis0 = ' , Nis0 + WRITE(numout,*) ' Njs0 = ' , Njs0 + WRITE(numout,*) ' Nie0 = ' , Nie0 + WRITE(numout,*) ' Nje0 = ' , Nje0 + WRITE(numout,*) ' Nie0_full=' , Nie0_full + WRITE(numout,*) ' Nis0_full=' , Nis0_full + WRITE(numout,*) ' nimpp = ' , nimpp + WRITE(numout,*) ' njmpp = ' , njmpp + WRITE(numout,*) ' njmpp_full = ', njmpp_full + WRITE(numout,*) + ENDIF + + CALL dom_grid_glo + + mxbinctr = INT( nn_factx * 0.5 ) + mybinctr = INT( nn_facty * 0.5 ) + + nrestx = MOD( nn_factx, 2 ) ! check if even- or odd- numbered reduction factor + nresty = MOD( nn_facty, 2 ) + + IF ( nrestx == 0 ) THEN + mxbinctr = mxbinctr - 1 + ENDIF + + IF ( nresty == 0 ) THEN + mybinctr = mybinctr - 1 +!!$ IF ( jperio == 3 .OR. jperio == 4 ) nperio_crs = jperio + 2 +!!$ IF ( jperio == 5 .OR. jperio == 6 ) nperio_crs = jperio - 2 +!!$ +!!$ IF ( npolj == 3 ) npolj_crs = 5 +!!$ IF ( npolj == 5 ) npolj_crs = 3 + ENDIF + + rfactxy = nn_factx * nn_facty + + ! 2.b. Set up bins for coarse grid, horizontal only. + ierr = crs_dom_alloc2() + + mis2_crs(:) = 0 ; mie2_crs(:) = 0 + mjs2_crs(:) = 0 ; mje2_crs(:) = 0 + + + SELECT CASE ( nn_binref ) + + CASE ( 0 ) + +!!$ SELECT CASE ( jperio ) +!!$ +!!$ +!!$ CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold +!!$ +!!$ DO ji = 2, jpiglo_crsm1 +!!$ ijie = ( ji * nn_factx ) - nn_factx !cc +!!$ ijis = ijie - nn_factx + 1 +!!$ mis2_crs(ji) = ijis +!!$ mie2_crs(ji) = ijie +!!$ ENDDO +!!$ IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 2 +!!$ +!!$ ! Handle first the northernmost bin +!!$ IF ( nn_facty == 2 ) THEN ; ijjgloT = jpjglo - 1 +!!$ ELSE ; ijjgloT = jpjglo +!!$ ENDIF +!!$ +!!$ DO jj = 2, jpjglo_crs +!!$ ijje = ijjgloT - nn_facty * ( jj - 3 ) +!!$ ijjs = ijje - nn_facty + 1 +!!$ mjs2_crs(jpjglo_crs-jj+2) = ijjs +!!$ mje2_crs(jpjglo_crs-jj+2) = ijje +!!$ ENDDO +!!$ +!!$ CASE ( 2 ) +!!$ WRITE(numout,*) 'crs_init, jperio=2 not supported' +!!$ +!!$ CASE ( 5, 6 ) ! F-pivot at North Fold +!!$ +!!$ DO ji = 2, jpiglo_crsm1 +!!$ ijie = ( ji * nn_factx ) - nn_factx +!!$ ijis = ijie - nn_factx + 1 +!!$ mis2_crs(ji) = ijis +!!$ mie2_crs(ji) = ijie +!!$ ENDDO +!!$ IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo - 2 +!!$ +!!$ ! Treat the northernmost bin separately. +!!$ jj = 2 +!!$ ijje = jpj - nn_facty * ( jj - 2 ) +!!$ IF ( nn_facty == 3 ) THEN ; ijjs = ijje - 1 +!!$ ELSE ; ijjs = ijje - nn_facty + 1 +!!$ ENDIF +!!$ mjs2_crs(jpj_crs-jj+1) = ijjs +!!$ mje2_crs(jpj_crs-jj+1) = ijje +!!$ +!!$ ! Now bin the rest, any remainder at the south is lumped in the southern bin +!!$ DO jj = 3, jpjglo_crsm1 +!!$ ijje = jpjglo - nn_facty * ( jj - 2 ) +!!$ ijjs = ijje - nn_facty + 1 +!!$ IF ( ijjs <= nn_facty ) ijjs = 2 +!!$ mjs2_crs(jpj_crs-jj+1) = ijjs +!!$ mje2_crs(jpj_crs-jj+1) = ijje +!!$ ENDDO +!!$ +!!$ CASE DEFAULT +!!$ WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported' +!!$ +!!$ END SELECT + + CASE (1 ) + WRITE(numout,*) 'crs_init. Equator-centered bins option not yet available' + + END SELECT + + ! Pad the boundaries, do not know if it is necessary + mis2_crs(2) = 1 ; mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 1 + mie2_crs(2) = nn_factx ; mie2_crs(jpiglo_crs) = jpiglo + ! + mjs2_crs(1) = 1 + mje2_crs(1) = 1 + ! + mje2_crs(2) = mjs2_crs(3)-1 ; mje2_crs(jpjglo_crs) = jpjglo + mjs2_crs(2) = 1 ; mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 1 + + IF( .NOT. lk_mpp ) THEN + mis_crs(:) = mis2_crs(:) + mie_crs(:) = mie2_crs(:) + mjs_crs(:) = mjs2_crs(:) + mje_crs(:) = mje2_crs(:) + ELSE + DO jj = 1, Nje0_crs + mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1 + mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1 + ENDDO + DO ji = 1, Nie0_crs + mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1 + mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1 + ENDDO + ENDIF + ! + nistr = mis_crs(2) ; niend = mis_crs(jpi_crs - 1) + njstr = mjs_crs(3) ; njend = mjs_crs(jpj_crs - 1) + ! + END SUBROUTINE crs_dom_def + + SUBROUTINE crs_dom_bat + !!---------------------------------------------------------------- + !! *** SUBROUTINE crs_dom_bat *** + !! ** Purpose : coarsenig bathy + !!---------------------------------------------------------------- + !! + !! local variables + INTEGER :: ji,jj,jk ! dummy indices + REAL(wp), DIMENSION(jpi_crs, jpj_crs) :: zmbk + !!---------------------------------------------------------------- + + mbathy_crs(:,:) = jpkm1 + mbkt_crs(:,:) = 1 + mbku_crs(:,:) = 1 + mbkv_crs(:,:) = 1 + + + DO jj = 1, jpj_crs + DO ji = 1, jpi_crs + jk = 0 + DO WHILE( tmask_crs(ji,jj,jk+1) > 0.) + jk = jk + 1 + ENDDO + mbathy_crs(ji,jj) = float( jk ) + ENDDO + ENDDO + + zmbk(:,:) = 0.0 + zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0_wp) ; mbathy_crs(:,:) = NINT( zmbk(:,:) ) + + + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~' + ! + mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 ) ! bottom k-index of T-level (=1 over land) + ! ! bottom k-index of W-level = mbkt+1 + + DO jj = 1, jpj_crsm1 ! bottom k-index of u- (v-) level + DO ji = 1, jpi_crsm1 + mbku_crs(ji,jj) = MIN( mbkt_crs(ji+1,jj ) , mbkt_crs(ji,jj) ) + mbkv_crs(ji,jj) = MIN( mbkt_crs(ji ,jj+1) , mbkt_crs(ji,jj) ) + END DO + END DO + + ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk + zmbk(:,:) = 1.e0; + zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0_wp) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) + zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0_wp) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) + ! + END SUBROUTINE crs_dom_bat + + +END MODULE crsdom diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsdomwri.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsdomwri.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7870d3bb2af51d2b9d9e919fed2e992576c80b20 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsdomwri.f90 @@ -0,0 +1,216 @@ + + + + + + + + + + + + + +MODULE crsdomwri + !!====================================================================== + !! Coarse Ocean initialization : write the coarse ocean domain mesh and mask files + !!====================================================================== + !! History : 3.6 ! 2012-06 (J. Simeon, C. Calone, C Ethe ) from domwri, reduced and modified for coarse grid + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! crs_dom_wri : create and write mesh and mask file(s) + !!---------------------------------------------------------------------- + USE timing ! Timing + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + USE par_kind, ONLY: wp + USE lib_mpp ! MPP library + USE iom_def + USE iom + USE crs ! coarse grid domain + USE crsdom ! coarse grid domain + USE crslbclnk ! crs mediator to lbclnk + + IMPLICIT NONE + PRIVATE + + PUBLIC crs_dom_wri ! routine called by crsini.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crsdomwri.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_dom_wri + !!---------------------------------------------------------------------- + !! *** ROUTINE crs_dom_wri *** + !! + !! ** Purpose : Create the NetCDF file(s) which contain(s) all the + !! ocean domain informations (mesh and mask arrays). This (these) + !! file(s) is (are) used for visualisation (SAXO software) and + !! diagnostic computation. + !! + !! ** Method : Write in a file all the arrays generated in routines + !! crsini for meshes and mask. In three separate files: + !! domain size, horizontal grid-point position, + !! masks, depth and vertical scale factors + !! + !! ** Output files : mesh_hgr_crs.nc, mesh_zgr_crs.nc, mesh_mask.nc + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inum ! local units for 'mesh_mask.nc' file + CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) + ! ! workspace + REAL(wp), DIMENSION(jpi_crs,jpj_crs ) :: zprt, zprw + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk) :: zdepu, zdepv + !!---------------------------------------------------------------------- + ! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'crs_dom_wri : create NetCDF mesh and mask file' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + + clnam = 'mesh_mask_crs' ! filename (mesh and mask informations) + + + ! ! ============================ + ! ! create 'mesh_mask.nc' file + ! ! ============================ + ! + CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) + + CALL iom_rstput( 0, 0, inum, 'tmask', tmask_crs, ktype = jp_i1 ) ! land-sea mask + CALL iom_rstput( 0, 0, inum, 'umask', umask_crs, ktype = jp_i1 ) + CALL iom_rstput( 0, 0, inum, 'vmask', vmask_crs, ktype = jp_i1 ) + CALL iom_rstput( 0, 0, inum, 'fmask', fmask_crs, ktype = jp_i1 ) + + CALL dom_uniq_crs( zprw, 'T' ) + zprt = tmask_crs(:,:,1) * zprw + CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq_crs( zprw, 'U' ) + zprt = umask_crs(:,:,1) * zprw + CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq_crs( zprw, 'V' ) + zprt = vmask_crs(:,:,1) * zprw + CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq_crs( zprw, 'F' ) + zprt = fmask_crs(:,:,1) * zprw + CALL iom_rstput( 0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1 ) + !======================================================== + ! ! horizontal mesh + CALL iom_rstput( 0, 0, inum, 'glamt', glamt_crs, ktype = jp_r4 ) ! ! latitude + CALL iom_rstput( 0, 0, inum, 'glamu', glamu_crs, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'glamv', glamv_crs, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'glamf', glamf_crs, ktype = jp_r4 ) + + CALL iom_rstput( 0, 0, inum, 'gphit', gphit_crs, ktype = jp_r4 ) ! ! longitude + CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu_crs, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv_crs, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'gphif', gphif_crs, ktype = jp_r4 ) + + CALL iom_rstput( 0, 0, inum, 'e1t', e1t_crs, ktype = jp_r8 ) ! ! e1 scale factors + CALL iom_rstput( 0, 0, inum, 'e1u', e1u_crs, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e1v', e1v_crs, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e1f', e1f_crs, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum, 'e2t', e2t_crs, ktype = jp_r8 ) ! ! e2 scale factors + CALL iom_rstput( 0, 0, inum, 'e2u', e2u_crs, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e2v', e2v_crs, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e2f', e2f_crs, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum, 'ff', ff_crs, ktype = jp_r8 ) ! ! coriolis factor + + !======================================================== + ! ! vertical mesh +! ! note that mbkt is set to 1 over land ==> use surface tmask_crs + zprt(:,:) = tmask_crs(:,:,1) * REAL( mbkt_crs(:,:) , wp ) + CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i2 ) ! ! nb of ocean T-points + ! + CALL iom_rstput( 0, 0, inum, 'e3t', e3t_crs ) + CALL iom_rstput( 0, 0, inum, 'e3w', e3w_crs ) + CALL iom_rstput( 0, 0, inum, 'e3u', e3u_crs ) + CALL iom_rstput( 0, 0, inum, 'e3v', e3v_crs ) + ! + CALL iom_rstput( 0, 0, inum, 'gdept', gdept_crs, ktype = jp_r4 ) + DO jk = 1,jpk + DO jj = 1, jpj_crsm1 + DO ji = 1, jpi_crsm1 ! jes what to do for jpim1??vector opt. + zdepu(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji+1,jj ,jk) ) * umask_crs(ji,jj,jk) + zdepv(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji ,jj+1,jk) ) * vmask_crs(ji,jj,jk) + END DO + END DO + END DO + CALL crs_lbc_lnk( zdepu,'U', 1.0_wp ) ; CALL crs_lbc_lnk( zdepv,'V', 1.0_wp ) + ! + CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'gdepv', zdepv, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'gdepw', gdepw_crs, ktype = jp_r4 ) + ! + CALL iom_rstput( 0, 0, inum, 'gdept_1d', gdept_1d ) ! ! reference z-coord. + CALL iom_rstput( 0, 0, inum, 'gdepw_1d', gdepw_1d ) + CALL iom_rstput( 0, 0, inum, 'e3t_1d' , e3t_1d ) + CALL iom_rstput( 0, 0, inum, 'e3w_1d' , e3w_1d ) + ! + CALL iom_rstput( 0, 0, inum, 'ocean_volume_t', ocean_volume_crs_t ) + CALL iom_rstput( 0, 0, inum, 'facvol_t' , facvol_t ) + CALL iom_rstput( 0, 0, inum, 'facvol_w' , facvol_w ) + CALL iom_rstput( 0, 0, inum, 'facsurfu' , facsurfu ) + CALL iom_rstput( 0, 0, inum, 'facsurfv' , facsurfv ) + CALL iom_rstput( 0, 0, inum, 'e1e2w_msk', e1e2w_msk ) + CALL iom_rstput( 0, 0, inum, 'e2e3u_msk', e2e3u_msk ) + CALL iom_rstput( 0, 0, inum, 'e1e3v_msk', e1e3v_msk ) + CALL iom_rstput( 0, 0, inum, 'e1e2w' , e1e2w_crs ) + CALL iom_rstput( 0, 0, inum, 'e2e3u' , e2e3u_crs ) + CALL iom_rstput( 0, 0, inum, 'e1e3v' , e1e3v_crs ) + CALL iom_rstput( 0, 0, inum, 'bt' , bt_crs ) + CALL iom_rstput( 0, 0, inum, 'r1_bt' , r1_bt_crs ) + ! + CALL iom_rstput( 0, 0, inum, 'crs_surfu_wgt', crs_surfu_wgt ) + CALL iom_rstput( 0, 0, inum, 'crs_surfv_wgt', crs_surfv_wgt ) + CALL iom_rstput( 0, 0, inum, 'crs_volt_wgt' , crs_volt_wgt ) + ! ! ============================ + ! ! close the files + ! ! ============================ + CALL iom_close( inum ) + ! + END SUBROUTINE crs_dom_wri + + + SUBROUTINE dom_uniq_crs( puniq, cdgrd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE crs_dom_uniq_crs *** + !! + !! ** Purpose : identify unique point of a grid (TUVF) + !! + !! ** Method : 1) apply crs_lbc_lnk on an array with different values for each element + !! 2) check which elements have been changed + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cdgrd ! + REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq ! + ! + REAL(wp) :: zshift ! shift value link to the process number + INTEGER :: ji ! dummy loop indices + LOGICAL , DIMENSION(jpi_crs,jpj_crs,1) :: lluniq ! store whether each point is unique or not + REAL(wp), DIMENSION(jpi_crs,jpj_crs ) :: ztstref + !!---------------------------------------------------------------------- + ! + ! build an array with different values for each element + ! in mpp: make sure that these values are different even between process + ! -> apply a shift value according to the process number + zshift = (jpi_crs+1.) * (jpj_crs+1.) * ( narea - 1 ) ! we should use jpimax_crs but not existing + ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi_crs*jpj_crs) /), (/ jpi_crs, jpj_crs /) ) + ! + puniq(:,:) = ztstref(:,:) ! default definition + CALL crs_lbc_lnk( puniq,cdgrd, 1.0_wp ) ! apply boundary conditions + lluniq(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed + ! + puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp ) + ! + END SUBROUTINE dom_uniq_crs + + !!====================================================================== + +END MODULE crsdomwri diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsfld.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsfld.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6055357f3fe0651c4a6c442d0a3e661fb36cf453 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsfld.f90 @@ -0,0 +1,271 @@ + + + + + + + + + + + + + +MODULE crsfld + !!====================================================================== + !! *** MODULE crsdfld *** + !! Ocean coarsening : coarse ocean fields + !!===================================================================== + !! 2012-07 (J. Simeon, C. Calone, G. Madec, C. Ethe) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! crs_fld : create the standard output files for coarse grid and prep + !! other variables needed to be passed to TOP + !!---------------------------------------------------------------------- + USE crs + USE crsdom + USE crslbclnk + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE zdf_oce ! vertical physics: ocean fields + USE ldftra ! ocean active tracers: lateral diffusivity & EIV coefficients + USE zdfddm ! vertical physics: double diffusion + ! + USE in_out_manager ! I/O manager + USE iom ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC crs_fld ! routines called by step.F90 + + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crsfld.F90 13472 2020-09-16 13:05:19Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_fld( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE crs_fld *** + !! + !! ** Purpose : Basic output of coarsened dynamics and tracer fields + !! NETCDF format is used by default + !! 1. Accumulate in time the dimensionally-weighted fields + !! 2. At time of output, rescale [1] by dimension and time + !! to yield the spatial and temporal average. + !! See. sbcmod.F90 + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: z2dcrsu, z2dcrsv ! local scalars + REAL(wp) :: zztmp ! - - + ! + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, ze3w ! 3D workspace for e3 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zt , zs , z3d + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk) :: zt_crs, zs_crs + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('crs_fld') + + ! Depth work arrrays + DO jk = 1 , jpk + ze3t(:,:,jk) = (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + ze3u(:,:,jk) = (e3u_0(:,:,jk)*(1._wp+r3u(:,:,Kmm)*umask(:,:,jk))) + ze3v(:,:,jk) = (e3v_0(:,:,jk)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,jk))) + ze3w(:,:,jk) = (e3w_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) + END DO + + IF( kt == nit000 ) THEN + tsn_crs (:,:,:,:) = 0._wp ! temp/sal array, now + un_crs (:,:,: ) = 0._wp ! u-velocity + vn_crs (:,:,: ) = 0._wp ! v-velocity + wn_crs (:,:,: ) = 0._wp ! w + avs_crs (:,:,: ) = 0._wp ! avt + hdivn_crs(:,:,: ) = 0._wp ! hdiv + sshn_crs (:,: ) = 0._wp ! ssh + utau_crs (:,: ) = 0._wp ! taux + vtau_crs (:,: ) = 0._wp ! tauy + wndm_crs (:,: ) = 0._wp ! wind speed + qsr_crs (:,: ) = 0._wp ! qsr + emp_crs (:,: ) = 0._wp ! emp + emp_b_crs(:,: ) = 0._wp ! emp + rnf_crs (:,: ) = 0._wp ! runoff + fr_i_crs (:,: ) = 0._wp ! ice cover + ENDIF + + CALL iom_swap( "nemo_crs" ) ! swap on the coarse grid + + ! 2. Coarsen fields at each time step + ! -------------------------------------------------------- + + ! Temperature + zt(:,:,:) = ts(:,:,:,jp_tem,Kmm) ; zt_crs(:,:,:) = 0._wp + CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) + tsn_crs(:,:,:,jp_tem) = zt_crs(:,:,:) + + CALL iom_put( "toce", tsn_crs(:,:,:,jp_tem) ) ! temp + CALL iom_put( "sst" , tsn_crs(:,:,1,jp_tem) ) ! sst + + + ! Salinity + zs(:,:,:) = ts(:,:,:,jp_sal,Kmm) ; zs_crs(:,:,:) = 0._wp + CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) + tsn_crs(:,:,:,jp_sal) = zt_crs(:,:,:) + + CALL iom_put( "soce" , tsn_crs(:,:,:,jp_sal) ) ! sal + CALL iom_put( "sss" , tsn_crs(:,:,1,jp_sal) ) ! sss + + ! U-velocity + CALL crs_dom_ope( REAL(uu(:,:,:,Kmm),sp), 'SUM', 'U', umask, un_crs, p_e12=REAL(e2u,dp), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + ! + zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zt(ji,jj,jk) = uu(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) ) + zs(ji,jj,jk) = uu(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) ) + END DO ; END DO ; END DO + CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=REAL(e2u,dp), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=REAL(e2u,dp), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + + CALL iom_put( "uoce" , un_crs ) ! i-current + CALL iom_put( "uocet" , zt_crs ) ! uT + CALL iom_put( "uoces" , zs_crs ) ! uS + + ! V-velocity + CALL crs_dom_ope( REAL(vv(:,:,:,Kmm),sp), 'SUM', 'V', vmask, vn_crs, p_e12=REAL(e1v,dp), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + ! + zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zt(ji,jj,jk) = vv(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) ) + zs(ji,jj,jk) = vv(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) ) + END DO ; END DO ; END DO + CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=REAL(e1v,dp), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=REAL(e1v,dp), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + + CALL iom_put( "voce" , vn_crs ) ! i-current + CALL iom_put( "vocet" , zt_crs ) ! vT + CALL iom_put( "voces" , zs_crs ) ! vS + + IF( iom_use( "ke") ) THEN ! kinetic energy + z3d(:,:,jk) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zztmp = r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + z3d(ji,jj,jk) = 0.25_wp * zztmp * ( & + & uu(ji-1,jj,jk,Kmm)**2 * e2u(ji-1,jj) * (e3u_0(ji-1,jj,jk)*(1._wp+r3u(ji-1,jj,Kmm)*umask(ji-1,jj,jk))) & + & + uu(ji ,jj,jk,Kmm)**2 * e2u(ji ,jj) * (e3u_0(ji ,jj,jk)*(1._wp+r3u(ji ,jj,Kmm)*umask(ji ,jj,jk))) & + & + vv(ji,jj-1,jk,Kmm)**2 * e1v(ji,jj-1) * (e3v_0(ji,jj-1,jk)*(1._wp+r3v(ji,jj-1,Kmm)*vmask(ji,jj-1,jk))) & + & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * (e3v_0(ji,jj ,jk)*(1._wp+r3v(ji,jj ,Kmm)*vmask(ji,jj ,jk))) ) + END DO ; END DO ; END DO + CALL lbc_lnk( 'crsfld', z3d, 'T', 1.0_wp ) + ! + CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) + CALL iom_put( "ke", zt_crs ) + ENDIF + ! Horizontal divergence ( following OCE/DYN/divhor.F90 ) + DO jk = 1, jpkm1 + DO ji = 2, jpi_crsm1 + DO jj = 2, jpj_crsm1 + IF( tmask_crs(ji,jj,jk ) > 0 ) THEN + z2dcrsu = ( un_crs(ji ,jj ,jk) * crs_surfu_wgt(ji ,jj ,jk) ) & + & - ( un_crs(ji-1,jj ,jk) * crs_surfu_wgt(ji-1,jj ,jk) ) + z2dcrsv = ( vn_crs(ji ,jj ,jk) * crs_surfv_wgt(ji ,jj ,jk) ) & + & - ( vn_crs(ji ,jj-1,jk) * crs_surfv_wgt(ji ,jj-1,jk) ) + ! + hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / crs_volt_wgt(ji,jj,jk) + ENDIF + END DO + END DO + END DO + CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0_wp ) + ! + CALL iom_put( "hdiv", hdivn_crs ) + + + ! W-velocity + IF( ln_crs_wn ) THEN + CALL crs_dom_ope( ww, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0_wp ) + ! CALL crs_dom_ope( ww, 'VOL', 'W', tmask, wn_crs, p_e12=e1e2t, p_e3=ze3w ) + ELSE + wn_crs(:,:,jpk) = 0._wp + DO jk = jpkm1, 1, -1 + wn_crs(:,:,jk) = wn_crs(:,:,jk+1) - e3t_crs(:,:,jk) * hdivn_crs(:,:,jk) + ENDDO + ENDIF + CALL iom_put( "woce", wn_crs ) ! vertical velocity + ! free memory + + ! avs + SELECT CASE ( nn_crs_kz ) + CASE ( 0 ) + CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CASE ( 1 ) + CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CASE ( 2 ) + CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + END SELECT + ! + CALL iom_put( "avt", avt_crs ) ! Kz on T + CALL iom_put( "avs", avs_crs ) ! Kz on S + + ! sbc fields + CALL crs_dom_ope( REAL(ssh(:,:,Kmm),sp) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0_wp ) + CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=REAL(e2u,dp) , p_surf_crs=e2u_crs , psgn=1.0_wp ) + CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=REAL(e1v,dp) , p_surf_crs=e1v_crs , psgn=1.0_wp ) + CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( rnf , 'MAX', 'T', tmask, rnf_crs , psgn=1.0_wp ) + CALL crs_dom_ope( qsr , 'SUM', 'T', tmask, qsr_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( emp , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + + CALL iom_put( "ssh" , sshn_crs ) ! ssh output + CALL iom_put( "utau" , utau_crs ) ! i-tau output + CALL iom_put( "vtau" , vtau_crs ) ! j-tau output + CALL iom_put( "wspd" , wndm_crs ) ! wind speed output + CALL iom_put( "runoffs" , rnf_crs ) ! runoff output + CALL iom_put( "qsr" , qsr_crs ) ! qsr output + CALL iom_put( "empmr" , emp_crs ) ! water flux output + CALL iom_put( "saltflx" , sfx_crs ) ! salt flux output + CALL iom_put( "ice_cover", fr_i_crs ) ! ice cover output + + ! + CALL iom_swap( "nemo" ) ! return back on high-resolution grid + ! + IF( ln_timing ) CALL timing_stop('crs_fld') + ! + END SUBROUTINE crs_fld + + !!====================================================================== +END MODULE crsfld diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsini.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsini.f90 new file mode 100644 index 0000000000000000000000000000000000000000..23f9c5dd275e870d734da7c2c4f9e320f4c853be --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crsini.f90 @@ -0,0 +1,273 @@ + + + + + + + + + + + + + +MODULE crsini + !!====================================================================== + !! *** MODULE crsini *** + !! Manage the grid coarsening module initialization + !!====================================================================== + !! History 2012-05 (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! crs_init : + !!---------------------------------------------------------------------- + USE par_kind, ONLY: wp + USE par_oce ! For parameter jpi,jpj + USE dom_oce ! For parameters in par_oce + USE crs ! Coarse grid domain + USE phycst, ONLY: omega, rad ! physical constants + USE crsdom + USE crsdomwri + USE crslbclnk + ! + USE iom + USE in_out_manager + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC crs_init ! called by nemogcm.F90 module + + !! * Substitutions + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crsini.F90 13237 2020-07-03 09:12:53Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_init( Kmm ) + !!------------------------------------------------------------------- + !! *** SUBROUTINE crs_init + !! ** Purpose : Initialization of the grid coarsening module + !! 1. Read namelist + !! X2. MOVE TO crs_dom.F90 Set the domain definitions for coarse grid + !! a. Define the coarse grid starting/ending indices on parent grid + !! Here is where the T-pivot or F-pivot grids are discerned + !! b. TODO. Include option for north-centric or equator-centric binning. + !! (centered only for odd reduction factors; even reduction bins bias equator to the south) + !! 3. Mask and mesh creation. => calls to crsfun + !! a. Use crsfun_mask to generate tmask,umask, vmask, fmask. + !! b. Use crsfun_coordinates to get coordinates + !! c. Use crsfun_UV to get horizontal scale factors + !! d. Use crsfun_TW to get initial vertical scale factors + !! 4. Volumes and weights jes.... TODO. Updates for vvl? Where to do this? crsstp.F90? + !! a. Calculate initial coarse grid box volumes: pvol_T, pvol_W + !! b. Calculate initial coarse grid surface-averaging weights + !! c. Calculate initial coarse grid volume-averaging weights + !! + !! X5. MOVE TO crs_dom_wri.F90 Using iom_rstput output the initial meshmask. + !! ?. Another set of "masks" to generate + !! are the u- and v- surface areas for U- and V- area-weighted means. + !! Need to put this somewhere in section 3? + !! jes. What do to about the vvl? GM. could separate the weighting (denominator), so + !! output C*dA or C*dV as summation not mran, then do mean (division) at moment of output. + !! As is, crsfun takes into account vvl. + !! Talked about pre-setting the surface array to avoid IF/ENDIF and division. + !! But have then to make that preset array here and elsewhere. + !! that is called every timestep... + !! + !! - Read in pertinent data ? + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ji,jj,jk ! dummy indices + INTEGER :: ierr ! allocation error status + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, ze3w + + NAMELIST/namcrs/ nn_factx, nn_facty, nn_binref, ln_msh_crs, nn_crs_kz, ln_crs_wn + !!---------------------------------------------------------------------- + ! + !--------------------------------------------------------- + ! 1. Read Namelist file + !--------------------------------------------------------- + ! + READ ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in reference namelist' ) + READ ( numnam_cfg, namcrs, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcrs in configuration namelist' ) + IF(lwm) WRITE ( numond, namcrs ) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'crs_init : Initializing the grid coarsening module' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist namcrs ' + WRITE(numout,*) ' coarsening factor in i-direction nn_factx = ', nn_factx + WRITE(numout,*) ' coarsening factor in j-direction nn_facty = ', nn_facty + WRITE(numout,*) ' bin centering preference nn_binref = ', nn_binref + WRITE(numout,*) ' create a mesh file (=T) ln_msh_crs = ', ln_msh_crs + WRITE(numout,*) ' type of Kz coarsening (0,1,2) nn_crs_kz = ', nn_crs_kz + WRITE(numout,*) ' ww coarsened or computed using hdiv ln_crs_wn = ', ln_crs_wn + ENDIF + + rfactx_r = 1. / nn_factx + rfacty_r = 1. / nn_facty + + !--------------------------------------------------------- + ! 2. Define Global Dimensions of the coarsened grid + !--------------------------------------------------------- + CALL crs_dom_def + + !--------------------------------------------------------- + ! 3. Mask and Mesh + !--------------------------------------------------------- + + ! Set up the masks and meshes + + ! 3.a. Get the masks + + CALL crs_dom_msk + + + ! 3.b. Get the coordinates + ! Odd-numbered reduction factor, center coordinate on T-cell + ! Even-numbered reduction factor, center coordinate on U-,V- faces or f-corner. + ! + IF ( nresty /= 0 .AND. nrestx /= 0 ) THEN + CALL crs_dom_coordinates( gphit, glamt, 'T', gphit_crs, glamt_crs ) + CALL crs_dom_coordinates( gphiu, glamu, 'U', gphiu_crs, glamu_crs ) + CALL crs_dom_coordinates( gphiv, glamv, 'V', gphiv_crs, glamv_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) + ELSEIF ( nresty /= 0 .AND. nrestx == 0 ) THEN + CALL crs_dom_coordinates( gphiu, glamu, 'T', gphit_crs, glamt_crs ) + CALL crs_dom_coordinates( gphiu, glamu, 'U', gphiu_crs, glamu_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) + ELSEIF ( nresty == 0 .AND. nrestx /= 0 ) THEN + CALL crs_dom_coordinates( gphiv, glamv, 'T', gphit_crs, glamt_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs ) + CALL crs_dom_coordinates( gphiv, glamv, 'V', gphiv_crs, glamv_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) + ELSE + CALL crs_dom_coordinates( gphif, glamf, 'T', gphit_crs, glamt_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) + ENDIF + + + ! 3.c. Get the horizontal mesh + + ! 3.c.1 Horizontal scale factors + + CALL crs_dom_hgr( e1t, e2t, 'T', e1t_crs, e2t_crs ) + CALL crs_dom_hgr( e1u, REAL(e2u,dp), 'U', e1u_crs, e2u_crs ) + CALL crs_dom_hgr( REAL(e1v,dp), e2v, 'V', e1v_crs, e2v_crs ) + CALL crs_dom_hgr( e1f, e2f, 'F', e1f_crs, e2f_crs ) + + e1e2t_crs(:,:) = e1t_crs(:,:) * e2t_crs(:,:) + + + ! 3.c.2 Coriolis factor + +!!gm Not sure CRS needs Coriolis parameter.... +!!gm If needed, then update this to have Coriolis at both f- and t-points + + ff_crs(:,:) = 2. * omega * SIN( rad * gphif_crs(:,:) ) + + CALL ctl_warn( 'crsini: CAUTION, CRS only designed for Coriolis defined on the sphere' ) + + + ! 3.d.1 mbathy ( vertical k-levels of bathymetry ) + + CALL crs_dom_bat + + ! + DO jk = 1, jpk + ze3t(:,:,jk) = (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + ze3u(:,:,jk) = (e3u_0(:,:,jk)*(1._wp+r3u(:,:,Kmm)*umask(:,:,jk))) + ze3v(:,:,jk) = (e3v_0(:,:,jk)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,jk))) + ze3w(:,:,jk) = (e3w_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) + END DO + + ! 3.d.2 Surfaces + CALL crs_dom_sfc( tmask, 'W', e1e2w_crs, e1e2w_msk, p_e1=REAL(e1t,sp), p_e2=REAL(e2t,sp) ) + CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=ze3u ) + CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=ze3v ) + + facsurfu(:,:,:) = umask_crs(:,:,:) * e2e3u_msk(:,:,:) / e2e3u_crs(:,:,:) + facsurfv(:,:,:) = vmask_crs(:,:,:) * e1e3v_msk(:,:,:) / e1e3v_crs(:,:,:) + + ! 3.d.3 Vertical scale factors + ! + CALL crs_dom_e3( e1t, e2t, ze3t, e1e2w_crs, 'T', tmask, e3t_crs, e3t_max_crs) + CALL crs_dom_e3( e1u, REAL(e2u,dp), ze3u, e2e3u_crs, 'U', umask, e3u_crs, e3u_max_crs) + CALL crs_dom_e3( REAL(e1v,dp), e2v, ze3v, e1e3v_crs, 'V', vmask, e3v_crs, e3v_max_crs) + CALL crs_dom_e3( e1t, e2t, ze3w, e1e2w_crs, 'W', tmask, e3w_crs, e3w_max_crs) + + ! Replace 0 by e3t_0 or e3w_0 + DO jk = 1, jpk + DO ji = 1, jpi_crs + DO jj = 1, jpj_crs + IF( e3t_crs(ji,jj,jk) == 0._wp ) e3t_crs(ji,jj,jk) = e3t_1d(jk) + IF( e3w_crs(ji,jj,jk) == 0._wp ) e3w_crs(ji,jj,jk) = e3w_1d(jk) + IF( e3u_crs(ji,jj,jk) == 0._wp ) e3u_crs(ji,jj,jk) = e3t_1d(jk) + IF( e3v_crs(ji,jj,jk) == 0._wp ) e3v_crs(ji,jj,jk) = e3t_1d(jk) + ENDDO + ENDDO + ENDDO + + ! 3.d.3 Vertical depth (meters) + CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0_wp ) + CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0_wp ) + + + !--------------------------------------------------------- + ! 4. Coarse grid ocean volume and averaging weights + !--------------------------------------------------------- + ! 4.a. Ocean volume or area unmasked and masked + CALL crs_dom_facvol( tmask, 'T', e1t, e2t, ze3t, ocean_volume_crs_t, facvol_t ) + ! + bt_crs(:,:,:) = ocean_volume_crs_t(:,:,:) * facvol_t(:,:,:) + ! + r1_bt_crs(:,:,:) = 0._wp + WHERE( bt_crs /= 0._wp ) r1_bt_crs(:,:,:) = 1._wp / bt_crs(:,:,:) + + CALL crs_dom_facvol( tmask, 'W', e1t, e2t, ze3w, ocean_volume_crs_w, facvol_w ) + ! + !--------------------------------------------------------- + ! 5. Write out coarse meshmask (see OCE/DOM/domwri.F90 for ideas later) + !--------------------------------------------------------- + + IF( ln_msh_crs ) THEN + CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain + CALL crs_dom_wri + CALL dom_grid_glo ! Return to parent grid domain + ENDIF + + !--------------------------------------------------------- + ! 7. Finish and clean-up + !--------------------------------------------------------- + ! + END SUBROUTINE crs_init + + !!====================================================================== +END MODULE crsini diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crslbclnk.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crslbclnk.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b72d739746c599616948c601ecc39d8856a20204 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/crslbclnk.f90 @@ -0,0 +1,102 @@ + + + + + + + + + + + + + +MODULE crslbclnk + !!====================================================================== + !! *** MODULE crslbclnk *** + !! A temporary solution for lbclnk for coarsened grid. + !! Ocean : lateral boundary conditions for grid coarsening + !!===================================================================== + !! History : ! 2012-06 (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code + !!---------------------------------------------------------------------- + USE par_kind, ONLY: wp + USE dom_oce + USE crs + ! + USE lbclnk + USE in_out_manager + + INTERFACE crs_lbc_lnk + MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_2d + END INTERFACE + + PUBLIC crs_lbc_lnk + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crslbclnk.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, kfillmode, pfillval ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE crs_lbc_lnk *** + !! + !! ** Purpose : set lateral boundary conditions for coarsened grid + !! + !! ** Method : Swap domain indices from full to coarse domain + !! before arguments are passed directly to lbc_lnk. + !! Upon exiting, switch back to full domain indices. + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! grid type + REAL(wp) , INTENT(in ) :: psgn ! control of the sign + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 ! 3D array on which the lbc is applied + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = cst) + REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + ! + LOGICAL :: ll_grid_crs + !!---------------------------------------------------------------------- + ! + ll_grid_crs = ( jpi == jpi_crs ) + ! + IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain + ! + CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, kfillmode = kfillmode, pfillval = pfillval ) + ! + IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain + ! + END SUBROUTINE crs_lbc_lnk_3d + + + SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, kfillmode, pfillval ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE crs_lbc_lnk *** + !! + !! ** Purpose : set lateral boundary conditions for coarsened grid + !! + !! ** Method : Swap domain indices from full to coarse domain + !! before arguments are passed directly to lbc_lnk. + !! Upon exiting, switch back to full domain indices. + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cd_type ! grid type + REAL(wp) , INTENT(in ) :: psgn ! control of the sign + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + ! + LOGICAL :: ll_grid_crs + !!---------------------------------------------------------------------- + ! + ll_grid_crs = ( jpi == jpi_crs ) + ! + IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain + ! + CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, kfillmode = kfillmode, pfillval = pfillval ) + ! + IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain + ! + END SUBROUTINE crs_lbc_lnk_2d + + !!====================================================================== +END MODULE crslbclnk diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/cyclone.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/cyclone.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ca1b8b7da4ac6a97a97726dc9acb4e38164d3203 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/cyclone.f90 @@ -0,0 +1,25 @@ + + + + + + + + + + + + + +MODULE cyclone + !!====================================================================== + !! *** MODULE cyclone *** + !! add the Tropical Cyclones along tracks to the surface wind forcing + !! + !!====================================================================== + !! History : 3.3 ! 2010-05 (E Vincent, G Madec, S Masson) Original code + !!---------------------------------------------------------------------- + + + !!====================================================================== +END MODULE cyclone diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/daymod.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/daymod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6f96b55c4d53ee78d4df55119ad5f33532abd74e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/daymod.f90 @@ -0,0 +1,427 @@ + + + + + + + + + + + + + +MODULE daymod + !!====================================================================== + !! *** MODULE daymod *** + !! Ocean : management of the model calendar + !!===================================================================== + !! History : OPA ! 1994-09 (M. Pontaud M. Imbard) Original code + !! ! 1997-03 (O. Marti) + !! ! 1997-05 (G. Madec) + !! ! 1997-08 (M. Imbard) + !! NEMO 1.0 ! 2003-09 (G. Madec) F90 + nyear, nmonth, nday + !! ! 2004-01 (A.M. Treguier) new calculation based on adatrj + !! ! 2006-08 (G. Madec) surface module major update + !! ! 2015-11 (D. Lea) Allow non-zero initial time of day + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! day : calendar + !!---------------------------------------------------------------------- + !! ----------- WARNING ----------- + !! ------------------------------- + !! sbcmod assume that the time step is dividing the number of second of + !! in a day, i.e. ===> MOD( rday, rn_Dt ) == 0 + !! except when user defined forcing is used (see sbcmod.F90) + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ioipsl , ONLY : ymds2ju ! for calendar + USE trc_oce , ONLY : l_offline ! offline flag + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE iom ! + USE timing ! Timing + USE restart ! restart + + IMPLICIT NONE + PRIVATE + + PUBLIC day ! called by step.F90 + PUBLIC day_init ! called by istate.F90 + PUBLIC day_mth ! Needed by TAM + + INTEGER, PUBLIC :: nsecd, nsecd05, ndt, ndt05 !: (PUBLIC for TAM) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: daymod.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE day_init + !!---------------------------------------------------------------------- + !! *** ROUTINE day_init *** + !! + !! ** Purpose : Initialization of the calendar values to their values 1 time step before nit000 + !! because day will be called at the beginning of step + !! + !! ** Action : - nyear : current year + !! - nmonth : current month of the current nyear + !! - nday : current day of the current nmonth + !! - nday_year : current day of the current nyear + !! - nsec_year : seconds between 00h jan 1st of the current year and half of the current time step + !! - nsec_month : seconds between 00h 1st day of the current month and half of the current time step + !! - nsec_monday : seconds between 00h of the last Monday and half of the current time step + !! - nsec_day : seconds between 00h of the current day and half of the current time step + !! - nsec1jan000 : seconds between Jan. 1st 00h of nit000 year and Jan. 1st 00h of the current year + !! - nmonth_len, nyear_len, nmonth_beg through day_mth + !!---------------------------------------------------------------------- + INTEGER :: inbday, imonday, isecrst ! local integers + REAL(dp) :: zjul ! local scalar + !!---------------------------------------------------------------------- + ! + ! max number of seconds between each restart + IF( REAL( nitend - nit000 + 1 ) * rn_Dt > REAL( HUGE( nsec1jan000 ) ) ) THEN + CALL ctl_stop( 'The number of seconds between each restart exceeds the integer 4 max value: 2^31-1. ', & + & 'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' ) + ENDIF + nsecd = NINT( rday ) + nsecd05 = NINT( 0.5 * rday ) + ndt = NINT( rn_Dt ) + ndt05 = NINT( 0.5 * rn_Dt ) + + lrst_oce = .NOT. l_offline ! force definition of offline + IF( lrst_oce ) CALL day_rst( nit000, 'READ' ) + + ! set the calandar from ndastp (read in restart file and namelist) + nyear = ndastp / 10000 + nmonth = ( ndastp - (nyear * 10000) ) / 100 + nday = ndastp - (nyear * 10000) - ( nmonth * 100 ) + + nhour = nn_time0 / 100 + nminute = ( nn_time0 - nhour * 100 ) + isecrst = ( nhour * NINT(rhhmm) + nminute ) * NINT(rmmss) + + CALL ymds2ju( nyear, nmonth, nday, REAL(isecrst,dp), fjulday ) + IF( ABS(fjulday - REAL(NINT(fjulday),wp)) < 0.1 / rday ) fjulday = REAL(NINT(fjulday),wp) ! avoid truncation error + IF( nhour*NINT(rhhmm*rmmss) + nminute*NINT(rmmss) - ndt05 .LT. 0 ) fjulday = fjulday+1. ! move back to the day at nit000 (and not at nit000 - 1) + + nsec1jan000 = 0 + CALL day_mth + + IF ( nday == 0 ) THEN ! for ex if ndastp = ndate0 - 1 + nmonth = nmonth - 1 + nday = nmonth_len(nmonth) + ENDIF + IF ( nmonth == 0 ) THEN ! go at the end of previous year + nmonth = 12 + nyear = nyear - 1 + nsec1jan000 = nsec1jan000 - nsecd * nyear_len(0) + IF( nleapy == 1 ) CALL day_mth + ENDIF + + ! day since january 1st + nday_year = nday + SUM( nmonth_len(1:nmonth - 1) ) + + !compute number of days between last Monday and today + CALL ymds2ju( 1900, 01, 01, 0.0_dp, zjul ) ! compute julian day value of 01.01.1900 (our reference that was a Monday) + + inbday = FLOOR(fjulday - zjul) ! compute nb day between 01.01.1900 and start of current day + imonday = MOD(inbday, 7) ! compute nb day between last monday and current day + IF (imonday .LT. 0) imonday = imonday + 7 ! Avoid negative values for dates before 01.01.1900 + + ! number of seconds since the beginning of current year/month/week/day at the middle of the time-step + IF( isecrst - ndt05 .GT. 0 ) THEN + ! 1 timestep before current middle of first time step is still the same day + nsec_year = (nday_year-1) * nsecd + isecrst - ndt05 + nsec_month = (nday-1) * nsecd + isecrst - ndt05 + ELSE + ! 1 time step before the middle of the first time step is the previous day + nsec_year = nday_year * nsecd + isecrst - ndt05 + nsec_month = nday * nsecd + isecrst - ndt05 + ENDIF + nsec_monday = imonday * nsecd + isecrst - ndt05 + nsec_day = isecrst - ndt05 + IF( nsec_day .LT. 0 ) nsec_day = nsec_day + nsecd + IF( nsec_monday .LT. 0 ) nsec_monday = nsec_monday + nsecd*7 + + ! control print + IF(lwp) WRITE(numout,'(a,i6,a,i2,a,i2,a,i8,a,i8,a,i8,a,i8)') & + & ' =======>> 1/2 time step before the start of the run DATE Y/M/D = ', & + & nyear, '/', nmonth, '/', nday, ' nsec_day:', nsec_day, ' nsec_monday:', nsec_monday, ' & + & nsec_month:', nsec_month , ' nsec_year:' , nsec_year + + nsec000_1jan000 = nsec1jan000 + nsec_year + ndt05 + nsecend_1jan000 = nsec000_1jan000 + ndt * ( nitend - nit000 + 1 ) + + ! Up to now, calendar parameters are related to the end of previous run (nit000-1) + ! call day to set the calendar parameters at the begining of the current simulaton. needed by iom_init + CALL day( nit000 ) + ! + END SUBROUTINE day_init + + + SUBROUTINE day_mth + !!---------------------------------------------------------------------- + !! *** ROUTINE day_init *** + !! + !! ** Purpose : calendar values related to the months + !! + !! ** Action : - nyear_len : length in days of the previous/current year + !! - nmonth_len : length in days of the months of the current year + !! - nmonth_half : second since the beginning of the current year and the halft of the months + !! - nmonth_end : second since the beginning of the current year and the end of the months + !!---------------------------------------------------------------------- + INTEGER :: jm ,jy ! dummy loop indice + INTEGER, DIMENSION(12) :: idaymt ! length in days of the 12 months for non-leap year + !!---------------------------------------------------------------------- + + ! length of the month of the current year (from nleapy, read in namelist) + IF ( nleapy < 2 ) THEN + ! default values + idaymt(1:12) = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) + nmonth_len(-11: 25) = (/ idaymt(1:12), idaymt(1:12), idaymt(1:12), idaymt(1) /) + nyear_len(:) = 365 + ! + IF ( nleapy == 1 ) THEN ! we are using calandar with leap years + DO jy = -1,1 + IF ( MOD(nyear+jy, 4) == 0 .AND. ( MOD(nyear+jy, 400) == 0 .OR. MOD(nyear+jy, 100) /= 0 ) ) THEN + nmonth_len(2 + 12*jy) = 29 + nyear_len( 1 + jy) = 366 + ENDIF + ENDDO + ENDIF + ELSE + nmonth_len(:) = nleapy ! all months with nleapy days per year + nyear_len(:) = 12 * nleapy + ENDIF + + ! time since Jan 1st 0 1 2 ... 11 12 13 + ! ---------*--|--*--|--*--| ... |--*--|--*--|--*--|-------------------------------------- + ! <---> <---> <---> ... <---> <---> <---> + ! month number 0 1 2 ... 11 12 13 + nmonth_beg(1) = 0 + DO jm = 2, 25 + nmonth_beg(jm) = nmonth_beg(jm-1) + nsecd * nmonth_len(jm-1) + END DO + DO jm = 0,-11,-1 + nmonth_beg(jm) = nmonth_beg(jm+1) - nsecd * nmonth_len(jm) + END DO + ! + END SUBROUTINE day_mth + + + SUBROUTINE day( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE day *** + !! + !! ** Purpose : Compute the date with a day iteration IF necessary. + !! + !! ** Method : - ??? + !! + !! ** Action : - nyear : current year + !! - nmonth : current month of the year nyear + !! - nday : current day of the month nmonth + !! - nday_year : current day of the year nyear + !! - ndastp : = nyear*10000 + nmonth*100 + nday + !! - adatrj : date in days since the beginning of the run + !! - nsec_year : current time of the year (in second since 00h, jan 1st) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step indices + ! + CHARACTER (len=25) :: charout + REAL(dp) :: zprec ! fraction of day corresponding to 0.1 second + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('day') + ! + zprec = 0.1 / rday + ! ! New time-step + nsec_year = nsec_year + ndt + nsec_month = nsec_month + ndt + nsec_monday = nsec_monday + ndt + nsec_day = nsec_day + ndt + adatrj = adatrj + rn_Dt / rday + fjulday = fjulday + rn_Dt / rday + IF( ABS(fjulday - REAL(NINT(fjulday),wp)) < zprec ) fjulday = REAL(NINT(fjulday),wp) ! avoid truncation error + IF( ABS(adatrj - REAL(NINT(adatrj ),wp)) < zprec ) adatrj = REAL(NINT(adatrj ),wp) ! avoid truncation error + + IF( nsec_day > nsecd ) THEN ! New day + ! + nday = nday + 1 + nday_year = nday_year + 1 + nsec_day = ndt05 + ! + IF( nday == nmonth_len(nmonth) + 1 ) THEN ! New month + nday = 1 + nmonth = nmonth + 1 + nsec_month = ndt05 + IF( nmonth == 13 ) THEN ! New year + nyear = nyear + 1 + nmonth = 1 + nday_year = 1 + nsec_year = ndt05 + nsec1jan000 = nsec1jan000 + nsecd * nyear_len(1) + IF( nleapy == 1 ) CALL day_mth + ENDIF + ENDIF + ! + ndastp = nyear * 10000 + nmonth * 100 + nday ! New date + ! + !compute first day of the year in julian days + CALL ymds2ju( nyear, 01, 01, 0.0_dp, fjulstartyear ) + ! + IF(lwp) WRITE(numout,'(a,i8,a,i4.4,a,i2.2,a,i2.2,a,i3.3)') '======>> time-step =', kt, & + & ' New day, DATE Y/M/D = ', nyear, '/', nmonth, '/', nday, ' nday_year = ', nday_year + IF(lwp) WRITE(numout,'(a,i8,a,i7,a,i5)') ' nsec_year = ', nsec_year, & + & ' nsec_month = ', nsec_month, ' nsec_day = ', nsec_day, ' nsec_monday = ', nsec_monday + ENDIF + + IF( nsec_monday > 7*nsecd ) nsec_monday = ndt05 ! New week + + IF(sn_cfctl%l_prtctl) THEN + WRITE(charout,FMT="('kt =', I4,' d/m/y =',I2,I2,I4)") kt, nday, nmonth, nyear + CALL prt_ctl_info( charout ) + ENDIF + + IF( .NOT. l_offline ) CALL rst_opn( kt ) ! Open the restart file if needed and control lrst_oce + IF( lrst_oce ) CALL day_rst( kt, 'WRITE' ) ! write day restart information + ! + IF( ln_timing ) CALL timing_stop('day') + ! + END SUBROUTINE day + + + SUBROUTINE day_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE day_rst *** + !! + !! ** Purpose : Read or write calendar in restart file: + !! + !! WRITE(READ) mode: + !! kt : number of time step since the begining of the experiment at the + !! end of the current(previous) run + !! adatrj(0) : number of elapsed days since the begining of the experiment at the + !! end of the current(previous) run (REAL -> keep fractions of day) + !! ndastp : date at the end of the current(previous) run (coded as yyyymmdd integer) + !! + !! According to namelist parameter nrstdt, + !! nrstdt = 0 no control on the date (nit000 is arbitrary). + !! nrstdt = 1 we verify that nit000 is equal to the last + !! time step of previous run + 1. + !! In both those options, the exact duration of the experiment + !! since the beginning (cumulated duration of all previous restart runs) + !! is not stored in the restart and is assumed to be (nit000-1)*rn_Dt. + !! This is valid is the time step has remained constant. + !! + !! nrstdt = 2 the duration of the experiment in days (adatrj) + !! has been stored in the restart file. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + REAL(dp) :: zkt, zndastp, zdayfrac, ksecs, ktime + INTEGER :: ihour, iminute, isecond + !!---------------------------------------------------------------------- + + IF( TRIM(cdrw) == 'READ' ) THEN + IF( iom_varid( numror, 'kt', ldstop = .FALSE. ) > 0 ) THEN + ! Get Calendar informations + CALL iom_get( numror, 'kt', zkt ) ! last time-step of previous run + IF(lwp) THEN + WRITE(numout,*) ' *** Info read in restart : ' + WRITE(numout,*) ' previous time-step : ', NINT( zkt ) + WRITE(numout,*) ' *** restart option' + SELECT CASE ( nrstdt ) + CASE ( 0 ) ; WRITE(numout,*) ' nrstdt = 0 : no control of nit000' + CASE ( 1 ) ; WRITE(numout,*) ' nrstdt = 1 : no control the date at nit000 (use ndate0 read in the namelist)' + CASE ( 2 ) ; WRITE(numout,*) ' nrstdt = 2 : calendar parameters read in restart' + END SELECT + WRITE(numout,*) + ENDIF + ! Control of date + IF( nit000 - NINT( zkt ) /= 1 .AND. nrstdt /= 0 ) & + & CALL ctl_stop( ' ===>>>> : problem with nit000 for the restart', & + & ' verify the restart file or rerun with nrstdt = 0 (namelist)' ) + ! define ndastp and adatrj + IF ( nrstdt == 2 ) THEN + ! read the parameters corresponding to nit000 - 1 (last time step of previous run) + CALL iom_get( numror, 'ndastp', zndastp ) + ndastp = NINT( zndastp ) + CALL iom_get( numror, 'adatrj', adatrj ) + CALL iom_get( numror, 'ntime' , ktime ) + nn_time0 = NINT(ktime) + ! calculate start time in hours and minutes + zdayfrac = adatrj - REAL(INT(adatrj), wp) + ksecs = NINT(zdayfrac * rday) ! Nearest second to catch rounding errors in adatrj + ihour = ksecs / NINT( rhhmm*rmmss ) + iminute = ksecs / NINT(rmmss) - ihour*NINT(rhhmm) + + ! Add to nn_time0 + nhour = nn_time0 / 100 + nminute = ( nn_time0 - nhour * 100 ) + nminute = nminute + iminute + + IF( nminute >= NINT(rhhmm) ) THEN + nminute = nminute - NINT(rhhmm) + nhour = nhour+1 + ENDIF + nhour=nhour+ihour + IF( nhour >= NINT(rjjhh) ) THEN + nhour = nhour - NINT(rjjhh) + adatrj = adatrj + 1. + ENDIF + nn_time0 = nhour * 100 + nminute + adatrj = REAL(INT(adatrj), wp) ! adatrj set to integer as nn_time0 updated + ELSE + ! parameters corresponding to nit000 - 1 (as we start the step loop with a call to day) + ndastp = ndate0 ! ndate0 read in the namelist in dom_nam + nhour = nn_time0 / 100 + nminute = ( nn_time0 - nhour * 100 ) + isecond = ( nhour * NINT(rhhmm) + nminute ) * NINT(rmmss) + IF( isecond - ndt05 .lt. 0 ) ndastp = ndastp - 1 ! Start hour is specified in the namelist (default 0) + adatrj = ( REAL( nit000-1, wp ) * rn_Dt ) / rday + ! note this is wrong if time step has changed during run + ENDIF + ELSE + ! parameters corresponding to nit000 - 1 (as we start the step loop with a call to day) + ndastp = ndate0 ! ndate0 read in the namelist in dom_nam + nhour = nn_time0 / 100 + nminute = ( nn_time0 - nhour * 100 ) + isecond = ( nhour * NINT(rhhmm) + nminute ) * NINT(rmmss) + IF( isecond - ndt05 .LT. 0 ) ndastp = ndastp - 1 ! Start hour is specified in the namelist (default 0) + adatrj = ( REAL( nit000-1, wp ) * rn_Dt ) / rday + ENDIF + IF( ABS(adatrj - REAL(NINT(adatrj),wp)) < 0.1 / rday ) adatrj = REAL(NINT(adatrj),wp) ! avoid truncation error + ! + IF(lwp) THEN + WRITE(numout,*) ' *** Info used values : ' + WRITE(numout,*) ' date ndastp : ', ndastp + WRITE(numout,*) ' number of elapsed days since the begining of run : ', adatrj + WRITE(numout,*) ' nn_time0 : ',nn_time0 + WRITE(numout,*) + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN + ! + IF( kt == nitrst ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'rst_write : write oce restart file kt =', kt + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + ! calendar control + CALL iom_rstput( kt, nitrst, numrow, 'kt' , REAL( kt , wp) ) ! time-step + CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp) ) ! date + CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj ) ! number of elapsed days since + ! ! the begining of the run [s] + CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp) ) ! time + ENDIF + ! + END SUBROUTINE day_rst + + !!====================================================================== +END MODULE daymod diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/depth_e3.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/depth_e3.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3b8dc2d8d5a2800816d371ca527fa09585d53b90 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/depth_e3.f90 @@ -0,0 +1,176 @@ + + + + + + + + + + + + + +MODULE depth_e3 + !!====================================================================== + !! *** MODULE depth_e3 *** + !! + !! zgr : vertical coordinate system + !!====================================================================== + !! History : 4.0 ! 2016-11 (S. Flavoni, G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! depth_to_e3 : use the depth of t- and w-points to calculate e3t & e3w + !! (generic interface for 1D and 3D fields) + !! e3_to_depth : use e3t & e3w to calculate the depth of t- and w-points + !! (generic interface for 1D and 3D fields) + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! ocean domain + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + INTERFACE depth_to_e3 + MODULE PROCEDURE depth_to_e3_1d, depth_to_e3_3d + END INTERFACE + + INTERFACE e3_to_depth + MODULE PROCEDURE e3_to_depth_1d, e3_to_depth_3d + END INTERFACE + + PUBLIC depth_to_e3 ! called by usrdef_zgr + PUBLIC e3_to_depth ! called by domzgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: depth_e3.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE depth_to_e3_1d( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d ) + !!--------------------------------------------------------------------- + !! *** ROUTINE depth_to_e3_1d *** + !! + !! ** Purpose : compute e3t & e3w scale factors from t- & w-depths of model levels + !! + !! ** Method : The scale factors are given by the discrete derivative + !! of the depth: + !! e3w(jk) = dk[ dept_1d ] + !! e3t(jk) = dk[ depw_1d ] + !! with, at top and bottom : + !! e3w( 1 ) = 2 * ( dept( 1 ) - depw( 1 ) ) + !! e3t(jpk) = 2 * ( dept(jpk) - depw(jpk) ) + !! + !! ** Action : - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(in ) :: pdept_1d, pdepw_1d ! depths [m] + REAL(wp), DIMENSION(:), INTENT( out) :: pe3t_1d , pe3w_1d ! e3.=dk[depth] [m] + ! + INTEGER :: jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + ! use pdep. at w- and t-points to compute e3. (e3. = dk[depth]) + ! + pe3w_1d( 1 ) = 2._wp * ( pdept_1d(1) - pdepw_1d(1) ) + DO jk = 1, jpkm1 + pe3w_1d(jk+1) = pdept_1d(jk+1) - pdept_1d(jk) + pe3t_1d(jk ) = pdepw_1d(jk+1) - pdepw_1d(jk) + END DO + pe3t_1d(jpk) = 2._wp * ( pdept_1d(jpk) - pdepw_1d(jpk) ) + ! + END SUBROUTINE depth_to_e3_1d + + + SUBROUTINE depth_to_e3_3d( pdept_3d, pdepw_3d, pe3t_3d, pe3w_3d ) + !!--------------------------------------------------------------------- + !! *** ROUTINE depth_to_e3_3d *** + !! + !! ** Purpose : compute e3t & e3w scale factors from t- & w-depths of model levels + !! + !! ** Method : The scale factors are given by the discrete derivative + !! of the depth: + !! e3w(jk) = dk[ dept_1d ] + !! e3t(jk) = dk[ depw_1d ] + !! with, at top and bottom : + !! e3w( 1 ) = 2 * ( dept( 1 ) - depw( 1 ) ) + !! e3t(jpk) = 2 * ( dept(jpk) - depw(jpk) ) + !! + !! ** Action : - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdept_3d, pdepw_3d ! depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3t_3d , pe3w_3d ! e3.=dk[depth] [m] + ! + INTEGER :: jk ! dummy loop indices + !!---------------------------------------------------------------------- + pe3w_3d(:,:, 1 ) = 2._wp * ( pdept_3d(:,:,1) - pdepw_3d(:,:,1) ) + DO jk = 1, jpkm1 + pe3w_3d(:,:,jk+1) = pdept_3d(:,:,jk+1) - pdept_3d(:,:,jk) + pe3t_3d(:,:,jk ) = pdepw_3d(:,:,jk+1) - pdepw_3d(:,:,jk) + END DO + pe3t_3d(:,:,jpk) = 2._wp * ( pdept_3d(:,:,jpk) - pdepw_3d(:,:,jpk) ) + ! + END SUBROUTINE depth_to_e3_3d + + + SUBROUTINE e3_to_depth_1d( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) + !!--------------------------------------------------------------------- + !! *** ROUTINE e3_to_depth_1d *** + !! + !! ** Purpose : compute t- & w-depths of model levels from e3t & e3w scale factors + !! + !! ** Method : The t- & w-depth are given by the summation of e3w & e3t, resp. + !! + !! ** Action : - pe3t_1d, pe3w_1d : scale factor of t- and w-point (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(in ) :: pe3t_1d , pe3w_1d ! vert. scale factors [m] + REAL(wp), DIMENSION(:), INTENT( out) :: pdept_1d, pdepw_1d ! depth = SUM( e3 ) [m] + ! + INTEGER :: jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + pdepw_1d(1) = 0.0_wp + pdept_1d(1) = 0.5_wp * pe3w_1d(1) + DO jk = 2, jpk + pdepw_1d(jk) = pdepw_1d(jk-1) + pe3t_1d(jk-1) + pdept_1d(jk) = pdept_1d(jk-1) + pe3w_1d(jk ) + END DO + ! + END SUBROUTINE e3_to_depth_1d + + + SUBROUTINE e3_to_depth_3d( pe3t_3d, pe3w_3d, pdept_3d, pdepw_3d ) + !!--------------------------------------------------------------------- + !! *** ROUTINE e3_to_depth_3d *** + !! + !! ** Purpose : compute t- & w-depths of model levels from e3t & e3w scale factors + !! + !! ** Method : The t- & w-depth are given by the summation of e3w & e3t, resp. + !! + !! ** Action : - pe3t_1d, pe3w_1d : scale factor of t- and w-point (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pe3w_3d! vert. scale factors [m] + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pe3t_3d! vert. scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdept_3d, pdepw_3d ! depth = SUM( e3 ) [m] + ! + INTEGER :: jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + pdepw_3d(:,:,1) = 0.0_wp + pdept_3d(:,:,1) = 0.5_wp * pe3w_3d(:,:,1) + DO jk = 2, jpk + pdepw_3d(:,:,jk) = pdepw_3d(:,:,jk-1) + pe3t_3d(:,:,jk-1) + pdept_3d(:,:,jk) = pdept_3d(:,:,jk-1) + pe3w_3d(:,:,jk ) + END DO + ! + END SUBROUTINE e3_to_depth_3d + + !!====================================================================== +END MODULE depth_e3 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dia25h.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dia25h.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0dcdfa1fc0ea68677d7dc805b704b65c74e6cd4d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dia25h.f90 @@ -0,0 +1,335 @@ + + + + + + + + + + + + + +MODULE dia25h + !!====================================================================== + !! *** MODULE diaharm *** + !! Harmonic analysis of tidal constituents + !!====================================================================== + !! History : 3.6 ! 2014 (E O'Dea) Original code + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain + USE zdf_oce ! ocean vertical physics + USE zdfgls , ONLY : hmxl_n + ! + USE in_out_manager ! I/O units + USE iom ! I/0 library + USE wet_dry + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_25h_init ! routine called by nemogcm.F90 + PUBLIC dia_25h ! routine called by diawri.F90 + + LOGICAL, PUBLIC :: ln_dia25h !: 25h mean output + + ! variables for calculating 25-hourly means + INTEGER , SAVE :: cnt_25h ! Counter for 25 hour means + REAL(wp), SAVE :: r1_25 = 0.04_wp ! =1/25 + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: tn_25h , sn_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: sshn_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: un_25h , vn_25h , wn_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avt_25h , avm_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: en_25h , rmxln_25h + +!! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dia25h.F90 15249 2021-09-13 09:59:09Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_25h_init( Kbb ) + !!--------------------------------------------------------------------------- + !! *** ROUTINE dia_25h_init *** + !! + !! ** Purpose: Initialization of 25h mean namelist + !! + !! ** Method : Read namelist + !!--------------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb ! Time level index + ! + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: ierror ! Local integer for memory allocation + INTEGER :: ji, jj, jk + ! + NAMELIST/nam_dia25h/ ln_dia25h + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, nam_dia25h, IOSTAT=ios, ERR= 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_dia25h in reference namelist' ) + READ ( numnam_cfg, nam_dia25h, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_dia25h in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_dia25h ) + + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dia_25h_init : Output 25 hour mean diagnostics' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist nam_dia25h : set 25h outputs ' + WRITE(numout,*) ' Switch for 25h diagnostics (T) or not (F) ln_dia25h = ', ln_dia25h + ENDIF + IF( .NOT. ln_dia25h ) RETURN + ! ------------------- ! + ! 1 - Allocate memory ! + ! ------------------- ! + ! ! ocean arrays + ALLOCATE( tn_25h (ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jpk), sn_25h (ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jpk), sshn_25h(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) , & + & un_25h (ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jpk), vn_25h (ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jpk), wn_25h(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jpk), & + & avt_25h(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jpk), avm_25h(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jpk), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'dia_25h: unable to allocate ocean arrays' ) ; RETURN + ENDIF + IF( ln_zdftke ) THEN ! TKE physics + ALLOCATE( en_25h(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jpk), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'dia_25h: unable to allocate en_25h' ) ; RETURN + ENDIF + ENDIF + IF( ln_zdfgls ) THEN ! GLS physics + ALLOCATE( en_25h(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jpk), rmxln_25h(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jpk), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'dia_25h: unable to allocate en_25h and rmxln_25h' ) ; RETURN + ENDIF + ENDIF + ! ------------------------- ! + ! 2 - Assign Initial Values ! + ! ------------------------- ! + cnt_25h = 1 ! sets the first value of sum at timestep 1 (note - should strictly be at timestep zero so before values used where possible) + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + tn_25h (ji,jj,jk) = ts (ji,jj,jk,jp_tem,Kbb) + sn_25h (ji,jj,jk) = ts (ji,jj,jk,jp_sal,Kbb) + un_25h (ji,jj,jk) = uu (ji,jj,jk,Kbb) + vn_25h (ji,jj,jk) = vv (ji,jj,jk,Kbb) + avt_25h(ji,jj,jk) = avt(ji,jj,jk) + avm_25h(ji,jj,jk) = avm(ji,jj,jk) + END DO ; END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + sshn_25h(ji,jj) = ssh(ji,jj,Kbb) + END DO ; END DO + IF( ln_zdftke ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + en_25h(ji,jj,jk) = en(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + IF( ln_zdfgls ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + en_25h (ji,jj,jk) = en (ji,jj,jk) + rmxln_25h(ji,jj,jk) = hmxl_n(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ! + END SUBROUTINE dia_25h_init + + + SUBROUTINE dia_25h( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_25h *** + !! + !! ** Purpose : Write diagnostics with M2/S2 tide removed + !! + !! ** Method : 25hr mean outputs for shelf seas + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !! + INTEGER :: ji, jj, jk + INTEGER :: iyear0, nimonth0,iday0 ! start year,imonth,day + LOGICAL :: ll_print = .FALSE. ! =T print and flush numout + REAL(dp) :: zsto, zout, zmax, zjulian, zmdi ! local scalars + INTEGER :: i_steps ! no of timesteps per hour + REAL(wp), DIMENSION(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0) ) :: zw2d, un_dm, vn_dm ! workspace + REAL(wp), DIMENSION(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),jpk) :: zw3d ! workspace + REAL(wp), DIMENSION(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),3) :: zwtmb ! workspace + !!---------------------------------------------------------------------- + + ! 0. Initialisation + ! ----------------- + ! Define frequency of summing to create 25 h mean + IF( MOD( 3600,NINT(rn_Dt) ) == 0 ) THEN + i_steps = 3600/NINT(rn_Dt) + ELSE + CALL ctl_stop('STOP', 'dia_wri_tide: timestep must give MOD(3600,rn_Dt) = 0 otherwise no hourly values are possible') + ENDIF + + ! local variable for debugging + ll_print = ll_print .AND. lwp + + ! wn_25h could not be initialised in dia_25h_init, so we do it here instead + IF( kt == nn_it000 ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + wn_25h(ji,jj,jk) = ww(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + + ! Sum of 25 hourly instantaneous values to give a 25h mean from 24hours every day + IF( MOD( kt, i_steps ) == 0 .AND. kt /= nn_it000 ) THEN + + IF (lwp) THEN + WRITE(numout,*) 'dia_wri_tide : Summing instantaneous hourly diagnostics at timestep ',kt + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + tn_25h (ji,jj,jk) = tn_25h (ji,jj,jk) + ts (ji,jj,jk,jp_tem,Kmm) + sn_25h (ji,jj,jk) = sn_25h (ji,jj,jk) + ts (ji,jj,jk,jp_sal,Kmm) + un_25h (ji,jj,jk) = un_25h (ji,jj,jk) + uu (ji,jj,jk,Kmm) + vn_25h (ji,jj,jk) = vn_25h (ji,jj,jk) + vv (ji,jj,jk,Kmm) + wn_25h (ji,jj,jk) = wn_25h (ji,jj,jk) + ww (ji,jj,jk) + avt_25h (ji,jj,jk) = avt_25h (ji,jj,jk) + avt(ji,jj,jk) + avm_25h (ji,jj,jk) = avm_25h (ji,jj,jk) + avm(ji,jj,jk) + END DO ; END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + sshn_25h(ji,jj) = sshn_25h(ji,jj) + ssh(ji,jj,Kmm) + END DO ; END DO + IF( ln_zdftke ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + en_25h(ji,jj,jk) = en_25h(ji,jj,jk) + en(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + IF( ln_zdfgls ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + en_25h (ji,jj,jk) = en_25h (ji,jj,jk) + en (ji,jj,jk) + rmxln_25h(ji,jj,jk) = rmxln_25h(ji,jj,jk) + hmxl_n(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + cnt_25h = cnt_25h + 1 + ! + IF (lwp) THEN + WRITE(numout,*) 'dia_tide : Summed the following number of hourly values so far',cnt_25h + ENDIF + ! + ENDIF ! MOD( kt, i_steps ) == 0 + + ! Write data for 25 hour mean output streams + IF( cnt_25h == 25 .AND. MOD( kt, i_steps*24) == 0 .AND. kt /= nn_it000 ) THEN + ! + IF(lwp) THEN + WRITE(numout,*) 'dia_wri_tide : Writing 25 hour mean tide diagnostics at timestep', kt + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! + tn_25h (:,:,:) = tn_25h (:,:,:) * r1_25 + sn_25h (:,:,:) = sn_25h (:,:,:) * r1_25 + sshn_25h(:,:) = sshn_25h(:,:) * r1_25 + un_25h (:,:,:) = un_25h (:,:,:) * r1_25 + vn_25h (:,:,:) = vn_25h (:,:,:) * r1_25 + wn_25h (:,:,:) = wn_25h (:,:,:) * r1_25 + avt_25h (:,:,:) = avt_25h (:,:,:) * r1_25 + avm_25h (:,:,:) = avm_25h (:,:,:) * r1_25 + IF( ln_zdftke ) THEN + en_25h(:,:,:) = en_25h(:,:,:) * r1_25 + ENDIF + IF( ln_zdfgls ) THEN + en_25h (:,:,:) = en_25h (:,:,:) * r1_25 + rmxln_25h(:,:,:) = rmxln_25h(:,:,:) * r1_25 + ENDIF + ! + IF(lwp) WRITE(numout,*) 'dia_wri_tide : Mean calculated by dividing 25 hour sums and writing output' + zmdi=1.e+20 !missing data indicator for masking + ! write tracers (instantaneous) + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zw3d(ji,jj,jk) = tn_25h(ji,jj,jk)*tmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END DO ; END DO ; END DO + CALL iom_put("temper25h", zw3d) ! potential temperature + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zw3d(ji,jj,jk) = sn_25h(ji,jj,jk)*tmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END DO ; END DO ; END DO + CALL iom_put( "salin25h", zw3d ) ! salinity + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zw2d(ji,jj) = sshn_25h(ji,jj)*tmask(ji,jj,1) + zmdi*(1.0-tmask(ji,jj,1)) + END DO ; END DO + IF( ll_wd ) THEN + CALL iom_put( "ssh25h", zw2d+ssh_ref ) ! sea surface + ELSE + CALL iom_put( "ssh25h", zw2d ) ! sea surface + ENDIF + ! Write velocities (instantaneous) + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zw3d(ji,jj,jk) = un_25h(ji,jj,jk)*umask(ji,jj,jk) + zmdi*(1.0-umask(ji,jj,jk)) + END DO ; END DO ; END DO + CALL iom_put("vozocrtx25h", zw3d) ! i-current + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zw3d(ji,jj,jk) = vn_25h(ji,jj,jk)*vmask(ji,jj,jk) + zmdi*(1.0-vmask(ji,jj,jk)) + END DO ; END DO ; END DO + CALL iom_put("vomecrty25h", zw3d ) ! j-current + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zw3d(ji,jj,jk) = wn_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END DO ; END DO ; END DO + CALL iom_put("vovecrtz25h", zw3d ) ! k-current + ! Write vertical physics + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zw3d(ji,jj,jk) = avt_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END DO ; END DO ; END DO + CALL iom_put("avt25h", zw3d ) ! diffusivity + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zw3d(ji,jj,jk) = avm_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END DO ; END DO ; END DO + CALL iom_put("avm25h", zw3d) ! viscosity + IF( ln_zdftke ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zw3d(ji,jj,jk) = en_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END DO ; END DO ; END DO + CALL iom_put("tke25h", zw3d) ! tke + ENDIF + IF( ln_zdfgls ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zw3d(ji,jj,jk) = en_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END DO ; END DO ; END DO + CALL iom_put("tke25h", zw3d) ! tke + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zw3d(ji,jj,jk) = rmxln_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END DO ; END DO ; END DO + CALL iom_put( "mxln25h",zw3d) + ENDIF + ! + ! After the write reset the values to cnt=1 and sum values equal current value + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + tn_25h (ji,jj,jk) = ts (ji,jj,jk,jp_tem,Kmm) + sn_25h (ji,jj,jk) = ts (ji,jj,jk,jp_sal,Kmm) + un_25h (ji,jj,jk) = uu (ji,jj,jk,Kmm) + vn_25h (ji,jj,jk) = vv (ji,jj,jk,Kmm) + wn_25h (ji,jj,jk) = ww (ji,jj,jk) + avt_25h (ji,jj,jk) = avt(ji,jj,jk) + avm_25h (ji,jj,jk) = avm(ji,jj,jk) + END DO ; END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + sshn_25h(ji,jj) = ssh(ji,jj,Kmm) + END DO ; END DO + IF( ln_zdftke ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + en_25h(ji,jj,jk) = en(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + IF( ln_zdfgls ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + en_25h (ji,jj,jk) = en (ji,jj,jk) + rmxln_25h(ji,jj,jk) = hmxl_n(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + cnt_25h = 1 + IF(lwp) WRITE(numout,*) 'dia_wri_tide : & + & After 25hr mean write, reset sum to current value and cnt_25h to one for overlapping average', cnt_25h + ENDIF ! cnt_25h .EQ. 25 .AND. MOD( kt, i_steps * 24) == 0 .AND. kt .NE. nn_it000 + ! + END SUBROUTINE dia_25h + + !!====================================================================== +END MODULE dia25h diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diaar5.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diaar5.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d6c96f10711513552264038445b560c4af8d2db4 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diaar5.f90 @@ -0,0 +1,450 @@ + + + + + + + + + + + + + +MODULE diaar5 + !!====================================================================== + !! *** MODULE diaar5 *** + !! AR5 diagnostics + !!====================================================================== + !! History : 3.2 ! 2009-11 (S. Masson) Original code + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA + !!---------------------------------------------------------------------- + !! dia_ar5 : AR5 diagnostics + !! dia_ar5_init : initialisation of AR5 diagnostics + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE eosbn2 ! equation of state (eos_bn2 routine) + USE phycst ! physical constant + USE in_out_manager ! I/O manager + USE zdfddm + USE zdf_oce + ! + USE lib_mpp ! distribued memory computing library + USE iom ! I/O manager library + USE fldread ! type FLD_N + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_ar5 ! routine called in step.F90 module + PUBLIC dia_ar5_alloc ! routine called in nemogcm.F90 module + PUBLIC dia_ar5_hst ! heat/salt transport + + REAL(wp) :: vol0 ! ocean volume (interior domain) + REAL(wp) :: area_tot ! total ocean surface (interior domain) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: thick0 ! ocean thickness (interior domain) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sn0 ! initial salinity + + LOGICAL :: l_ar5 + + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diaar5.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + FUNCTION dia_ar5_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ar5_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: dia_ar5_alloc + !!---------------------------------------------------------------------- + ! + ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk), STAT=dia_ar5_alloc ) + ! + CALL mpp_sum ( 'diaar5', dia_ar5_alloc ) + IF( dia_ar5_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dia_ar5_alloc: failed to allocate arrays' ) + ! + END FUNCTION dia_ar5_alloc + + + SUBROUTINE dia_ar5( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ar5 *** + !! + !! ** Purpose : compute and output some AR5 diagnostics + !!---------------------------------------------------------------------- + ! + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + ! + INTEGER :: ji, jj, jk, iks, ikb ! dummy loop arguments + REAL(wp) :: zvolssh, zvol, zssh_steric, zztmp, zarho, ztemp, zsal, zmass, zsst + REAL(wp) :: zaw, zbw, zrw + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zarea_ssh , zbotpres ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d, zpe ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d, zrhd, ztpot, zgdept ! 3D workspace (zgdept: needed to use the substitute) + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztsn ! 4D workspace + + !!-------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('dia_ar5') + + IF( kt == nit000 ) CALL dia_ar5_init + + IF( l_ar5 ) THEN + ALLOCATE( zarea_ssh(jpi,jpj), zbotpres(jpi,jpj), z2d(jpi,jpj) ) + ALLOCATE( zrhd(jpi,jpj,jpk) ) + ALLOCATE( ztsn(jpi,jpj,jpk,jpts) ) + zarea_ssh(:,:) = e1e2t(:,:) * ssh(:,:,Kmm) + ENDIF + ! + CALL iom_put( 'e2u' , e2u (:,:) ) + CALL iom_put( 'e1v' , e1v (:,:) ) + CALL iom_put( 'areacello', e1e2t(:,:) ) + ! + IF( iom_use( 'volcello' ) .OR. iom_use( 'masscello' ) ) THEN + zrhd(:,:,jpk) = 0._wp ! ocean volume ; rhd is used as workspace + DO jk = 1, jpkm1 + zrhd(:,:,jk) = e1e2t(:,:) * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) * tmask(:,:,jk) + END DO + DO jk = 1, jpk + z3d(:,:,jk) = rho0 * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) * tmask(:,:,jk) + END DO + CALL iom_put( 'volcello' , zrhd(:,:,:) ) ! WARNING not consistent with CMIP DR where volcello is at ca. 2000 + CALL iom_put( 'masscello' , z3d (:,:,:) ) ! ocean mass + ENDIF + ! + IF( iom_use( 'e3tb' ) ) THEN ! bottom layer thickness + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ikb = mbkt(ji,jj) + z2d(ji,jj) = (e3t_0(ji,jj,ikb)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,ikb))) + END DO ; END DO + CALL iom_put( 'e3tb', z2d ) + ENDIF + ! + IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) ) THEN + ! ! total volume of liquid seawater + zvolssh =glob_sum( 'diaar5', REAL(zarea_ssh(:,:),dp) ) + zvol = vol0 + zvolssh + + CALL iom_put( 'voltot', zvol ) + CALL iom_put( 'sshtot', zvolssh / area_tot ) + CALL iom_put( 'sshdyn', ssh(:,:,Kmm) - (zvolssh / area_tot) ) + ! + ENDIF + + IF( iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) ) THEN + ! + ztsn(:,:,:,jp_tem) = ts(:,:,:,jp_tem,Kmm) ! thermosteric ssh + ztsn(:,:,:,jp_sal) = sn0(:,:,:) + ALLOCATE( zgdept(jpi,jpj,jpk) ) + DO jk = 1, jpk + zgdept(:,:,jk) = (gdept_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) + END DO + CALL eos( REAL(ztsn,dp), zrhd, zgdept) ! now in situ density using initial salinity + ! + zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice + DO jk = 1, jpkm1 + zbotpres(:,:) = zbotpres(:,:) + (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) * zrhd(:,:,jk) + END DO + IF( ln_linssh ) THEN + IF( ln_isfcav ) THEN + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + iks = mikt(ji,jj) + zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj) + END DO ; END DO + ELSE + zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * zrhd(:,:,1) + END IF +!!gm +!!gm riceload should be added in both ln_linssh=T or F, no? +!!gm + END IF + ! + zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) ) + zssh_steric = - zarho / area_tot + CALL iom_put( 'sshthster', zssh_steric ) + + ! ! steric sea surface height + zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice + DO jk = 1, jpkm1 + zbotpres(:,:) = zbotpres(:,:) + (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) * rhd(:,:,jk) + END DO + IF( ln_linssh ) THEN + IF ( ln_isfcav ) THEN + DO ji = 1,jpi + DO jj = 1,jpj + iks = mikt(ji,jj) + zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * rhd(ji,jj,iks) + riceload(ji,jj) + END DO + END DO + ELSE + zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * rhd(:,:,1) + END IF + END IF + ! + zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) ) + zssh_steric = - zarho / area_tot + CALL iom_put( 'sshsteric', zssh_steric ) + ! ! ocean bottom pressure + zztmp = rho0 * grav * 1.e-4_wp ! recover pressure from pressure anomaly and cover to dbar = 1.e4 Pa + zbotpres(:,:) = zztmp * ( zbotpres(:,:) + ssh(:,:,Kmm) + thick0(:,:) ) + CALL iom_put( 'botpres', zbotpres ) + ! + DEALLOCATE( zgdept ) + ! + ENDIF + + IF( iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) ) THEN + ! ! Mean density anomalie, temperature and salinity + ztsn(:,:,:,:) = 0._wp ! ztsn(:,:,1,jp_tem/sal) is used here as 2D Workspace for temperature & salinity + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + zztmp = e1e2t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zztmp * ts(ji,jj,jk,jp_tem,Kmm) + ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zztmp * ts(ji,jj,jk,jp_sal,Kmm) + END DO ; END DO ; END DO + + IF( ln_linssh ) THEN + IF( ln_isfcav ) THEN + DO ji = 1, jpi + DO jj = 1, jpj + iks = mikt(ji,jj) + ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_tem,Kmm) + ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_sal,Kmm) + END DO + END DO + ELSE + ztsn(:,:,1,jp_tem) = ztsn(:,:,1,jp_tem) + zarea_ssh(:,:) * ts(:,:,1,jp_tem,Kmm) + ztsn(:,:,1,jp_sal) = ztsn(:,:,1,jp_sal) + zarea_ssh(:,:) * ts(:,:,1,jp_sal,Kmm) + END IF + ENDIF + ! + ztemp =glob_sum( 'diaar5', REAL(ztsn(:,:,1,jp_tem),dp) ) + zsal =glob_sum( 'diaar5', REAL(ztsn(:,:,1,jp_sal),dp) ) + zmass = rho0 * ( zarho + zvol ) + ! + CALL iom_put( 'masstot', zmass ) + CALL iom_put( 'temptot', ztemp / zvol ) + CALL iom_put( 'saltot' , zsal / zvol ) + ! + ENDIF + + IF( ln_teos10 ) THEN ! ! potential temperature (TEOS-10 case) + IF( iom_use( 'toce_pot') .OR. iom_use( 'temptot_pot' ) .OR. iom_use( 'sst_pot' ) & + .OR. iom_use( 'ssttot' ) .OR. iom_use( 'tosmint_pot' ) ) THEN + ! + ALLOCATE( ztpot(jpi,jpj,jpk) ) + ztpot(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + ztpot(:,:,jk) =eos_pt_from_ct( REAL(ts(:,:,jk,jp_tem,Kmm),sp), REAL(ts(:,:,jk,jp_sal,Kmm),sp) ) + END DO + ! + CALL iom_put( 'toce_pot', ztpot(:,:,:) ) ! potential temperature (TEOS-10 case) + CALL iom_put( 'sst_pot' , ztpot(:,:,1) ) ! surface temperature + ! + IF( iom_use( 'temptot_pot' ) ) THEN ! Output potential temperature in case we use TEOS-10 + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 + z2d(:,:) = z2d(:,:) + e1e2t(:,:) * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) * ztpot(:,:,jk) + END DO + ztemp =glob_sum( 'diaar5', REAL(z2d(:,:),dp) ) + CALL iom_put( 'temptot_pot', ztemp / zvol ) + ENDIF + ! + IF( iom_use( 'ssttot' ) ) THEN ! Output potential temperature in case we use TEOS-10 + zsst = glob_sum( 'diaar5', e1e2t(:,:) * ztpot(:,:,1) ) + CALL iom_put( 'ssttot', zsst / area_tot ) + ENDIF + ! Vertical integral of temperature + IF( iom_use( 'tosmint_pot') ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + z2d(ji,jj) = z2d(ji,jj) + rho0 * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * ztpot(ji,jj,jk) + END DO ; END DO ; END DO + CALL iom_put( 'tosmint_pot', z2d ) + ENDIF + DEALLOCATE( ztpot ) + ENDIF + ELSE + IF( iom_use('ssttot') ) THEN ! Output sst in case we use EOS-80 + zsst = glob_sum( 'diaar5', e1e2t(:,:) * ts(:,:,1,jp_tem,Kmm) ) + CALL iom_put('ssttot', zsst / area_tot ) + ENDIF + ENDIF + + IF( iom_use( 'tnpeo' )) THEN + ! Work done against stratification by vertical mixing + ! Exclude points where rn2 is negative as convection kicks in here and + ! work is not being done against stratification + ALLOCATE( zpe(jpi,jpj) ) + zpe(:,:) = 0._wp + IF( ln_zdfddm ) THEN + DO jk = 2, jpk ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + IF( rn2(ji,jj,jk) > 0._wp ) THEN + zrw = ( (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) / (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + ! + zaw = rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem)* zrw + zbw = rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal)* zrw + ! + zpe(ji, jj) = zpe(ji,jj) & + & - grav * ( avt(ji,jj,jk) * zaw * (ts(ji,jj,jk-1,jp_tem,Kmm) - ts(ji,jj,jk,jp_tem,Kmm) ) & + & - avs(ji,jj,jk) * zbw * (ts(ji,jj,jk-1,jp_sal,Kmm) - ts(ji,jj,jk,jp_sal,Kmm) ) ) + ENDIF + END DO ; END DO ; END DO + ELSE + DO jk = 1, jpk ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + zpe(ji,jj) = zpe(ji,jj) + avt(ji,jj,jk) * MIN(0._wp,rn2(ji,jj,jk)) * rho0 * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO ; END DO + ENDIF + CALL iom_put( 'tnpeo', zpe ) + DEALLOCATE( zpe ) + ENDIF + + IF( l_ar5 ) THEN + DEALLOCATE( zarea_ssh , zbotpres, z2d ) + DEALLOCATE( ztsn ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dia_ar5') + ! + END SUBROUTINE dia_ar5 + + + SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ar5_htr *** + !!---------------------------------------------------------------------- + !! Wrapper for heat transport calculations + !! Called from all advection and/or diffusion routines + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktra ! tracer index + CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf' + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) , INTENT(in) :: puflx ! u-flux of advection/diffusion + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) , INTENT(in) :: pvflx ! v-flux of advection/diffusion + ! + INTEGER :: ji, jj, jk + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: z2d + + z2d(:,:) = puflx(:,:,1) + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk) + END DO ; END DO ; END DO + + IF( cptr == 'adv' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d(:,:) ) ! advective heat transport in i-direction + IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * z2d(:,:) ) ! advective salt transport in i-direction + ELSE IF( cptr == 'ldf' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * z2d(:,:) ) ! diffusive heat transport in i-direction + IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * z2d(:,:) ) ! diffusive salt transport in i-direction + ENDIF + ! + z2d(:,:) = pvflx(:,:,1) + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk) + END DO ; END DO ; END DO + + IF( cptr == 'adv' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d(:,:) ) ! advective heat transport in j-direction + IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * z2d(:,:) ) ! advective salt transport in j-direction + ELSE IF( cptr == 'ldf' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * z2d(:,:) ) ! diffusive heat transport in j-direction + IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * z2d(:,:) ) ! diffusive salt transport in j-direction + ENDIF + + END SUBROUTINE dia_ar5_hst + + + SUBROUTINE dia_ar5_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ar5_init *** + !! + !! ** Purpose : initialization for AR5 diagnostic computation + !!---------------------------------------------------------------------- + INTEGER :: inum + INTEGER :: ik, idep + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zztmp + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zvol0 + ! + !!---------------------------------------------------------------------- + ! + l_ar5 = .FALSE. + IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) .OR. & + & iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) .OR. & + & iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) .OR. & + & iom_use( 'uadv_heattr' ) .OR. iom_use( 'udiff_heattr' ) .OR. & + & iom_use( 'uadv_salttr' ) .OR. iom_use( 'udiff_salttr' ) .OR. & + & iom_use( 'vadv_heattr' ) .OR. iom_use( 'vdiff_heattr' ) .OR. & + & iom_use( 'vadv_salttr' ) .OR. iom_use( 'vdiff_salttr' ) .OR. & + & iom_use( 'rhop' ) ) L_ar5 = .TRUE. + + IF( l_ar5 ) THEN + ! + ! ! allocate dia_ar5 arrays + IF( dia_ar5_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) + + area_tot = glob_sum( 'diaar5', e1e2t(:,:) ) + + ALLOCATE( zvol0(jpi,jpj) ) + zvol0 (:,:) = 0._wp + thick0(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) ! interpolation of salinity at the last ocean level (i.e. the partial step) + idep = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) + zvol0 (ji,jj) = zvol0 (ji,jj) + idep * e1e2t(ji,jj) + thick0(ji,jj) = thick0(ji,jj) + idep + END DO ; END DO ; END DO + vol0 =glob_sum( 'diaar5', REAL(zvol0,dp) ) + DEALLOCATE( zvol0 ) + + IF( iom_use( 'sshthster' ) ) THEN + ALLOCATE( zsaldta(jpi,jpj,jpk,jpts) ) + CALL iom_open ( 'sali_ref_clim_monthly', inum ) + CALL iom_get ( inum, jpdom_global, 'vosaline' , zsaldta(:,:,:,1), 1 ) + CALL iom_get ( inum, jpdom_global, 'vosaline' , zsaldta(:,:,:,2), 12 ) + CALL iom_close( inum ) + + sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) ) + sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) + IF( ln_zps ) THEN ! z-coord. partial steps + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) ! interpolation of salinity at the last ocean level (i.e. the partial step) + ik = mbkt(ji,jj) + IF( ik > 1 ) THEN + zztmp = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) + sn0(ji,jj,ik) = ( 1._wp - zztmp ) * sn0(ji,jj,ik) + zztmp * sn0(ji,jj,ik-1) + ENDIF + END DO ; END DO + ENDIF + ! + DEALLOCATE( zsaldta ) + ENDIF + ! + ENDIF + ! + END SUBROUTINE dia_ar5_init + + !!====================================================================== +END MODULE diaar5 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diacfl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diacfl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4a4ae1063cea006f9577fee10d63d428dad529ac --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diacfl.f90 @@ -0,0 +1,189 @@ + + + + + + + + + + + + + +MODULE diacfl + !!====================================================================== + !! *** MODULE diacfl *** + !! Output CFL diagnostics to ascii file + !!====================================================================== + !! History : 3.4 ! 2010-03 (E. Blockley) Original code + !! 3.6 ! 2014-06 (T. Graham) Removed CPP key & Updated to vn3.6 + !! 4.0 ! 2017-09 (G. Madec) style + comments + !!---------------------------------------------------------------------- + !! dia_cfl : Compute and output Courant numbers at each timestep + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domvvl ! + ! + USE lib_mpp ! distribued memory computing + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE in_out_manager ! I/O manager + USE iom ! + USE timing ! Performance output + + IMPLICIT NONE + PRIVATE + + CHARACTER(LEN=50) :: clname="cfl_diagnostics.ascii" ! ascii filename + INTEGER :: numcfl ! outfile unit + ! + INTEGER, DIMENSION(3) :: nCu_loc, nCv_loc, nCw_loc ! U, V, and W run max locations in the global domain + REAL(wp) :: rCu_max, rCv_max, rCw_max ! associated run max Courant number + + PUBLIC dia_cfl ! routine called by step.F90 + PUBLIC dia_cfl_init ! routine called by nemogcm + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diacfl.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_cfl ( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_cfl *** + !! + !! ** Purpose : Compute the Courant numbers Cu=u*dt/dx and Cv=v*dt/dy + !! and output to ascii file 'cfl_diagnostics.ascii' + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zCu_max, zCv_max, zCw_max ! local scalars + INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc ! workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace + LOGICAL , DIMENSION(jpi,jpj,jpk) :: llmsk + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_cfl') + ! + llmsk( 1:nn_hls,:,:) = .FALSE. ! exclude halos from the checked region + llmsk(Nie0+1: jpi,:,:) = .FALSE. + llmsk(:, 1:nn_hls,:) = .FALSE. + llmsk(:,Nje0+1: jpj,:) = .FALSE. + ! + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! calculate Courant numbers + zCu_cfl(ji,jj,jk) = ABS( uu(ji,jj,jk,Kmm) ) * rDt / e1u (ji,jj) ! for i-direction + zCv_cfl(ji,jj,jk) = ABS( vv(ji,jj,jk,Kmm) ) * rDt / e2v (ji,jj) ! for j-direction + zCw_cfl(ji,jj,jk) = ABS( ww(ji,jj,jk) ) * rDt / (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ! for k-direction + END DO ; END DO ; END DO + ! + ! write outputs + IF( iom_use('cfl_cu') ) THEN + llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, mask = llmsk, dim=3 ) ) + ENDIF + IF( iom_use('cfl_cv') ) THEN + llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, mask = llmsk, dim=3 ) ) + ENDIF + IF( iom_use('cfl_cw') ) THEN + llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, mask = llmsk, dim=3 ) ) + ENDIF + + ! ! calculate maximum values and locations + llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL mpp_maxloc( 'diacfl', REAL(zCu_cfl,dp), llmsk, zCu_max, iloc_u ) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL mpp_maxloc( 'diacfl', REAL(zCv_cfl,dp), llmsk, zCv_max, iloc_v ) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL mpp_maxloc( 'diacfl', REAL(zCw_cfl,dp), llmsk, zCw_max, iloc_w ) + ! + IF( lwp ) THEN ! write out to file + WRITE(numcfl,FMT='(2x,i6,3x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) + WRITE(numcfl,FMT='(11x, a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') 'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) + WRITE(numcfl,FMT='(11x, a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') 'Max Cw', zCw_max, iloc_w(1), iloc_w(2), iloc_w(3) + ENDIF + ! + ! ! update maximum Courant numbers from whole run if applicable + IF( zCu_max > rCu_max ) THEN ; rCu_max = zCu_max ; nCu_loc(:) = iloc_u(:) ; ENDIF + IF( zCv_max > rCv_max ) THEN ; rCv_max = zCv_max ; nCv_loc(:) = iloc_v(:) ; ENDIF + IF( zCw_max > rCw_max ) THEN ; rCw_max = zCw_max ; nCw_loc(:) = iloc_w(:) ; ENDIF + + ! ! at end of run output max Cu and Cv and close ascii file + IF( kt == nitend .AND. lwp ) THEN + ! to ascii file + WRITE(numcfl,*) '******************************************' + WRITE(numcfl,FMT='(3x,a12,6x,f7.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cu', rCu_max, nCu_loc(1), nCu_loc(2), nCu_loc(3) + WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', rDt/rCu_max + WRITE(numcfl,*) '******************************************' + WRITE(numcfl,FMT='(3x,a12,6x,f7.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cv', rCv_max, nCv_loc(1), nCv_loc(2), nCv_loc(3) + WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', rDt/rCv_max + WRITE(numcfl,*) '******************************************' + WRITE(numcfl,FMT='(3x,a12,6x,f7.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cw', rCw_max, nCw_loc(1), nCw_loc(2), nCw_loc(3) + WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', rDt/rCw_max + CLOSE( numcfl ) + ! + ! to ocean output + WRITE(numout,*) + WRITE(numout,*) 'dia_cfl : Maximum Courant number information for the run ' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) ' Max Cu = ', rCu_max, ' at (i,j,k) = (',nCu_loc(1),nCu_loc(2),nCu_loc(3),') => dt/C = ', rDt/rCu_max + WRITE(numout,*) ' Max Cv = ', rCv_max, ' at (i,j,k) = (',nCv_loc(1),nCv_loc(2),nCv_loc(3),') => dt/C = ', rDt/rCv_max + WRITE(numout,*) ' Max Cw = ', rCw_max, ' at (i,j,k) = (',nCw_loc(1),nCw_loc(2),nCw_loc(3),') => dt/C = ', rDt/rCw_max + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dia_cfl') + ! + END SUBROUTINE dia_cfl + + + SUBROUTINE dia_cfl_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_cfl_init *** + !! + !! ** Purpose : create output file, initialise arrays + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_cfl : Outputting CFL diagnostics to ',TRIM(clname), ' file' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) + ! + ! create output ascii file + CALL ctl_opn( numcfl, clname, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', 1, numout, lwp, 1 ) + WRITE(numcfl,*) 'Timestep Direction Max C i j k' + WRITE(numcfl,*) '******************************************' + ENDIF + ! + rCu_max = 0._wp + rCv_max = 0._wp + rCw_max = 0._wp + ! + END SUBROUTINE dia_cfl_init + + !!====================================================================== +END MODULE diacfl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diadct.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diadct.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f7dc782e7728b4978d11646d3b1774faadd20cfc --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diadct.f90 @@ -0,0 +1,1213 @@ + + + + + + + + + + + + + +MODULE diadct + !!====================================================================== + !! *** MODULE diadct *** + !! Ocean diagnostics: Compute the transport trough a sec. + !!====================================================================== + !! History : OPA ! 02/1999 (Y Drillet) original code + !! ! 10/2001 (Y Drillet, R Bourdalle Badie) + !! NEMO 1.0 ! 10/2005 (M Laborie) F90 + !! 3.0 ! 04/2007 (G Garric) Ice sections + !! - ! 04/2007 (C Bricaud) test on sec%nb_point, initialisation of ztransp1,ztransp2,... + !! 3.4 ! 09/2011 (C Bricaud) + !!---------------------------------------------------------------------- + !! ==>> CAUTION: does not work with agrif + !!---------------------------------------------------------------------- + !! dia_dct : Compute the transport through a sec. + !! dia_dct_init : Read namelist. + !! readsec : Read sections description and pathway + !! removepoints : Remove points which are common to 2 procs + !! transport : Compute transport for each sections + !! dia_dct_wri : Write tranports results in ascii files + !! interp : Compute temperature/salinity/density at U-point or V-point + !! + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE in_out_manager ! I/O manager + USE daymod ! calendar + USE dianam ! build name of file + USE lib_mpp ! distributed memory computing library + USE domvvl + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_dct ! routine called by step.F90 + PUBLIC dia_dct_init ! routine called by nemogcm.F90 + + ! !!** namelist variables ** + LOGICAL, PUBLIC :: ln_diadct !: Calculate transport thru a section or not + INTEGER :: nn_dct ! Frequency of computation + INTEGER :: nn_dctwri ! Frequency of output + INTEGER :: nn_secdebug ! Number of the section to debug + + INTEGER, PARAMETER :: nb_class_max = 10 + INTEGER, PARAMETER :: nb_sec_max = 150 + INTEGER, PARAMETER :: nb_point_max = 2000 + INTEGER, PARAMETER :: nb_type_class = 10 + INTEGER, PARAMETER :: nb_3d_vars = 3 + INTEGER, PARAMETER :: nb_2d_vars = 2 + INTEGER :: nb_sec + + TYPE POINT_SECTION + INTEGER :: I,J + END TYPE POINT_SECTION + + TYPE COORD_SECTION + REAL(wp) :: lon,lat + END TYPE COORD_SECTION + + TYPE SECTION + CHARACTER(len=60) :: name ! name of the sec + LOGICAL :: llstrpond ! true if you want the computation of salt and heat transports + LOGICAL :: ll_ice_section ! ice surface and ice volume computation + LOGICAL :: ll_date_line ! = T if the section crosses the date-line + TYPE(COORD_SECTION), DIMENSION(2) :: coordSec ! longitude and latitude of the extremities of the sec + INTEGER :: nb_class ! number of boundaries for density classes + INTEGER, DIMENSION(nb_point_max) :: direction ! vector direction of the point in the section + CHARACTER(len=40),DIMENSION(nb_class_max) :: classname ! characteristics of the class + REAL(wp), DIMENSION(nb_class_max) :: zsigi ! in-situ density classes (99 if you don't want) + REAL(wp), DIMENSION(nb_class_max) :: zsigp ! potential density classes (99 if you don't want) + REAL(wp), DIMENSION(nb_class_max) :: zsal ! salinity classes (99 if you don't want) + REAL(wp), DIMENSION(nb_class_max) :: ztem ! temperature classes(99 if you don't want) + REAL(wp), DIMENSION(nb_class_max) :: zlay ! level classes (99 if you don't want) + REAL(wp), DIMENSION(nb_type_class,nb_class_max) :: transport ! transport output + REAL(wp) :: slopeSection ! slope of the section + INTEGER :: nb_point ! number of points in the section + TYPE(POINT_SECTION),DIMENSION(nb_point_max) :: listPoint ! list of points in the sections + END TYPE SECTION + + TYPE(SECTION),DIMENSION(nb_sec_max) :: secs ! Array of sections + + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: transports_3d + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: transports_2d + + + !! * Substitutions + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diadct.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + INTEGER FUNCTION diadct_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION diadct_alloc *** + !!---------------------------------------------------------------------- + + ALLOCATE( transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), & + & transports_2d(nb_2d_vars,nb_sec_max,nb_point_max) , STAT=diadct_alloc ) + + CALL mpp_sum( 'diadct', diadct_alloc ) + IF( diadct_alloc /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) + + END FUNCTION diadct_alloc + + SUBROUTINE dia_dct_init + !!--------------------------------------------------------------------- + !! *** ROUTINE diadct *** + !! + !! ** Purpose: Read the namelist parameters + !! Open output files + !! + !!--------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/nam_diadct/ln_diadct, nn_dct, nn_dctwri, nn_secdebug + !!--------------------------------------------------------------------- + + READ ( numnam_ref, nam_diadct, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diadct in reference namelist' ) + + READ ( numnam_cfg, nam_diadct, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diadct in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_diadct ) + + IF( lwp ) THEN + WRITE(numout,*) " " + WRITE(numout,*) "diadct_init: compute transports through sections " + WRITE(numout,*) "~~~~~~~~~~~~~~~~~~~~~" + WRITE(numout,*) " Calculate transport thru sections: ln_diadct = ", ln_diadct + WRITE(numout,*) " Frequency of computation: nn_dct = ", nn_dct + WRITE(numout,*) " Frequency of write: nn_dctwri = ", nn_dctwri + + IF ( nn_secdebug .GE. 1 .AND. nn_secdebug .LE. nb_sec_max )THEN + WRITE(numout,*)" Debug section number: ", nn_secdebug + ELSE IF ( nn_secdebug == 0 )THEN ; WRITE(numout,*)" No section to debug" + ELSE IF ( nn_secdebug == -1 )THEN ; WRITE(numout,*)" Debug all sections" + ELSE ; WRITE(numout,*)" Wrong value for nn_secdebug : ",nn_secdebug + ENDIF + ENDIF + + IF( ln_diadct ) THEN + ! control + IF(nn_dct .GE. nn_dctwri .AND. MOD(nn_dct,nn_dctwri) .NE. 0) & + & CALL ctl_stop( 'diadct: nn_dct should be smaller and a multiple of nn_dctwri' ) + + ! allocate dia_dct arrays + IF( diadct_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) + + !Read section_ijglobal.diadct + CALL readsec + + !open output file + IF( lwm ) THEN + CALL ctl_opn( numdct_vol, 'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + CALL ctl_opn( numdct_heat, 'heat_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + CALL ctl_opn( numdct_salt, 'salt_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + ENDIF + + ! Initialise arrays to zero + transports_3d(:,:,:,:)=0.0 + transports_2d(:,:,:) =0.0 + ! + ENDIF + ! + END SUBROUTINE dia_dct_init + + + SUBROUTINE dia_dct( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE diadct *** + !! + !! Purpose :: Compute section transports and write it in numdct files + !! + !! Method :: All arrays initialised to zero in dct_init + !! Each nn_dct time step call subroutine 'transports' for + !! each section to sum the transports over each grid cell. + !! Each nn_dctwri time step: + !! Divide the arrays by the number of summations to gain + !! an average value + !! Call dia_dct_sum to sum relevant grid boxes to obtain + !! totals for each class (density, depth, temp or sal) + !! Call dia_dct_wri to write the transports into file + !! Reinitialise all relevant arrays to zero + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: jsec ! loop on sections + INTEGER :: itotal ! nb_sec_max*nb_type_class*nb_class_max + LOGICAL :: lldebug =.FALSE. ! debug a section + INTEGER , DIMENSION(1) :: ish ! work array for mpp_sum + INTEGER , DIMENSION(3) :: ish2 ! " + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zwork ! " + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:):: zsum ! " + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_dct') + + IF( lk_mpp )THEN + itotal = nb_sec_max*nb_type_class*nb_class_max + ALLOCATE( zwork(itotal) , zsum(nb_sec_max,nb_type_class,nb_class_max) ) + ENDIF + + ! Initialise arrays + zwork(:) = 0.0 + zsum(:,:,:) = 0.0 + + IF( lwp .AND. kt==nit000+nn_dct-1 ) THEN + WRITE(numout,*) " " + WRITE(numout,*) "diadct: compute transport" + WRITE(numout,*) "~~~~~~~~~~~~~~~~~~~~~~~~~" + WRITE(numout,*) "nb_sec = ",nb_sec + ENDIF + + + ! Compute transport and write only at nn_dctwri + IF( MOD(kt,nn_dct)==0 ) THEN + + DO jsec=1,nb_sec + + !debug this section computing ? + lldebug=.FALSE. + IF( (jsec==nn_secdebug .OR. nn_secdebug==-1) .AND. kt==nit000+nn_dct-1 ) lldebug=.TRUE. + + !Compute transport through section + CALL transport(Kmm,secs(jsec),lldebug,jsec) + + ENDDO + + IF( MOD(kt,nn_dctwri)==0 )THEN + + IF( kt==nit000+nn_dctwri-1 )WRITE(numout,*)" diadct: average transports and write at kt = ",kt + + !! divide arrays by nn_dctwri/nn_dct to obtain average + transports_3d(:,:,:,:)=transports_3d(:,:,:,:)/(nn_dctwri/nn_dct) + transports_2d(:,:,:) =transports_2d(:,:,:) /(nn_dctwri/nn_dct) + + ! Sum over each class + DO jsec=1,nb_sec + CALL dia_dct_sum(Kmm,secs(jsec),jsec) + ENDDO + + !Sum on all procs + IF( lk_mpp )THEN + ish(1) = nb_sec_max*nb_type_class*nb_class_max + ish2 = (/nb_sec_max,nb_type_class,nb_class_max/) + DO jsec=1,nb_sec ; zsum(jsec,:,:) = secs(jsec)%transport(:,:) ; ENDDO + zwork(:)= RESHAPE(zsum(:,:,:), ish ) + CALL mpp_sum('diadct', zwork, ish(1)) + zsum(:,:,:)= RESHAPE(zwork,ish2) + DO jsec=1,nb_sec ; secs(jsec)%transport(:,:) = zsum(jsec,:,:) ; ENDDO + ENDIF + + !Write the transport + DO jsec=1,nb_sec + + IF( lwm )CALL dia_dct_wri(kt,jsec,secs(jsec)) + + !nullify transports values after writing + transports_3d(:,jsec,:,:)=0. + transports_2d(:,jsec,: )=0. + secs(jsec)%transport(:,:)=0. + + ENDDO + + ENDIF + + ENDIF + + IF( lk_mpp )THEN + itotal = nb_sec_max*nb_type_class*nb_class_max + DEALLOCATE( zwork , zsum ) + ENDIF + + IF( ln_timing ) CALL timing_stop('dia_dct') + ! + END SUBROUTINE dia_dct + + + SUBROUTINE readsec + !!--------------------------------------------------------------------- + !! *** ROUTINE readsec *** + !! + !! ** Purpose: + !! Read a binary file(section_ijglobal.diadct) + !! generated by the tools "NEMOGCM/TOOLS/SECTIONS_DIADCT" + !! + !! + !!--------------------------------------------------------------------- + INTEGER :: iptglo , iptloc ! Global and local number of points for a section + INTEGER :: isec, iiglo, ijglo, iiloc, ijloc,iost,i1 ,i2 ! temporary integer + INTEGER :: jsec, jpt ! dummy loop indices + INTEGER, DIMENSION(2) :: icoord + LOGICAL :: llbon, lldebug ! local logical + CHARACTER(len=160) :: clname ! filename + CHARACTER(len=200) :: cltmp + CHARACTER(len=200) :: clformat !automatic format + TYPE(POINT_SECTION),DIMENSION(nb_point_max) ::coordtemp !contains listpoints coordinates read in the file + INTEGER, DIMENSION(nb_point_max) :: directemp !contains listpoints directions read in the files + !!------------------------------------------------------------------------------------- + + !open input file + !--------------- + CALL ctl_opn( numdct_in, 'section_ijglobal.diadct', 'OLD', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + + !--------------- + !Read input file + !--------------- + + DO jsec=1,nb_sec_max !loop on the nb_sec sections + + IF ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) & + & WRITE(numout,*)'debuging for section number: ',jsec + + !initialization + !--------------- + secs(jsec)%name='' + secs(jsec)%llstrpond = .FALSE. ; secs(jsec)%ll_ice_section = .FALSE. + secs(jsec)%ll_date_line = .FALSE. ; secs(jsec)%nb_class = 0 + secs(jsec)%zsigi = 99._wp ; secs(jsec)%zsigp = 99._wp + secs(jsec)%zsal = 99._wp ; secs(jsec)%ztem = 99._wp + secs(jsec)%zlay = 99._wp + secs(jsec)%transport = 0._wp ; secs(jsec)%nb_point = 0 + + !read section's number / name / computing choices / classes / slopeSection / points number + !----------------------------------------------------------------------------------------- + READ(numdct_in,iostat=iost)isec + IF (iost .NE. 0 )EXIT !end of file + WRITE(cltmp,'(a,i4.4,a,i4.4)')'diadct: read sections : Problem of section number: isec= ',isec,' and jsec= ',jsec + IF( jsec .NE. isec ) CALL ctl_stop( cltmp ) + + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )WRITE(numout,*)"isec ",isec + + READ(numdct_in)secs(jsec)%name + READ(numdct_in)secs(jsec)%llstrpond + READ(numdct_in)secs(jsec)%ll_ice_section + READ(numdct_in)secs(jsec)%ll_date_line + READ(numdct_in)secs(jsec)%coordSec + READ(numdct_in)secs(jsec)%nb_class + READ(numdct_in)secs(jsec)%zsigi + READ(numdct_in)secs(jsec)%zsigp + READ(numdct_in)secs(jsec)%zsal + READ(numdct_in)secs(jsec)%ztem + READ(numdct_in)secs(jsec)%zlay + READ(numdct_in)secs(jsec)%slopeSection + READ(numdct_in)iptglo + + !debug + !----- + + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN + + WRITE(clformat,'(a,i2,a)') '(A40,', nb_class_max,'(f8.3,1X))' + + WRITE(numout,*) " Section name : ",TRIM(secs(jsec)%name) + WRITE(numout,*) " Compute heat and salt transport ? ",secs(jsec)%llstrpond + WRITE(numout,*) " Compute ice transport ? ",secs(jsec)%ll_ice_section + WRITE(numout,*) " Section crosses date-line ? ",secs(jsec)%ll_date_line + WRITE(numout,*) " Slope section : ",secs(jsec)%slopeSection + WRITE(numout,*) " Number of points in the section: ",iptglo + WRITE(numout,*) " Number of classes ",secs(jsec)%nb_class + WRITE(numout,clformat)" Insitu density classes : ",secs(jsec)%zsigi + WRITE(numout,clformat)" Potential density classes : ",secs(jsec)%zsigp + WRITE(numout,clformat)" Salinity classes : ",secs(jsec)%zsal + WRITE(numout,clformat)" Temperature classes : ",secs(jsec)%ztem + WRITE(numout,clformat)" Depth classes : ",secs(jsec)%zlay + ENDIF + + IF( iptglo /= 0 )THEN + + !read points'coordinates and directions + !-------------------------------------- + coordtemp(:) = POINT_SECTION(0,0) !list of points read + directemp(:) = 0 !value of directions of each points + DO jpt=1,iptglo + READ(numdct_in) i1, i2 + coordtemp(jpt)%I = i1 + coordtemp(jpt)%J = i2 + ENDDO + READ(numdct_in) directemp(1:iptglo) + + !debug + !----- + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN + WRITE(numout,*)" List of points in global domain:" + DO jpt=1,iptglo + WRITE(numout,*)' # I J ',jpt,coordtemp(jpt),directemp(jpt) + ENDDO + ENDIF + + !Now each proc selects only points that are in its domain: + !-------------------------------------------------------- + iptloc = 0 ! initialize number of points selected + DO jpt = 1, iptglo ! loop on listpoint read in the file + ! + iiglo=coordtemp(jpt)%I ! global coordinates of the point + ijglo=coordtemp(jpt)%J ! " + + IF( iiglo==jpiglo .AND. nimpp==1 ) iiglo = 2 !!gm BUG: Hard coded periodicity ! + + iiloc=iiglo-nimpp+1 ! local coordinates of the point + ijloc=ijglo-njmpp+1 ! " + + !verify if the point is on the local domain:(1,Nie0)*(1,Nje0) + IF( iiloc >= 1 .AND. iiloc <= Nie0 .AND. & + ijloc >= 1 .AND. ijloc <= Nje0 )THEN + iptloc = iptloc + 1 ! count local points + secs(jsec)%listPoint(iptloc) = POINT_SECTION(mi0(iiglo),mj0(ijglo)) ! store local coordinates + secs(jsec)%direction(iptloc) = directemp(jpt) ! store local direction + ENDIF + ! + END DO + + secs(jsec)%nb_point=iptloc !store number of section's points + + !debug + !----- + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN + WRITE(numout,*)" List of points selected by the proc:" + DO jpt = 1,iptloc + iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1 + ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1 + WRITE(numout,*)' # I J : ',iiglo,ijglo + ENDDO + ENDIF + + IF(jsec==nn_secdebug .AND. secs(jsec)%nb_point .NE. 0)THEN + DO jpt = 1,iptloc + iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1 + ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1 + ENDDO + ENDIF + + !remove redundant points between processors + !------------------------------------------ + lldebug = .FALSE. ; IF ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) lldebug = .TRUE. + IF( iptloc .NE. 0 )THEN + CALL removepoints(secs(jsec),'I','top_list',lldebug) + CALL removepoints(secs(jsec),'I','bot_list',lldebug) + CALL removepoints(secs(jsec),'J','top_list',lldebug) + CALL removepoints(secs(jsec),'J','bot_list',lldebug) + ENDIF + IF(jsec==nn_secdebug .AND. secs(jsec)%nb_point .NE. 0)THEN + DO jpt = 1,secs(jsec)%nb_point + iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1 + ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1 + ENDDO + ENDIF + + !debug + !----- + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN + WRITE(numout,*)" List of points after removepoints:" + iptloc = secs(jsec)%nb_point + DO jpt = 1,iptloc + iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1 + ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1 + WRITE(numout,*)' # I J : ',iiglo,ijglo + CALL FLUSH(numout) + ENDDO + ENDIF + + ELSE ! iptglo = 0 + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )& + WRITE(numout,*)' No points for this section.' + ENDIF + + ENDDO !end of the loop on jsec + + nb_sec = jsec-1 !number of section read in the file + ! + END SUBROUTINE readsec + + + SUBROUTINE removepoints(sec,cdind,cdextr,ld_debug) + !!--------------------------------------------------------------------------- + !! *** function removepoints + !! + !! ** Purpose :: Remove points which are common to 2 procs + !! + !---------------------------------------------------------------------------- + !! * arguments + TYPE(SECTION),INTENT(INOUT) :: sec + CHARACTER(len=1),INTENT(IN) :: cdind ! = 'I'/'J' + CHARACTER(len=8),INTENT(IN) :: cdextr ! = 'top_list'/'bot_list' + LOGICAL,INTENT(IN) :: ld_debug + + !! * Local variables + INTEGER :: iextr ,& !extremity of listpoint that we verify + iind ,& !coord of listpoint that we verify + itest ,& !indice value of the side of the domain + !where points could be redundant + isgn ,& ! isgn= 1 : scan listpoint from start to end + ! isgn=-1 : scan listpoint from end to start + istart,iend !first and last points selected in listpoint + INTEGER :: jpoint !loop on list points + INTEGER, DIMENSION(nb_point_max) :: idirec !contains temporary sec%direction + INTEGER, DIMENSION(2,nb_point_max) :: icoord !contains temporary sec%listpoint + !---------------------------------------------------------------------------- + ! + IF( ld_debug )WRITE(numout,*)' -------------------------' + IF( ld_debug )WRITE(numout,*)' removepoints in listpoint' + + !iextr=extremity of list_point that we verify + IF ( cdextr=='bot_list' )THEN ; iextr=1 ; isgn=1 + ELSE IF ( cdextr=='top_list' )THEN ; iextr=sec%nb_point ; isgn=-1 + ELSE ; CALL ctl_stop("removepoints :Wrong value for cdextr") + ENDIF + + !which coordinate shall we verify ? + IF ( cdind=='I' )THEN ; itest=Nie0 ; iind=1 + ELSE IF ( cdind=='J' )THEN ; itest=Nje0 ; iind=2 + ELSE ; CALL ctl_stop("removepoints :Wrong value for cdind") + ENDIF + + IF( ld_debug )THEN + WRITE(numout,*)' case: coord/list extr/domain side' + WRITE(numout,*)' ', cdind,' ',cdextr,' ',itest + WRITE(numout,*)' Actual number of points: ',sec%nb_point + ENDIF + + icoord(1,1:nb_point_max) = sec%listPoint%I + icoord(2,1:nb_point_max) = sec%listPoint%J + idirec = sec%direction + sec%listPoint = POINT_SECTION(0,0) + sec%direction = 0 + + jpoint=iextr+isgn + DO WHILE( jpoint .GE. 1 .AND. jpoint .LE. sec%nb_point ) + IF( icoord( iind,jpoint-isgn ) == itest .AND. icoord( iind,jpoint ) == itest )THEN ; jpoint=jpoint+isgn + ELSE ; EXIT + ENDIF + ENDDO + + IF( cdextr=='bot_list')THEN ; istart=jpoint-1 ; iend=sec%nb_point + ELSE ; istart=1 ; iend=jpoint+1 + ENDIF + + sec%listPoint(1:1+iend-istart)%I = icoord(1,istart:iend) + sec%listPoint(1:1+iend-istart)%J = icoord(2,istart:iend) + sec%direction(1:1+iend-istart) = idirec(istart:iend) + sec%nb_point = iend-istart+1 + + IF( ld_debug )THEN + WRITE(numout,*)' Number of points after removepoints :',sec%nb_point + WRITE(numout,*)' sec%direction after removepoints :',sec%direction(1:sec%nb_point) + ENDIF + ! + END SUBROUTINE removepoints + + + SUBROUTINE transport(Kmm,sec,ld_debug,jsec) + !!------------------------------------------------------------------------------------------- + !! *** ROUTINE transport *** + !! + !! Purpose :: Compute the transport for each point in a section + !! + !! Method :: Loop over each segment, and each vertical level and add the transport + !! Be aware : + !! One section is a sum of segments + !! One segment is defined by 2 consecutive points in sec%listPoint + !! All points of sec%listPoint are positioned on the F-point of the cell + !! + !! There are two loops: + !! loop on the segment between 2 nodes + !! loop on the level jk !! + !! + !! Output :: Arrays containing the volume,density,heat,salt transports for each i + !! point in a section, summed over each nn_dct. + !! + !!------------------------------------------------------------------------------------------- + INTEGER ,INTENT(IN) :: Kmm ! time level index + TYPE(SECTION),INTENT(INOUT) :: sec + LOGICAL ,INTENT(IN) :: ld_debug + INTEGER ,INTENT(IN) :: jsec ! numeric identifier of section + ! + INTEGER :: jk, jseg, jclass,jl, isgnu, isgnv ! loop on level/segment/classes/ice categories + REAL(wp):: zumid, zvmid, zumid_ice, zvmid_ice ! U/V ocean & ice velocity on a cell segment + REAL(wp):: zTnorm ! transport of velocity through one cell's sides + REAL(wp):: ztn, zsn, zrhoi, zrhop, zsshn, zdep ! temperature/salinity/potential density/ssh/depth at u/v point + TYPE(POINT_SECTION) :: k + !!-------------------------------------------------------- + ! + IF( ld_debug )WRITE(numout,*)' Compute transport' + + !---------------------------! + ! COMPUTE TRANSPORT ! + !---------------------------! + IF(sec%nb_point .NE. 0)THEN + + !---------------------------------------------------------------------------------------------------- + !Compute sign for velocities: + ! + !convention: + ! non horizontal section: direction + is toward left hand of section + ! horizontal section: direction + is toward north of section + ! + ! + ! slopeSection < 0 slopeSection > 0 slopeSection=inf slopeSection=0 + ! ---------------- ----------------- --------------- -------------- + ! + ! isgnv=1 direction + + ! ______ _____ ______ + ! | //| | | direction + + ! | isgnu=1 // | |isgnu=1 |isgnu=1 /| ! |_______ // ______| \\ | ---\ | + ! | | isgnv=-1 \\ | | ---/ direction + ____________ + ! | | __\\| | + ! | | direction + | isgnv=1 + ! + !---------------------------------------------------------------------------------------------------- + isgnu = 1 + IF( sec%slopeSection .GT. 0 ) THEN ; isgnv = -1 + ELSE ; isgnv = 1 + ENDIF + IF( sec%slopeSection .GE. 9999. ) isgnv = 1 + + IF( ld_debug )write(numout,*)"sec%slopeSection isgnu isgnv ",sec%slopeSection,isgnu,isgnv + + !--------------------------------------! + ! LOOP ON THE SEGMENT BETWEEN 2 NODES ! + !--------------------------------------! + DO jseg=1,MAX(sec%nb_point-1,0) + + !------------------------------------------------------------------------------------------- + ! Select the appropriate coordinate for computing the velocity of the segment + ! + ! CASE(0) Case (2) + ! ------- -------- + ! listPoint(jseg) listPoint(jseg+1) listPoint(jseg) F(i,j) + ! F(i,j)----------V(i+1,j)-------F(i+1,j) | + ! | + ! | + ! | + ! Case (3) U(i,j) + ! -------- | + ! | + ! listPoint(jseg+1) F(i,j+1) | + ! | | + ! | | + ! | listPoint(jseg+1) F(i,j-1) + ! | + ! | + ! U(i,j+1) + ! | Case(1) + ! | ------ + ! | + ! | listPoint(jseg+1) listPoint(jseg) + ! | F(i-1,j)-----------V(i,j) -------f(jseg) + ! listPoint(jseg) F(i,j) + ! + !------------------------------------------------------------------------------------------- + + SELECT CASE( sec%direction(jseg) ) + CASE(0) ; k = sec%listPoint(jseg) + CASE(1) ; k = POINT_SECTION(sec%listPoint(jseg)%I+1,sec%listPoint(jseg)%J) + CASE(2) ; k = sec%listPoint(jseg) + CASE(3) ; k = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J+1) + END SELECT + + !---------------------------| + ! LOOP ON THE LEVEL | + !---------------------------| + DO jk = 1, mbkt(k%I,k%J) !Sum of the transport on the vertical + ! ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point + SELECT CASE( sec%direction(jseg) ) + CASE(0,1) + ztn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_tem,Kmm) ) + zsn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_sal,Kmm) ) + zrhop = interp(Kmm,k%I,k%J,jk,'V',rhop) + zrhoi =interp(Kmm,k%I,k%J,jk,'V',REAL(rhd*rho0+rho0,dp)) + zsshn = 0.5*( ssh(k%I,k%J,Kmm) + ssh(k%I,k%J+1,Kmm) ) * vmask(k%I,k%J,1) + CASE(2,3) + ztn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_tem,Kmm) ) + zsn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_sal,Kmm) ) + zrhop = interp(Kmm,k%I,k%J,jk,'U',rhop) + zrhoi =interp(Kmm,k%I,k%J,jk,'U',REAL(rhd*rho0+rho0,dp)) + zsshn = 0.5*( ssh(k%I,k%J,Kmm) + ssh(k%I+1,k%J,Kmm) ) * umask(k%I,k%J,1) + END SELECT + ! + zdep= (gdept_0(k%I,k%J,jk)*(1._wp+r3t(k%I,k%J,Kmm))) + + SELECT CASE( sec%direction(jseg) ) !compute velocity with the correct direction + CASE(0,1) + zumid=0._wp + zvmid=isgnv*vv(k%I,k%J,jk,Kmm)*vmask(k%I,k%J,jk) + CASE(2,3) + zumid=isgnu*uu(k%I,k%J,jk,Kmm)*umask(k%I,k%J,jk) + zvmid=0._wp + END SELECT + + !zTnorm=transport through one cell; + !velocity* cell's length * cell's thickness + zTnorm = zumid*e2u(k%I,k%J) * (e3u_0(k%I,k%J,jk)*(1._wp+r3u(k%I,k%J,Kmm)*umask(k%I,k%J,jk))) & + & + zvmid*e1v(k%I,k%J) * (e3v_0(k%I,k%J,jk)*(1._wp+r3v(k%I,k%J,Kmm)*vmask(k%I,k%J,jk))) + +!!gm THIS is WRONG no transport due to ssh in linear free surface case !!!!! + IF( ln_linssh ) THEN !add transport due to free surface + IF( jk==1 ) THEN + zTnorm = zTnorm + zumid* e2u(k%I,k%J) * zsshn * umask(k%I,k%J,jk) & + & + zvmid* e1v(k%I,k%J) * zsshn * vmask(k%I,k%J,jk) + ENDIF + ENDIF +!!gm end + !COMPUTE TRANSPORT + + transports_3d(1,jsec,jseg,jk) = transports_3d(1,jsec,jseg,jk) + zTnorm + + IF( sec%llstrpond ) THEN + transports_3d(2,jsec,jseg,jk) = transports_3d(2,jsec,jseg,jk) + zTnorm * ztn * zrhop * rcp + transports_3d(3,jsec,jseg,jk) = transports_3d(3,jsec,jseg,jk) + zTnorm * zsn * zrhop * 0.001 + ENDIF + + END DO !end of loop on the level + + + END DO !end of loop on the segment + + ENDIF !end of sec%nb_point =0 case + ! + END SUBROUTINE transport + + + SUBROUTINE dia_dct_sum(Kmm,sec,jsec) + !!------------------------------------------------------------- + !! Purpose: Average the transport over nn_dctwri time steps + !! and sum over the density/salinity/temperature/depth classes + !! + !! Method: Sum over relevant grid cells to obtain values + !! for each class + !! There are several loops: + !! loop on the segment between 2 nodes + !! loop on the level jk + !! loop on the density/temperature/salinity/level classes + !! test on the density/temperature/salinity/level + !! + !! Note: Transport through a given section is equal to the sum of transports + !! computed on each proc. + !! On each proc,transport is equal to the sum of transport computed through + !! segments linking each point of sec%listPoint with the next one. + !! + !!------------------------------------------------------------- + INTEGER ,INTENT(IN) :: Kmm ! time level index + TYPE(SECTION),INTENT(INOUT) :: sec + INTEGER ,INTENT(IN) :: jsec ! numeric identifier of section + + TYPE(POINT_SECTION) :: k + INTEGER :: jk,jseg,jclass ! dummy variables for looping on level/segment/classes + REAL(wp) :: ztn, zsn, zrhoi, zrhop, zsshn, zdep ! temperature/salinity/ssh/potential density /depth at u/v point + !!------------------------------------------------------------- + + !! Sum the relevant segments to obtain values for each class + IF(sec%nb_point .NE. 0)THEN + + !--------------------------------------! + ! LOOP ON THE SEGMENT BETWEEN 2 NODES ! + !--------------------------------------! + DO jseg=1,MAX(sec%nb_point-1,0) + + !------------------------------------------------------------------------------------------- + ! Select the appropriate coordinate for computing the velocity of the segment + ! + ! CASE(0) Case (2) + ! ------- -------- + ! listPoint(jseg) listPoint(jseg+1) listPoint(jseg) F(i,j) + ! F(i,j)----------V(i+1,j)-------F(i+1,j) | + ! | + ! | + ! | + ! Case (3) U(i,j) + ! -------- | + ! | + ! listPoint(jseg+1) F(i,j+1) | + ! | | + ! | | + ! | listPoint(jseg+1) F(i,j-1) + ! | + ! | + ! U(i,j+1) + ! | Case(1) + ! | ------ + ! | + ! | listPoint(jseg+1) listPoint(jseg) + ! | F(i-1,j)-----------V(i,j) -------f(jseg) + ! listPoint(jseg) F(i,j) + ! + !------------------------------------------------------------------------------------------- + + SELECT CASE( sec%direction(jseg) ) + CASE(0) ; k = sec%listPoint(jseg) + CASE(1) ; k = POINT_SECTION(sec%listPoint(jseg)%I+1,sec%listPoint(jseg)%J) + CASE(2) ; k = sec%listPoint(jseg) + CASE(3) ; k = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J+1) + END SELECT + + !---------------------------| + ! LOOP ON THE LEVEL | + !---------------------------| + !Sum of the transport on the vertical + DO jk=1,mbkt(k%I,k%J) + + ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point + SELECT CASE( sec%direction(jseg) ) + CASE(0,1) + ztn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_tem,Kmm) ) + zsn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_sal,Kmm) ) + zrhop = interp(Kmm,k%I,k%J,jk,'V',rhop) + zrhoi =interp(Kmm,k%I,k%J,jk,'V',REAL(rhd*rho0+rho0,dp)) + + CASE(2,3) + ztn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_tem,Kmm) ) + zsn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_sal,Kmm) ) + zrhop = interp(Kmm,k%I,k%J,jk,'U',rhop) + zrhoi =interp(Kmm,k%I,k%J,jk,'U',REAL(rhd*rho0+rho0,dp)) + zsshn = 0.5*( ssh(k%I,k%J,Kmm) + ssh(k%I+1,k%J,Kmm) ) * umask(k%I,k%J,1) + END SELECT + + zdep= (gdept_0(k%I,k%J,jk)*(1._wp+r3t(k%I,k%J,Kmm))) + + !------------------------------- + ! LOOP ON THE DENSITY CLASSES | + !------------------------------- + !The computation is made for each density/temperature/salinity/depth class + DO jclass=1,MAX(1,sec%nb_class-1) + + !----------------------------------------------! + !TEST ON THE DENSITY/SALINITY/TEMPERATURE/LEVEL! + !----------------------------------------------! + + IF ( ( & + ((( zrhop .GE. (sec%zsigp(jclass)+1000. )) .AND. & + ( zrhop .LE. (sec%zsigp(jclass+1)+1000. ))) .OR. & + ( sec%zsigp(jclass) .EQ. 99.)) .AND. & + + ((( zrhoi .GE. (sec%zsigi(jclass) + 1000. )) .AND. & + ( zrhoi .LE. (sec%zsigi(jclass+1)+1000. ))) .OR. & + ( sec%zsigi(jclass) .EQ. 99.)) .AND. & + + ((( zsn .GT. sec%zsal(jclass)) .AND. & + ( zsn .LE. sec%zsal(jclass+1))) .OR. & + ( sec%zsal(jclass) .EQ. 99.)) .AND. & + + ((( ztn .GE. sec%ztem(jclass)) .AND. & + ( ztn .LE. sec%ztem(jclass+1))) .OR. & + ( sec%ztem(jclass) .EQ.99.)) .AND. & + + ((( zdep .GE. sec%zlay(jclass)) .AND. & + ( zdep .LE. sec%zlay(jclass+1))) .OR. & + ( sec%zlay(jclass) .EQ. 99. )) & + )) THEN + + !SUM THE TRANSPORTS FOR EACH CLASSES FOR THE POSITIVE AND NEGATIVE DIRECTIONS + !---------------------------------------------------------------------------- + IF (transports_3d(1,jsec,jseg,jk) .GE. 0.0) THEN + sec%transport(1,jclass) = sec%transport(1,jclass)+transports_3d(1,jsec,jseg,jk)*1.E-6 + ELSE + sec%transport(2,jclass) = sec%transport(2,jclass)+transports_3d(1,jsec,jseg,jk)*1.E-6 + ENDIF + IF( sec%llstrpond )THEN + + IF ( transports_3d(2,jsec,jseg,jk) .GE. 0.0 ) THEN + sec%transport(3,jclass) = sec%transport(3,jclass)+transports_3d(2,jsec,jseg,jk) + ELSE + sec%transport(4,jclass) = sec%transport(4,jclass)+transports_3d(2,jsec,jseg,jk) + ENDIF + + IF ( transports_3d(3,jsec,jseg,jk) .GE. 0.0 ) THEN + sec%transport(5,jclass) = sec%transport(5,jclass)+transports_3d(3,jsec,jseg,jk) + ELSE + sec%transport(6,jclass) = sec%transport(6,jclass)+transports_3d(3,jsec,jseg,jk) + ENDIF + + ELSE + sec%transport( 3,jclass) = 0._wp + sec%transport( 4,jclass) = 0._wp + sec%transport( 5,jclass) = 0._wp + sec%transport( 6,jclass) = 0._wp + ENDIF + + ENDIF ! end of test if point is in class + + END DO ! end of loop on the classes + + END DO ! loop over jk + + + END DO !end of loop on the segment + + ELSE !if sec%nb_point =0 + sec%transport(1:2,:)=0. + IF (sec%llstrpond) sec%transport(3:6,:)=0. + IF (sec%ll_ice_section) sec%transport(7:10,:)=0. + ENDIF !end of sec%nb_point =0 case + + END SUBROUTINE dia_dct_sum + + + SUBROUTINE dia_dct_wri(kt,ksec,sec) + !!------------------------------------------------------------- + !! Write transport output in numdct + !! + !! Purpose: Write transports in ascii files + !! + !! Method: + !! 1. Write volume transports in "volume_transport" + !! Unit: Sv : area * Velocity / 1.e6 + !! + !! 2. Write heat transports in "heat_transport" + !! Unit: Peta W : area * Velocity * T * rhop * Cp * 1.e-15 + !! + !! 3. Write salt transports in "salt_transport" + !! Unit: 10^9 Kg/m^2/s : area * Velocity * S * rhop * 1.e-9 + !! + !!------------------------------------------------------------- + !!arguments + INTEGER, INTENT(IN) :: kt ! time-step + TYPE(SECTION), INTENT(INOUT) :: sec ! section to write + INTEGER ,INTENT(IN) :: ksec ! section number + + !!local declarations + INTEGER :: jclass ! Dummy loop + CHARACTER(len=2) :: classe ! Classname + REAL(wp) :: zbnd1,zbnd2 ! Class bounds + REAL(wp) :: zslope ! section's slope coeff + ! + REAL(wp), DIMENSION(nb_type_class):: zsumclasses ! 1D workspace + !!------------------------------------------------------------- + + zsumclasses(:)=0._wp + zslope = sec%slopeSection + + + DO jclass=1,MAX(1,sec%nb_class-1) + + classe = 'N ' + zbnd1 = 0._wp + zbnd2 = 0._wp + zsumclasses(1:nb_type_class)=zsumclasses(1:nb_type_class)+sec%transport(1:nb_type_class,jclass) + + + !insitu density classes transports + IF( ( sec%zsigi(jclass) .NE. 99._wp ) .AND. & + ( sec%zsigi(jclass+1) .NE. 99._wp ) )THEN + classe = 'DI ' + zbnd1 = sec%zsigi(jclass) + zbnd2 = sec%zsigi(jclass+1) + ENDIF + !potential density classes transports + IF( ( sec%zsigp(jclass) .NE. 99._wp ) .AND. & + ( sec%zsigp(jclass+1) .NE. 99._wp ) )THEN + classe = 'DP ' + zbnd1 = sec%zsigp(jclass) + zbnd2 = sec%zsigp(jclass+1) + ENDIF + !depth classes transports + IF( ( sec%zlay(jclass) .NE. 99._wp ) .AND. & + ( sec%zlay(jclass+1) .NE. 99._wp ) )THEN + classe = 'Z ' + zbnd1 = sec%zlay(jclass) + zbnd2 = sec%zlay(jclass+1) + ENDIF + !salinity classes transports + IF( ( sec%zsal(jclass) .NE. 99._wp ) .AND. & + ( sec%zsal(jclass+1) .NE. 99._wp ) )THEN + classe = 'S ' + zbnd1 = sec%zsal(jclass) + zbnd2 = sec%zsal(jclass+1) + ENDIF + !temperature classes transports + IF( ( sec%ztem(jclass) .NE. 99._wp ) .AND. & + ( sec%ztem(jclass+1) .NE. 99._wp ) ) THEN + classe = 'T ' + zbnd1 = sec%ztem(jclass) + zbnd2 = sec%ztem(jclass+1) + ENDIF + + !write volume transport per class + WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope, & + jclass,classe,zbnd1,zbnd2,& + sec%transport(1,jclass),sec%transport(2,jclass), & + sec%transport(1,jclass)+sec%transport(2,jclass) + + IF( sec%llstrpond )THEN + + !write heat transport per class: + WRITE(numdct_heat,119) ndastp,kt,ksec,sec%name,zslope, & + jclass,classe,zbnd1,zbnd2,& + sec%transport(3,jclass)*1.e-15,sec%transport(4,jclass)*1.e-15, & + ( sec%transport(3,jclass)+sec%transport(4,jclass) )*1.e-15 + !write salt transport per class + WRITE(numdct_salt,119) ndastp,kt,ksec,sec%name,zslope, & + jclass,classe,zbnd1,zbnd2,& + sec%transport(5,jclass)*1.e-9,sec%transport(6,jclass)*1.e-9,& + (sec%transport(5,jclass)+sec%transport(6,jclass))*1.e-9 + ENDIF + + ENDDO + + zbnd1 = 0._wp + zbnd2 = 0._wp + jclass=0 + + !write total volume transport + WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope, & + jclass,"total",zbnd1,zbnd2,& + zsumclasses(1),zsumclasses(2),zsumclasses(1)+zsumclasses(2) + + IF( sec%llstrpond )THEN + + !write total heat transport + WRITE(numdct_heat,119) ndastp,kt,ksec,sec%name,zslope, & + jclass,"total",zbnd1,zbnd2,& + zsumclasses(3)*1.e-15,zsumclasses(4)*1.e-15,& + (zsumclasses(3)+zsumclasses(4) )*1.e-15 + !write total salt transport + WRITE(numdct_salt,119) ndastp,kt,ksec,sec%name,zslope, & + jclass,"total",zbnd1,zbnd2,& + zsumclasses(5)*1.e-9,zsumclasses(6)*1.e-9,& + (zsumclasses(5)+zsumclasses(6))*1.e-9 + ENDIF + + + IF ( sec%ll_ice_section) THEN + !write total ice volume transport + WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope,& + jclass,"ice_vol",zbnd1,zbnd2,& + sec%transport(7,1),sec%transport(8,1),& + sec%transport(7,1)+sec%transport(8,1) + !write total ice surface transport + WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope,& + jclass,"ice_surf",zbnd1,zbnd2,& + sec%transport(9,1),sec%transport(10,1), & + sec%transport(9,1)+sec%transport(10,1) + ENDIF + +118 FORMAT(I8,1X,I8,1X,I4,1X,A30,1X,f9.2,1X,I4,3X,A8,1X,2F12.4,5X,3F12.4) +119 FORMAT(I8,1X,I8,1X,I4,1X,A30,1X,f9.2,1X,I4,3X,A8,1X,2F12.4,5X,3E15.6) + ! + END SUBROUTINE dia_dct_wri + + + FUNCTION interp(Kmm, ki, kj, kk, cd_point, ptab) + !!---------------------------------------------------------------------- + !! + !! Purpose: compute temperature/salinity/density at U-point or V-point + !! -------- + !! + !! Method: + !! ------ + !! + !! ====> full step and partial step + !! + !! + !! | I | I+1 | Z=temperature/salinity/density at U-poinT + !! | | | + !! ---------------------------------------- 1. Veritcal interpolation: compute zbis + !! | | | interpolation between ptab(I,J,K) and ptab(I,J,K+1) + !! | | | zbis = + !! | | | [ e3w_n(I+1,J,K,NOW)*ptab(I,J,K) + ( e3w_n(I,J,K,NOW) - e3w_n(I+1,J,K,NOW) ) * ptab(I,J,K-1) ] + !! | | | /[ e3w_n(I+1,J,K,NOW) + e3w_n(I,J,K,NOW) - e3w_n(I+1,J,K,NOW) ] + !! | | | + !! | | | 2. Horizontal interpolation: compute value at U/V point + !!K-1 | ptab(I,J,K-1) | | interpolation between zbis and ptab(I+1,J,K) + !! | . | | + !! | . | | interp = ( 0.5*zet2*zbis + 0.5*zet1*ptab(I+1,J,K) )/(0.5*zet2+0.5*zet1) + !! | . | | + !! ------------------------------------------ + !! | . | | + !! | . | | + !! | . | | + !!K | zbis.......U...ptab(I+1,J,K) | + !! | . | | + !! | ptab(I,J,K) | | + !! | |------------------| + !! | | partials | + !! | | steps | + !! ------------------------------------------- + !! <----zet1------><----zet2---------> + !! + !! + !! ====> s-coordinate + !! + !! | | | 1. Compute distance between T1 and U points: SQRT( zdep1^2 + (0.5 * zet1 )^2 + !! | | | Compute distance between T2 and U points: SQRT( zdep2^2 + (0.5 * zet2 )^2 + !! | | ptab(I+1,J,K) | + !! | | T2 | 2. Interpolation between T1 and T2 values at U point + !! | | ^ | + !! | | | zdep2 | + !! | | | | + !! | ^ U v | + !! | | | | + !! | | zdep1 | | + !! | v | | + !! | T1 | | + !! | ptab(I,J,K) | | + !! | | | + !! | | | + !! + !! <----zet1--------><----zet2---------> + !! + !!---------------------------------------------------------------------- + !*arguments + INTEGER, INTENT(IN) :: Kmm ! time level index + INTEGER, INTENT(IN) :: ki, kj, kk ! coordinate of point + CHARACTER(len=1), INTENT(IN) :: cd_point ! type of point (U, V) + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(IN) :: ptab ! variable to compute at (ki, kj, kk ) + REAL(wp) :: interp ! interpolated variable + + !*local declations + INTEGER :: ii1, ij1, ii2, ij2 ! local integer + REAL(wp):: ze3t, ze3, zwgt1, zwgt2, zbis, zdepu ! local real + REAL(wp):: zet1, zet2 ! weight for interpolation + REAL(wp):: zdep1,zdep2 ! differences of depth + REAL(wp):: zmsk ! mask value + !!---------------------------------------------------------------------- + + IF( cd_point=='U' )THEN + ii1 = ki ; ij1 = kj + ii2 = ki+1 ; ij2 = kj + + zet1=e1t(ii1,ij1) + zet2=e1t(ii2,ij2) + zmsk=umask(ii1,ij1,kk) + + + ELSE ! cd_point=='V' + ii1 = ki ; ij1 = kj + ii2 = ki ; ij2 = kj+1 + + zet1=e2t(ii1,ij1) + zet2=e2t(ii2,ij2) + zmsk=vmask(ii1,ij1,kk) + + ENDIF + + IF( ln_sco )THEN ! s-coordinate case + + zdepu = ( (gdept_0(ii1,ij1,kk)*(1._wp+r3t(ii1,ij1,Kmm))) + (gdept_0(ii2,ij2,kk)*(1._wp+r3t(ii2,ij2,Kmm))) ) * 0.5_wp + zdep1 = (gdept_0(ii1,ij1,kk)*(1._wp+r3t(ii1,ij1,Kmm))) - zdepu + zdep2 = (gdept_0(ii2,ij2,kk)*(1._wp+r3t(ii2,ij2,Kmm))) - zdepu + + ! weights + zwgt1 = SQRT( ( 0.5 * zet1 ) * ( 0.5 * zet1 ) + ( zdep1 * zdep1 ) ) + zwgt2 = SQRT( ( 0.5 * zet2 ) * ( 0.5 * zet2 ) + ( zdep2 * zdep2 ) ) + + ! result + interp = zmsk * ( zwgt2 * ptab(ii1,ij1,kk) + zwgt1 * ptab(ii1,ij1,kk) ) / ( zwgt2 + zwgt1 ) + + + ELSE ! full step or partial step case + + ze3t = (e3t_0(ii2,ij2,kk)*(1._wp+r3t(ii2,ij2,Kmm)*tmask(ii2,ij2,kk))) - (e3t_0(ii1,ij1,kk)*(1._wp+r3t(ii1,ij1,Kmm)*tmask(ii1,ij1,kk))) + zwgt1 = ( (e3w_0(ii2,ij2,kk)*(1._wp+r3t(ii2,ij2,Kmm))) - (e3w_0(ii1,ij1,kk)*(1._wp+r3t(ii1,ij1,Kmm))) ) & + & / (e3w_0(ii2,ij2,kk)*(1._wp+r3t(ii2,ij2,Kmm))) + zwgt2 = ( (e3w_0(ii1,ij1,kk)*(1._wp+r3t(ii1,ij1,Kmm))) - (e3w_0(ii2,ij2,kk)*(1._wp+r3t(ii2,ij2,Kmm))) ) & + & / (e3w_0(ii1,ij1,kk)*(1._wp+r3t(ii1,ij1,Kmm))) + + IF(kk .NE. 1)THEN + + IF( ze3t >= 0. )THEN + ! zbis + zbis = ptab(ii2,ij2,kk) + zwgt1 * ( ptab(ii2,ij2,kk-1) - ptab(ii2,ij2,kk) ) + ! result + interp = zmsk * ( zet2 * ptab(ii1,ij1,kk) + zet1 * zbis )/( zet1 + zet2 ) + ELSE + ! zbis + zbis = ptab(ii1,ij1,kk) + zwgt2 * ( ptab(ii1,ij1,kk-1) - ptab(ii1,ij2,kk) ) + ! result + interp = zmsk * ( zet2 * zbis + zet1 * ptab(ii2,ij2,kk) )/( zet1 + zet2 ) + ENDIF + + ELSE + interp = zmsk * ( zet2 * ptab(ii1,ij1,kk) + zet1 * ptab(ii2,ij2,kk) )/( zet1 + zet2 ) + ENDIF + + ENDIF + ! + END FUNCTION interp + + + !!====================================================================== +END MODULE diadct diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diadetide.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diadetide.f90 new file mode 100644 index 0000000000000000000000000000000000000000..637f38a0fa209584fb6337c5e5f8491874326539 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diadetide.f90 @@ -0,0 +1,122 @@ + + + + + + + + + + + + + +MODULE diadetide + !!====================================================================== + !! *** MODULE diadetide *** + !! Computation of weights for daily detided model diagnostics + !!====================================================================== + !! History : ! 2019 (S. Mueller) + !!---------------------------------------------------------------------- + USE par_kind + USE par_oce , ONLY : wp, jpi, jpj + USE in_out_manager , ONLY : lwp, numout + USE iom , ONLY : iom_put + USE dom_oce , ONLY : rn_Dt, nsec_day + USE phycst , ONLY : rpi + USE tide_mod + USE xios + + IMPLICIT NONE + PRIVATE + + LOGICAL, PUBLIC :: lk_diadetide + INTEGER :: ndiadetide + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: tdiadetide + + PUBLIC :: dia_detide_init, dia_detide + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2019) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_detide_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_detide_init *** + !! + !! ** Purpose : initialisation of the weight computation for daily + !! detided diagnostics (currently M2-detiding only) + !! + !!---------------------------------------------------------------------- + + REAL(wp) :: zdt + INTEGER :: jn + CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: ctide_selected = ' n/a ' + TYPE(tide_harmonic), DIMENSION(:), POINTER :: stideconst + + lk_diadetide = .FALSE. + ! Enquire detiding activation state (test for presence of detiding-related + ! weights field and output file group) + IF ( xios_is_valid_field( "diadetide_weight" ).AND.xios_is_valid_filegroup( "diadetide_files" ).AND.ln_tide ) THEN + lk_diadetide = .TRUE. + END IF + + IF (lwp) THEN + WRITE (numout, *) + WRITE (numout, *) 'dia_detide_init : weight computation for daily detided model diagnostics' + WRITE (numout, *) '~~~~~~~~~~~~~~~' + WRITE (numout, *) ' lk_diadetide = ', lk_diadetide + END IF + + IF (lk_diadetide) THEN + ! Retrieve information about M2 tidal constituent + ctide_selected(1) = 'M2' + CALL tide_init_harmonics(ctide_selected, stideconst) + + ! For M2, twice the tidal period spans slightly more than one full + ! day. Compute the maximum number of equal intervals that span exactly + ! twice the tidal period *and* whose mid-points fall within a 24-hour + ! period from midnight to midnight. + zdt = 2.0_wp * 2.0_wp * rpi / stideconst(1)%omega + ndiadetide = FLOOR( zdt / ( zdt - 86400.0_wp ) ) + ! Compute mid-points of the intervals to be included in the detided + ! average + ALLOCATE ( tdiadetide(ndiadetide) ) + DO jn = 1, ndiadetide + tdiadetide(jn) = ( REAL( jn, KIND=wp) - 0.5_wp ) * zdt / REAL( ndiadetide, KIND=wp ) - ( zdt - 86400.0_wp ) * 0.5_wp + END DO + END IF + + END SUBROUTINE dia_detide_init + + SUBROUTINE dia_detide( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_detide *** + !! + !! ** Purpose : weight computation for daily detided model diagnostics + !!---------------------------------------------------------------------- + + INTEGER, INTENT(in) :: kt + REAL(wp), DIMENSION(jpi,jpj) :: zwght_2D + REAL(wp) :: zwght, ztmp + INTEGER :: jn + + ! Compute detiding weight at the current time-step; the daily total weight + ! is one, and the daily summation of a diagnosed field multiplied by this + ! weight should provide daily detided averages + zwght = 0.0_wp + DO jn = 1, ndiadetide + ztmp = ( tdiadetide(jn) - REAL( nsec_day, KIND=wp ) ) / rn_Dt + IF ( ( ztmp < 0.5_wp ).AND.( ztmp >= -0.5_wp ) ) THEN + zwght = zwght + 1.0_wp / REAL( ndiadetide, KIND=wp ) + END IF + END DO + zwght_2D(:,:) = zwght + CALL iom_put( "diadetide_weight", zwght_2D) + + END SUBROUTINE dia_detide + +END MODULE diadetide diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diahsb.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diahsb.f90 new file mode 100644 index 0000000000000000000000000000000000000000..918dac5d666e6688f7529f57a8453925378b0eac --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diahsb.f90 @@ -0,0 +1,471 @@ + + + + + + + + + + + + + +MODULE diahsb + !!====================================================================== + !! *** MODULE diahsb *** + !! Ocean diagnostics: Heat, salt and volume budgets + !!====================================================================== + !! History : 3.3 ! 2010-09 (M. Leclair) Original code + !! ! 2012-10 (C. Rousset) add iom_put + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dia_hsb : Diagnose the conservation of ocean heat and salt contents, and volume + !! dia_hsb_rst : Read or write DIA file in restart file + !! dia_hsb_init : Initialization of the conservation diagnostic + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce ! surface thermohaline fluxes + USE isf_oce ! ice shelf fluxes + USE sbcrnf ! river runoff + USE domvvl ! vertical scale factors + USE traqsr ! penetrative solar radiation + USE trabbc ! bottom boundary condition + USE trabbc ! bottom boundary condition + USE restart ! ocean restart + USE bdy_oce , ONLY : ln_bdy + ! + USE iom ! I/O manager + USE in_out_manager ! I/O manager + USE lib_fortran ! glob_sum + USE lib_mpp ! distributed memory computing library + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_hsb ! routine called by step.F90 + PUBLIC dia_hsb_init ! routine called by nemogcm.F90 + + LOGICAL, PUBLIC :: ln_diahsb !: check the heat and salt budgets + + REAL(wp) :: surf_tot ! ocean surface + REAL(wp) :: frc_s! global forcing trends + REAL(dp) :: frc_t, frc_v! global forcing trends + REAL(wp) :: frc_wn_t, frc_wn_s ! global forcing trends + ! + REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: surf + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ssh_ini! + REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: surf_ini! + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ssh_hc_loc_ini, ssh_sc_loc_ini ! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: hc_loc_ini! + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: sc_loc_ini, e3t_ini! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_ini + + !! * Substitutions +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diahsb.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_hsb( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------------- + !! *** ROUTINE dia_hsb *** + !! + !! ** Purpose: Compute the ocean global heat content, salt content and volume conservation + !! + !! ** Method : - Compute the deviation of heat content, salt content and volume + !! at the current time step from their values at nit000 + !! - Compute the contribution of forcing and remove it from these deviations + !! + !!--------------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indice + REAL(wp) :: zdiff_hc , zdiff_sc ! heat and salt content variations + REAL(wp) :: zdiff_hc1 , zdiff_sc1 ! - - - - + REAL(dp) :: zdiff_v1 , zdiff_v2 ! volume variation + REAL(wp) :: zerr_hc1 , zerr_sc1 ! heat and salt content misfit + REAL(wp) :: zvol_tot ! volume + REAL(wp) :: z_frc_trd_t , z_frc_trd_s ! - - + REAL(dp) :: z_frc_trd_v ! - - + REAL(wp) :: z_wn_trd_t , z_wn_trd_s ! - - + REAL(wp) :: z_ssh_hc , z_ssh_sc ! - - + REAL(dp), DIMENSION(jpi,jpj,13) :: ztmp + REAL(dp), DIMENSION(jpi,jpj,jpkm1,4) :: ztmpk + REAL(dp), DIMENSION(17) :: zbg + !!--------------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('dia_hsb') + ! + ztmp (:,:,:) = 0._wp ! should be better coded + ztmpk(:,:,:,:) = 0._wp ! should be better coded + ! + ts(:,:,:,1,Kmm) = ts(:,:,:,1,Kmm) * tmask(:,:,:) ; ts(:,:,:,1,Kbb) = ts(:,:,:,1,Kbb) * tmask(:,:,:) ; + ts(:,:,:,2,Kmm) = ts(:,:,:,2,Kmm) * tmask(:,:,:) ; ts(:,:,:,2,Kbb) = ts(:,:,:,2,Kbb) * tmask(:,:,:) ; + ! + ! ------------------------- ! + ! 1 - Trends due to forcing ! + ! ------------------------- ! + ! prepare trends + ztmp(:,:,1) = - r1_rho0 * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) ) * surf(:,:) ! volume + ztmp(:,:,2) = sbc_tsc(:,:,jp_tem) * surf(:,:) ! heat + ztmp(:,:,3) = sbc_tsc(:,:,jp_sal) * surf(:,:) ! salt + IF( ln_rnf ) ztmp(:,:,4) = rnf_tsc(:,:,jp_tem) * surf(:,:) ! runoff temp + IF( ln_rnf_sal ) ztmp(:,:,5) = rnf_tsc(:,:,jp_sal) * surf(:,:) ! runoff salt + IF( ln_isf ) ztmp(:,:,6) = ( risf_cav_tsc(:,:,jp_tem) + risf_par_tsc(:,:,jp_tem) ) * surf(:,:) ! isf temp + IF( ln_traqsr ) ztmp(:,:,7) = r1_rho0_rcp * qsr(:,:) * surf(:,:) ! penetrative solar radiation + IF( ln_trabbc ) ztmp(:,:,8) = qgh_trd0(:,:) * surf(:,:) ! geothermal heat + ! + IF( ln_linssh ) THEN ! Advection flux through fixed surface (z=0) + IF( ln_isfcav ) THEN + DO ji=1,jpi + DO jj=1,jpj + ztmp(ji,jj,9 ) = - surf(ji,jj) * ww(ji,jj,mikt(ji,jj)) * ts(ji,jj,mikt(ji,jj),jp_tem,Kbb) + ztmp(ji,jj,10) = - surf(ji,jj) * ww(ji,jj,mikt(ji,jj)) * ts(ji,jj,mikt(ji,jj),jp_sal,Kbb) + END DO + END DO + ELSE + ztmp(:,:,9 ) = - surf(:,:) * ww(:,:,1) * ts(:,:,1,jp_tem,Kbb) + ztmp(:,:,10) = - surf(:,:) * ww(:,:,1) * ts(:,:,1,jp_sal,Kbb) + END IF + ENDIF + + ! global sum + zbg(1:10) = glob_sum_vec( 'dia_hsb', ztmp(:,:,1:10) ) + + ! adding up + z_frc_trd_v = zbg(1) ! volume fluxes + z_frc_trd_t = zbg(2) ! heat fluxes + z_frc_trd_s = zbg(3) ! salt fluxes + IF( ln_rnf ) z_frc_trd_t = z_frc_trd_t + zbg(4) ! runoff heat + IF( ln_rnf_sal) z_frc_trd_s = z_frc_trd_s + zbg(5) ! runoff salt + IF( ln_isf ) z_frc_trd_t = z_frc_trd_t + zbg(6) ! isf heat + IF( ln_traqsr ) z_frc_trd_t = z_frc_trd_t + zbg(7) ! penetrative solar flux + IF( ln_trabbc ) z_frc_trd_t = z_frc_trd_t + zbg(8) ! geothermal heat + ! + frc_v = frc_v + z_frc_trd_v * rn_Dt + frc_t = frc_t + z_frc_trd_t * rn_Dt + frc_s = frc_s + z_frc_trd_s * rn_Dt + ! ! Advection flux through fixed surface (z=0) + IF( ln_linssh ) THEN + z_wn_trd_t = zbg(9) + z_wn_trd_s = zbg(10) + ! + frc_wn_t = frc_wn_t + z_wn_trd_t * rn_Dt + frc_wn_s = frc_wn_s + z_wn_trd_s * rn_Dt + ENDIF + + ! --------------------------------- ! + ! 2 - Content variations with ssh ! + ! --------------------------------- ! + ! glob_sum is needed because you keep only the interior domain to compute the sum (iscpl) + ! + ! ! volume variation (calculated with ssh) + ztmp(:,:,11) = surf(:,:)*ssh(:,:,Kmm) - surf_ini(:,:)*ssh_ini(:,:) + + ! ! heat & salt content variation (associated with ssh) + IF( ln_linssh ) THEN ! linear free surface case + IF( ln_isfcav ) THEN ! ISF case + DO ji = 1, jpi + DO jj = 1, jpj + ztmp(ji,jj,12) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) - ssh_hc_loc_ini(ji,jj) ) + ztmp(ji,jj,13) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) - ssh_sc_loc_ini(ji,jj) ) + END DO + END DO + ELSE ! no under ice-shelf seas + ztmp(:,:,12) = surf(:,:) * ( ts(:,:,1,jp_tem,Kmm) * ssh(:,:,Kmm) - ssh_hc_loc_ini(:,:) ) + ztmp(:,:,13) = surf(:,:) * ( ts(:,:,1,jp_sal,Kmm) * ssh(:,:,Kmm) - ssh_sc_loc_ini(:,:) ) + END IF + ENDIF + + ! global sum + zbg(11:13) = glob_sum_vec( 'dia_hsb', ztmp(:,:,11:13) ) + + zdiff_v1 = zbg(11) + ! ! heat & salt content variation (associated with ssh) + IF( ln_linssh ) THEN ! linear free surface case + z_ssh_hc = zbg(12) + z_ssh_sc = zbg(13) + ENDIF + ! + ! --------------------------------- ! + ! 3 - Content variations with e3t ! + ! --------------------------------- ! + ! glob_sum is needed because you keep only the interior domain to compute the sum (iscpl) + ! + DO jk = 1, jpkm1 ! volume + ztmpk(:,:,jk,1) = surf (:,:) * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk)))*tmask(:,:,jk) & + & - surf_ini(:,:) * e3t_ini(:,:,jk )*tmask_ini(:,:,jk) + END DO + DO jk = 1, jpkm1 ! heat + ztmpk(:,:,jk,2) = ( surf (:,:) * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk)))*ts(:,:,jk,jp_tem,Kmm) & + & - surf_ini(:,:) * hc_loc_ini(:,:,jk) ) + END DO + DO jk = 1, jpkm1 ! salt + ztmpk(:,:,jk,3) = ( surf (:,:) * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk)))*ts(:,:,jk,jp_sal,Kmm) & + & - surf_ini(:,:) * sc_loc_ini(:,:,jk) ) + END DO + DO jk = 1, jpkm1 ! total ocean volume + ztmpk(:,:,jk,4) = surf(:,:) * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) * tmask(:,:,jk) + END DO + + ! global sum + zbg(14:17) = glob_sum_vec( 'dia_hsb', ztmpk(:,:,:,1:4) ) + + zdiff_v2 = zbg(14) ! glob_sum needed as tmask and tmask_ini could be different + zdiff_hc = zbg(15) + zdiff_sc = zbg(16) + zvol_tot = zbg(17) + + ! ------------------------ ! + ! 4 - Drifts ! + ! ------------------------ ! + zdiff_v1 = zdiff_v1 - frc_v + IF( .NOT.ln_linssh ) zdiff_v2 = zdiff_v2 - frc_v + zdiff_hc = zdiff_hc - frc_t + zdiff_sc = zdiff_sc - frc_s + IF( ln_linssh ) THEN + zdiff_hc1 = zdiff_hc + z_ssh_hc + zdiff_sc1 = zdiff_sc + z_ssh_sc + zerr_hc1 = z_ssh_hc - frc_wn_t + zerr_sc1 = z_ssh_sc - frc_wn_s + ENDIF + +!!gm to be added ? +! IF( ln_linssh ) THEN ! fixed volume, add the ssh contribution +! zvol_tot = zvol_tot + glob_sum( 'diahsb', surf(:,:) * ssh(:,:,Kmm) ) +! ENDIF +!!gm end + + CALL iom_put( 'bgfrcvol' , frc_v * 1.e-9 ) ! vol - surface forcing (km3) + CALL iom_put( 'bgfrctem' , frc_t * rho0 * rcp * 1.e-20 ) ! hc - surface forcing (1.e20 J) + CALL iom_put( 'bgfrchfx' , frc_t * rho0 * rcp / & ! hc - surface forcing (W/m2) + & ( surf_tot * kt * rn_Dt ) ) + CALL iom_put( 'bgfrcsal' , frc_s * 1.e-9 ) ! sc - surface forcing (psu*km3) + + IF( .NOT. ln_linssh ) THEN + CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot ) ! Temperature drift (C) + CALL iom_put( 'bgsaline' , zdiff_sc / zvol_tot ) ! Salinity drift (PSU) + CALL iom_put( 'bgheatco' , zdiff_hc * 1.e-20 * rho0 * rcp ) ! Heat content drift (1.e20 J) + CALL iom_put( 'bgheatfx' , zdiff_hc * rho0 * rcp / & ! Heat flux drift (W/m2) + & ( surf_tot * kt * rn_Dt ) ) + CALL iom_put( 'bgsaltco' , zdiff_sc * 1.e-9 ) ! Salt content drift (psu*km3) + CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9 ) ! volume ssh drift (km3) + CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9 ) ! volume e3t drift (km3) + ! + IF( kt == nitend .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_hsb : last time step hsb diagnostics: at it= ', kt,' date= ', ndastp + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) ' Temperature drift = ', zdiff_hc / zvol_tot, ' C' + WRITE(numout,*) ' Salinity drift = ', zdiff_sc / zvol_tot, ' PSU' + WRITE(numout,*) ' volume ssh drift = ', zdiff_v1 * 1.e-9 , ' km^3' + WRITE(numout,*) ' volume e3t drift = ', zdiff_v2 * 1.e-9 , ' km^3' + ENDIF + ! + ELSE + CALL iom_put( 'bgtemper' , zdiff_hc1 / zvol_tot) ! Heat content drift (C) + CALL iom_put( 'bgsaline' , zdiff_sc1 / zvol_tot) ! Salt content drift (PSU) + CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rho0 * rcp ) ! Heat content drift (1.e20 J) + CALL iom_put( 'bgheatfx' , zdiff_hc1 * rho0 * rcp / & ! Heat flux drift (W/m2) + & ( surf_tot * kt * rn_Dt ) ) + CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9 ) ! Salt content drift (psu*km3) + CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9 ) ! volume ssh drift (km3) + CALL iom_put( 'bgmistem' , zerr_hc1 / zvol_tot ) ! hc - error due to free surface (C) + CALL iom_put( 'bgmissal' , zerr_sc1 / zvol_tot ) ! sc - error due to free surface (psu) + ENDIF + ! + IF( lrst_oce ) CALL dia_hsb_rst( kt, Kmm, 'WRITE' ) + ! + IF( ln_timing ) CALL timing_stop('dia_hsb') + ! + END SUBROUTINE dia_hsb + + + SUBROUTINE dia_hsb_rst( kt, Kmm, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_hsb_rst *** + !! + !! ** Purpose : Read or write DIA file in restart file + !! + !! ** Method : use of IOM library + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: Kmm ! ocean time level index + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + IF( ln_rstart ) THEN !* Read the restart file + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' dia_hsb_rst : read hsb restart at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) + CALL iom_get( numror, 'frc_v', frc_v ) + CALL iom_get( numror, 'frc_t', frc_t ) + CALL iom_get( numror, 'frc_s', frc_s ) + IF( ln_linssh ) THEN + CALL iom_get( numror, 'frc_wn_t', frc_wn_t ) + CALL iom_get( numror, 'frc_wn_s', frc_wn_s ) + ENDIF + CALL iom_get( numror, jpdom_auto, 'surf_ini' , surf_ini ) ! ice sheet coupling + CALL iom_get( numror, jpdom_auto, 'ssh_ini' , ssh_ini ) + CALL iom_get( numror, jpdom_auto, 'e3t_ini' , e3t_ini ) + CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini ) + CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini ) + CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini ) + IF( ln_linssh ) THEN + CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) + CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) + ENDIF + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' dia_hsb_rst : initialise hsb at initial state ' + IF(lwp) WRITE(numout,*) + surf_ini(:,:) = e1e2t(:,:) * tmask_i(:,:) ! initial ocean surface + ssh_ini(:,:) = ssh(:,:,Kmm) ! initial ssh + DO jk = 1, jpk + ! if ice sheet/oceqn coupling, need to mask ini variables here (mask could change at the next NEMO instance). + e3t_ini (:,:,jk) = (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) * tmask(:,:,jk) ! initial vertical scale factors + tmask_ini (:,:,jk) = tmask(:,:,jk) ! initial mask + hc_loc_ini(:,:,jk) = ts(:,:,jk,jp_tem,Kmm) * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) * tmask(:,:,jk) ! initial heat content + sc_loc_ini(:,:,jk) = ts(:,:,jk,jp_sal,Kmm) * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) * tmask(:,:,jk) ! initial salt content + END DO + frc_v = 0._wp ! volume trend due to forcing + frc_t = 0._wp ! heat content - - - - + frc_s = 0._wp ! salt content - - - - + IF( ln_linssh ) THEN + IF( ln_isfcav ) THEN + DO ji = 1, jpi + DO jj = 1, jpj + ssh_hc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) ! initial heat content in ssh + ssh_sc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) ! initial salt content in ssh + END DO + END DO + ELSE + ssh_hc_loc_ini(:,:) = ts(:,:,1,jp_tem,Kmm) * ssh(:,:,Kmm) ! initial heat content in ssh + ssh_sc_loc_ini(:,:) = ts(:,:,1,jp_sal,Kmm) * ssh(:,:,Kmm) ! initial salt content in ssh + END IF + frc_wn_t = 0._wp ! initial heat content misfit due to free surface + frc_wn_s = 0._wp ! initial salt content misfit due to free surface + ENDIF + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' dia_hsb_rst : write restart at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) + ! + CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v ) + CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t ) + CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s ) + IF( ln_linssh ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t ) + CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s ) + ENDIF + CALL iom_rstput( kt, nitrst, numrow, 'surf_ini' , surf_ini ) ! ice sheet coupling + CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini' , ssh_ini ) + CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini' , e3t_ini ) + CALL iom_rstput( kt, nitrst, numrow, 'tmask_ini' , tmask_ini ) + CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini ) + CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini ) + IF( ln_linssh ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) + CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) + ENDIF + ! + ENDIF + ! + END SUBROUTINE dia_hsb_rst + + + SUBROUTINE dia_hsb_init( Kmm ) + !!--------------------------------------------------------------------------- + !! *** ROUTINE dia_hsb *** + !! + !! ** Purpose: Initialization for the heat salt volume budgets + !! + !! ** Method : Compute initial heat content, salt content and volume + !! + !! ** Action : - Compute initial heat content, salt content and volume + !! - Initialize forcing trends + !! - Compute coefficients for conversion + !!--------------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ierror, ios ! local integer + !! + NAMELIST/namhsb/ ln_diahsb + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_hsb_init : heat and salt budgets diagnostics' + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + READ ( numnam_ref, namhsb, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namhsb in reference namelist' ) + READ ( numnam_cfg, namhsb, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namhsb in configuration namelist' ) + IF(lwm) WRITE( numond, namhsb ) + + IF(lwp) THEN + WRITE(numout,*) ' Namelist namhsb :' + WRITE(numout,*) ' check the heat and salt budgets (T) or not (F) ln_diahsb = ', ln_diahsb + ENDIF + ! + IF( .NOT. ln_diahsb ) RETURN + + ! ------------------- ! + ! 1 - Allocate memory ! + ! ------------------- ! + ALLOCATE( hc_loc_ini(jpi,jpj,jpk), sc_loc_ini(jpi,jpj,jpk), surf_ini(jpi,jpj), & + & e3t_ini(jpi,jpj,jpk), surf(jpi,jpj), ssh_ini(jpi,jpj), tmask_ini(jpi,jpj,jpk),STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'dia_hsb_init: unable to allocate hc_loc_ini' ) ; RETURN + ENDIF + + IF( ln_linssh ) ALLOCATE( ssh_hc_loc_ini(jpi,jpj), ssh_sc_loc_ini(jpi,jpj),STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'dia_hsb: unable to allocate ssh_hc_loc_ini' ) ; RETURN + ENDIF + + ! ----------------------------------------------- ! + ! 2 - Time independant variables and file opening ! + ! ----------------------------------------------- ! + surf(:,:) = e1e2t(:,:) * tmask_i(:,:) ! masked surface grid cell area + surf_tot = glob_sum( 'diahsb', surf(:,:) ) ! total ocean surface area + + IF( ln_bdy ) CALL ctl_warn( 'dia_hsb_init: heat/salt budget does not consider open boundary fluxes' ) + ! + ! ---------------------------------- ! + ! 4 - initial conservation variables ! + ! ---------------------------------- ! + CALL dia_hsb_rst( nit000, Kmm, 'READ' ) !* read or initialize all required files + ! + END SUBROUTINE dia_hsb_init + + !!====================================================================== +END MODULE diahsb diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diahth.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diahth.f90 new file mode 100644 index 0000000000000000000000000000000000000000..540cabf7db7f15e913f2a05689f3f07703e9f699 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diahth.f90 @@ -0,0 +1,400 @@ + + + + + + + + + + + + + +MODULE diahth + !!====================================================================== + !! *** MODULE diahth *** + !! Ocean diagnostics: thermocline and 20 degree depth + !!====================================================================== + !! History : OPA ! 1994-09 (J.-P. Boulanger) Original code + !! ! 1996-11 (E. Guilyardi) OPA8 + !! ! 1997-08 (G. Madec) optimization + !! ! 1999-07 (E. Guilyardi) hd28 + heat content + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.2 ! 2009-07 (S. Masson) hc300 bugfix + cleaning + add new diag + !!---------------------------------------------------------------------- + !! dia_hth : Compute varius diagnostics associated with the mixed layer + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE iom ! I/O library + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_hth ! routine called by step.F90 + PUBLIC dia_hth_alloc ! routine called by nemogcm.F90 + + LOGICAL, SAVE :: l_hth !: thermocline-20d depths flag + + ! note: following variables should move to local variables once iom_put is always used + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hth !: depth of the max vertical temperature gradient [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd20 !: depth of 20 C isotherm [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd26 !: depth of 26 C isotherm [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd28 !: depth of 28 C isotherm [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc3 !: heat content of first 300 m [W] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc7 !: heat content of first 700 m [W] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc20 !: heat content of first 2000 m [W] + + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diahth.F90 15234 2021-09-08 14:07:02Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + FUNCTION dia_hth_alloc() + !!--------------------------------------------------------------------- + INTEGER :: dia_hth_alloc + !!--------------------------------------------------------------------- + ! + ALLOCATE( hth(jpi,jpj), hd20(jpi,jpj), hd26(jpi,jpj), hd28(jpi,jpj), & + & htc3(jpi,jpj), htc7(jpi,jpj), htc20(jpi,jpj), STAT=dia_hth_alloc ) + ! + CALL mpp_sum ( 'diahth', dia_hth_alloc ) + IF(dia_hth_alloc /= 0) CALL ctl_stop( 'STOP', 'dia_hth_alloc: failed to allocate arrays.' ) + ! + END FUNCTION dia_hth_alloc + + + SUBROUTINE dia_hth( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_hth *** + !! + !! ** Purpose : Computes + !! the mixing layer depth (turbocline): avt = 5.e-4 + !! the depth of strongest vertical temperature gradient + !! the mixed layer depth with density criteria: rho = rho(10m or surf) + 0.03(or 0.01) + !! the mixed layer depth with temperature criteria: abs( tn - tn(10m) ) = 0.2 + !! the top of the thermochine: tn = tn(10m) - ztem2 + !! the pycnocline depth with density criteria equivalent to a temperature variation + !! rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) + !! the barrier layer thickness + !! the maximal verical inversion of temperature and its depth max( 0, max of tn - tn(10m) ) + !! the depth of the 20 degree isotherm (linear interpolation) + !! the depth of the 28 degree isotherm (linear interpolation) + !! the heat content of first 300 m + !! + !! ** Method : + !!------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + !! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp) :: zrho3 = 0.03_wp ! density criterion for mixed layer depth + REAL(wp) :: zrho1 = 0.01_wp ! density criterion for mixed layer depth + REAL(wp) :: ztem2 = 0.2_wp ! temperature criterion for mixed layer depth + REAL(wp) :: zztmp, zzdep ! temporary scalars inside do loop + REAL(wp) :: zu, zv, zw, zut, zvt ! temporary workspace + REAL(wp), DIMENSION(jpi,jpj) :: zabs2 ! MLD: abs( tn - tn(10m) ) = ztem2 + REAL(wp), DIMENSION(jpi,jpj) :: ztm2 ! Top of thermocline: tn = tn(10m) - ztem2 + REAL(wp), DIMENSION(jpi,jpj) :: zrho10_3 ! MLD: rho = rho10m + zrho3 + REAL(wp), DIMENSION(jpi,jpj) :: zpycn ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) + REAL(wp), DIMENSION(jpi,jpj) :: ztinv ! max of temperature inversion + REAL(wp), DIMENSION(jpi,jpj) :: zdepinv ! depth of temperature inversion + REAL(wp), DIMENSION(jpi,jpj) :: zrho0_3 ! MLD rho = rho(surf) = 0.03 + REAL(wp), DIMENSION(jpi,jpj) :: zrho0_1 ! MLD rho = rho(surf) = 0.01 + REAL(wp), DIMENSION(jpi,jpj) :: zmaxdzT ! max of dT/dz + REAL(wp), DIMENSION(jpi,jpj) :: zdelr ! delta rho equivalent to deltaT = 0.2 + !!---------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('dia_hth') + + IF( kt == nit000 ) THEN + l_hth = .FALSE. + IF( iom_use( 'mlddzt' ) .OR. iom_use( 'mldr0_3' ) .OR. iom_use( 'mldr0_1' ) .OR. & + & iom_use( 'mld_dt02' ) .OR. iom_use( 'topthdep' ) .OR. iom_use( 'mldr10_3' ) .OR. & + & iom_use( '20d' ) .OR. iom_use( '26d' ) .OR. iom_use( '28d' ) .OR. & + & iom_use( 'hc300' ) .OR. iom_use( 'hc700' ) .OR. iom_use( 'hc2000' ) .OR. & + & iom_use( 'pycndep' ) .OR. iom_use( 'tinv' ) .OR. iom_use( 'depti' ) ) l_hth = .TRUE. + ! ! allocate dia_hth array + IF( l_hth ) THEN + IF( dia_hth_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_hth : unable to allocate standard arrays' ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dia_hth : diagnostics of the thermocline depth' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + IF(lwp) WRITE(numout,*) + ENDIF + ENDIF + + IF( l_hth ) THEN + ! + IF( iom_use( 'mlddzt' ) .OR. iom_use( 'mldr0_3' ) .OR. iom_use( 'mldr0_1' ) ) THEN + ! initialization + ztinv (:,:) = 0._wp + zdepinv(:,:) = 0._wp + zmaxdzT(:,:) = 0._wp + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zztmp = (gdepw_0(ji,jj,mbkt(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))) + hth (ji,jj) = zztmp + zabs2 (ji,jj) = zztmp + ztm2 (ji,jj) = zztmp + zrho10_3(ji,jj) = zztmp + zpycn (ji,jj) = zztmp + END DO ; END DO + IF( nla10 > 1 ) THEN + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zztmp = (gdepw_0(ji,jj,mbkt(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))) + zrho0_3(ji,jj) = zztmp + zrho0_1(ji,jj) = zztmp + END DO ; END DO + ENDIF + + ! Preliminary computation + ! computation of zdelr = (dr/dT)(T,S,10m)*(-0.2 degC) + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + IF( tmask(ji,jj,nla10) == 1. ) THEN + zu = 1779.50 + 11.250 * ts(ji,jj,nla10,jp_tem,Kmm) - 3.80 * ts(ji,jj,nla10,jp_sal,Kmm) & + & - 0.0745 * ts(ji,jj,nla10,jp_tem,Kmm) * ts(ji,jj,nla10,jp_tem,Kmm) & + & - 0.0100 * ts(ji,jj,nla10,jp_tem,Kmm) * ts(ji,jj,nla10,jp_sal,Kmm) + zv = 5891.00 + 38.000 * ts(ji,jj,nla10,jp_tem,Kmm) + 3.00 * ts(ji,jj,nla10,jp_sal,Kmm) & + & - 0.3750 * ts(ji,jj,nla10,jp_tem,Kmm) * ts(ji,jj,nla10,jp_tem,Kmm) + zut = 11.25 - 0.149 * ts(ji,jj,nla10,jp_tem,Kmm) - 0.01 * ts(ji,jj,nla10,jp_sal,Kmm) + zvt = 38.00 - 0.750 * ts(ji,jj,nla10,jp_tem,Kmm) + zw = (zu + 0.698*zv) * (zu + 0.698*zv) + zdelr(ji,jj) = ztem2 * (1000.*(zut*zv - zvt*zu)/zw) + ELSE + zdelr(ji,jj) = 0._wp + ENDIF + END DO ; END DO + + ! ------------------------------------------------------------- ! + ! thermocline depth: strongest vertical gradient of temperature ! + ! turbocline depth (mixing layer depth): avt = zavt5 ! + ! MLD: rho = rho(1) + zrho3 ! + ! MLD: rho = rho(1) + zrho1 ! + ! ------------------------------------------------------------- ! + DO jk = jpkm1, 2, -1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) ! loop from bottom to 2 + ! + zzdep = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + zztmp = ( ts(ji,jj,jk-1,jp_tem,Kmm) - ts(ji,jj,jk,jp_tem,Kmm) ) & + & / zzdep * tmask(ji,jj,jk) ! vertical gradient of temperature (dT/dz) + zzdep = zzdep * tmask(ji,jj,1) + + IF( zztmp > zmaxdzT(ji,jj) ) THEN + zmaxdzT(ji,jj) = zztmp + hth (ji,jj) = zzdep ! max and depth of dT/dz + ENDIF + + IF( nla10 > 1 ) THEN + zztmp = rhop(ji,jj,jk) - rhop(ji,jj,1) ! delta rho(1) + IF( zztmp > zrho3 ) zrho0_3(ji,jj) = zzdep ! > 0.03 + IF( zztmp > zrho1 ) zrho0_1(ji,jj) = zzdep ! > 0.01 + ENDIF + END DO ; END DO ; END DO + + CALL iom_put( 'mlddzt', hth ) ! depth of the thermocline + IF( nla10 > 1 ) THEN + CALL iom_put( 'mldr0_3', zrho0_3 ) ! MLD delta rho(surf) = 0.03 + CALL iom_put( 'mldr0_1', zrho0_1 ) ! MLD delta rho(surf) = 0.01 + ENDIF + ! + ENDIF + ! + IF( iom_use( 'mld_dt02' ) .OR. iom_use( 'topthdep' ) .OR. iom_use( 'mldr10_3' ) .OR. & + & iom_use( 'pycndep' ) .OR. iom_use( 'tinv' ) .OR. iom_use( 'depti' ) ) THEN + ! ------------------------------------------------------------- ! + ! MLD: abs( tn - tn(10m) ) = ztem2 ! + ! Top of thermocline: tn = tn(10m) - ztem2 ! + ! MLD: rho = rho10m + zrho3 ! + ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) ! + ! temperature inversion: max( 0, max of tn - tn(10m) ) ! + ! depth of temperature inversion ! + ! ------------------------------------------------------------- ! + DO jk = jpkm1, nlb10, -1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) ! loop from bottom to nlb10 + ! + zzdep = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * tmask(ji,jj,1) + ! + zztmp = ts(ji,jj,nla10,jp_tem,Kmm) - ts(ji,jj,jk,jp_tem,Kmm) ! - delta T(10m) + IF( ABS(zztmp) > ztem2 ) zabs2 (ji,jj) = zzdep ! abs > 0.2 + IF( zztmp > ztem2 ) ztm2 (ji,jj) = zzdep ! > 0.2 + zztmp = -zztmp ! delta T(10m) + IF( zztmp > ztinv(ji,jj) ) THEN ! temperature inversion + ztinv(ji,jj) = zztmp + zdepinv (ji,jj) = zzdep ! max value and depth + ENDIF + + zztmp = rhop(ji,jj,jk) - rhop(ji,jj,nla10) ! delta rho(10m) + IF( zztmp > zrho3 ) zrho10_3(ji,jj) = zzdep ! > 0.03 + IF( zztmp > zdelr(ji,jj) ) zpycn (ji,jj) = zzdep ! > equi. delta T(10m) - 0.2 + ! + END DO ; END DO ; END DO + + CALL iom_put( 'mld_dt02', zabs2 ) ! MLD abs(delta t) - 0.2 + CALL iom_put( 'topthdep', ztm2 ) ! T(10) - 0.2 + CALL iom_put( 'mldr10_3', zrho10_3 ) ! MLD delta rho(10m) = 0.03 + CALL iom_put( 'pycndep' , zpycn ) ! MLD delta rho equi. delta T(10m) = 0.2 + CALL iom_put( 'tinv' , ztinv ) ! max. temp. inv. (t10 ref) + CALL iom_put( 'depti' , zdepinv ) ! depth of max. temp. inv. (t10 ref) + ! + ENDIF + + ! ------------------------------- ! + ! Depth of 20C/26C/28C isotherm ! + ! ------------------------------- ! + IF( iom_use ('20d') ) THEN ! depth of the 20 isotherm + ztem2 = 20. + CALL dia_hth_dep( Kmm, ztem2, hd20 ) + CALL iom_put( '20d', hd20 ) + ENDIF + ! + IF( iom_use ('26d') ) THEN ! depth of the 26 isotherm + ztem2 = 26. + CALL dia_hth_dep( Kmm, ztem2, hd26 ) + CALL iom_put( '26d', hd26 ) + ENDIF + ! + IF( iom_use ('28d') ) THEN ! depth of the 28 isotherm + ztem2 = 28. + CALL dia_hth_dep( Kmm, ztem2, hd28 ) + CALL iom_put( '28d', hd28 ) + ENDIF + + ! ----------------------------- ! + ! Heat content of first 300 m ! + ! ----------------------------- ! + IF( iom_use ('hc300') ) THEN + zzdep = 300. + CALL dia_hth_htc( Kmm, zzdep, ts(:,:,:,jp_tem,Kmm), htc3 ) + CALL iom_put( 'hc300', rho0_rcp * htc3 ) ! vertically integrated heat content (J/m2) + ENDIF + ! + ! ----------------------------- ! + ! Heat content of first 700 m ! + ! ----------------------------- ! + IF( iom_use ('hc700') ) THEN + zzdep = 700. + CALL dia_hth_htc( Kmm, zzdep, ts(:,:,:,jp_tem,Kmm), htc7 ) + CALL iom_put( 'hc700', rho0_rcp * htc7 ) ! vertically integrated heat content (J/m2) + + ENDIF + ! + ! ----------------------------- ! + ! Heat content of first 2000 m ! + ! ----------------------------- ! + IF( iom_use ('hc2000') ) THEN + zzdep = 2000. + CALL dia_hth_htc( Kmm, zzdep, ts(:,:,:,jp_tem,Kmm), htc20 ) + CALL iom_put( 'hc2000', rho0_rcp * htc20 ) ! vertically integrated heat content (J/m2) + ENDIF + ! + ENDIF + + ! + IF( ln_timing ) CALL timing_stop('dia_hth') + ! + END SUBROUTINE dia_hth + + SUBROUTINE dia_hth_dep( Kmm, ptem, pdept ) + ! + INTEGER , INTENT(in) :: Kmm ! ocean time level index + REAL(wp), INTENT(in) :: ptem + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pdept + ! + INTEGER :: ji, jj, jk, iid + REAL(wp) :: zztmp, zzdep + INTEGER, DIMENSION(jpi,jpj) :: iktem + + ! --------------------------------------- ! + ! search deepest level above ptem ! + ! --------------------------------------- ! + iktem(:,:) = 1 + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) ! beware temperature is not always decreasing with depth => loop from top to bottom + zztmp = ts(ji,jj,jk,jp_tem,Kmm) + IF( zztmp >= ptem ) iktem(ji,jj) = jk + END DO ; END DO ; END DO + + ! ------------------------------- ! + ! Depth of ptem isotherm ! + ! ------------------------------- ! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ! + zzdep = (gdepw_0(ji,jj,mbkt(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))) ! depth of the ocean bottom + ! + iid = iktem(ji,jj) + IF( iid /= 1 ) THEN + zztmp = (gdept_0(ji,jj,iid )*(1._wp+r3t(ji,jj,Kmm))) & ! linear interpolation + & + ( (gdept_0(ji,jj,iid+1)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj,iid)*(1._wp+r3t(ji,jj,Kmm))) ) & + & * ( 20.*tmask(ji,jj,iid+1) - ts(ji,jj,iid,jp_tem,Kmm) ) & + & / ( ts(ji,jj,iid+1,jp_tem,Kmm) - ts(ji,jj,iid,jp_tem,Kmm) + (1.-tmask(ji,jj,1)) ) + pdept(ji,jj) = MIN( zztmp , zzdep) * tmask(ji,jj,1) ! bound by the ocean depth + ELSE + pdept(ji,jj) = 0._wp + ENDIF + END DO ; END DO + ! + END SUBROUTINE dia_hth_dep + + + SUBROUTINE dia_hth_htc( Kmm, pdep, pt, phtc ) + ! + INTEGER , INTENT(in) :: Kmm ! ocean time level index + REAL(wp), INTENT(in) :: pdep ! depth over the heat content + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pt + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phtc + ! + INTEGER :: ji, jj, jk, ik + REAL(wp), DIMENSION(jpi,jpj) :: zthick + INTEGER , DIMENSION(jpi,jpj) :: ilevel + + + ! surface boundary condition + + IF( .NOT. ln_linssh ) THEN ; zthick(:,:) = 0._wp ; phtc(:,:) = 0._wp + ELSE ; zthick(:,:) = ssh(:,:,Kmm) ; phtc(:,:) = pt(:,:,1) * ssh(:,:,Kmm) * tmask(:,:,1) + ENDIF + ! + ilevel(:,:) = 1 + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + IF( ( (gdepw_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) < pdep ) .AND. ( tmask(ji,jj,jk) == 1 ) ) THEN + ilevel(ji,jj) = jk+1 + zthick(ji,jj) = zthick(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + phtc (ji,jj) = phtc (ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * pt(ji,jj,jk) + ENDIF + END DO ; END DO ; END DO + ! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ik = ilevel(ji,jj) + IF( tmask(ji,jj,ik) == 1 ) THEN + zthick(ji,jj) = MIN ( (gdepw_0(ji,jj,ik+1)*(1._wp+r3t(ji,jj,Kmm))), pdep ) - zthick(ji,jj) ! remaining thickness to reach dephw pdep + phtc(ji,jj) = phtc(ji,jj) + pt(ji,jj,ik) * zthick(ji,jj) + ENDIF + END DO ; END DO + ! + END SUBROUTINE dia_hth_htc + + !!====================================================================== +END MODULE diahth diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diamlr.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diamlr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..72802a0d68751b54138dbfe8043e8ef54a337bf9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diamlr.f90 @@ -0,0 +1,438 @@ + + + + + + + + + + + + + +MODULE diamlr + !!====================================================================== + !! *** MODULE diamlr *** + !! Management of the IOM context for multiple-linear-regression analysis + !!====================================================================== + !! History : 4.0 ! 2019 (S. Mueller) Original code + !!---------------------------------------------------------------------- + USE par_kind + USE par_oce , ONLY : wp, jpi, jpj + USE phycst , ONLY : rpi + USE dom_oce , ONLY : adatrj + USE tide_mod + ! + USE in_out_manager , ONLY : lwp, numout, ln_timing + USE iom , ONLY : iom_put, iom_use, iom_update_file_name + USE timing , ONLY : timing_start, timing_stop + USE xios + + IMPLICIT NONE + PRIVATE + + LOGICAL, PUBLIC :: lk_diamlr = .FALSE. !: ===>>> NOT a DOCTOR norm name : use l_diamlr + ! lk_ is used only for logical controlled by a CPP key + + PUBLIC :: dia_mlr_init, dia_mlr_iom_init, dia_mlr + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2019) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_mlr_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_mlr_init *** + !! + !! ** Purpose : initialisation of IOM context management for + !! multiple-linear-regression analysis + !! + !!---------------------------------------------------------------------- + ! + lk_diamlr = .TRUE. + ! + IF(lwp) THEN + WRITE(numout, *) + WRITE(numout, *) 'dia_mlr_init : initialisation of IOM context management for' + WRITE(numout, *) '~~~~~~~~~~~~ multiple-linear-regression analysis' + END IF + ! + END SUBROUTINE dia_mlr_init + + + SUBROUTINE dia_mlr_iom_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_mlr_iom_init *** + !! + !! ** Purpose : IOM context setup for multiple-linear-regression + !! analysis + !! + !!---------------------------------------------------------------------- + + TYPE(xios_fieldgroup) :: slxhdl_fldgrp + TYPE(xios_filegroup) :: slxhdl_filgrp + TYPE(xios_field), ALLOCATABLE, DIMENSION(:) :: slxhdl_regs, slxhdl_flds + TYPE(xios_field) :: slxhdl_fld + TYPE(xios_file) :: slxhdl_fil + LOGICAL :: llxatt_enabled, llxatt_comment + CHARACTER(LEN=256) :: clxatt_expr, clxatt_comment + CHARACTER(LEN=32) :: clxatt_name1, clxatt_name2 + CHARACTER(LEN=32) :: clxatt_gridref, clxatt_fieldref + INTEGER, PARAMETER :: jpscanmax = 999 + INTEGER :: ireg, ifld + CHARACTER(LEN=3) :: cl3i + CHARACTER(LEN=6) :: cl6a + CHARACTER(LEN=7) :: cl7a + CHARACTER(LEN=1) :: clgt + CHARACTER(LEN=2) :: clgd + CHARACTER(LEN=25) :: clfloat + CHARACTER(LEN=32) :: clrepl + INTEGER :: jl, jm, jn + INTEGER :: itide ! Number of available tidal components + REAL(wp) :: ztide_phase ! Tidal-constituent phase at adatrj=0 + CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: ctide_selected = 'n/a ' + TYPE(tide_harmonic), DIMENSION(:), POINTER :: stideconst + + IF(lwp) THEN + WRITE(numout, *) + WRITE(numout, *) 'dia_mlr_iom_init : IOM context setup for multiple-linear-regression' + WRITE(numout, *) '~~~~~~~~~~~~~~~~' + END IF + + ! Get handles to multiple-linear-regression analysis configuration (field + ! group 'diamrl_fields' and file group 'diamlr_files'); if no suitable + ! configuration is found, disable diamlr + IF ( lk_diamlr .AND. xios_is_valid_fieldgroup( "diamlr_fields" ) .AND. xios_is_valid_field( "diamlr_time" ) .AND. & + & xios_is_valid_filegroup( "diamlr_files" ) ) THEN + CALL xios_get_handle("diamlr_fields", slxhdl_fldgrp) + CALL xios_get_handle("diamlr_files", slxhdl_filgrp) + ELSE + IF (lwp) THEN + WRITE(numout, *) "diamlr: configuration not found or incomplete (field group 'diamlr_fields'" + WRITE(numout, *) " and/or file group 'diamlr_files' and/or field 'diamlr_time' missing);" + WRITE(numout, *) " disabling output for multiple-linear-regression analysis." + END IF + lk_diamlr = .FALSE. + END IF + + ! Set up IOM context for multiple-linear-regression analysis + IF ( lk_diamlr ) THEN + + ! Set up output files for grid types scalar, grid_T, grid_U, grid_V, + ! and grid_W + DO jm = 1, 5 + SELECT CASE( jm ) + CASE( 1 ) + cl6a = 'scalar' + CASE( 2 ) + cl6a = 'grid_T' + CASE( 3 ) + cl6a = 'grid_U' + CASE( 4 ) + cl6a = 'grid_V' + CASE( 5 ) + cl6a = 'grid_W' + END SELECT + CALL xios_add_child ( slxhdl_filgrp, slxhdl_fil, "diamlr_file_"//cl6a ) + CALL xios_set_attr ( slxhdl_fil, name_suffix="_diamlr_"//cl6a, & + & description="Intermediate output for multiple-linear-regression analysis - "//cl6a ) + CALL iom_update_file_name( "diamlr_file_"//cl6a ) + END DO + + ! Compile lists of active regressors and of fields selected for + ! analysis (fields "diamlr_r" and "diamlr_f", where is + ! a 3-digit integer); also carry out placeholder substitution of tidal + ! parameters in regressor expressions + ! + ALLOCATE( slxhdl_regs( jpscanmax ), slxhdl_flds( jpscanmax ) ) + ireg = 0 + ifld = 0 + ! + IF ( ln_tide ) THEN + ! Retrieve information (frequency, phase, nodal correction) about all + ! available tidal constituents for placeholder substitution below + ! Warning: we must use the same character length in an array constructor (at least for gcc compiler) + ctide_selected(1:34) = (/ 'Mf ', 'Mm ', 'Ssa ', 'Mtm ', 'Msf ', & + & 'Msqm', 'Sa ', 'K1 ', 'O1 ', 'P1 ', & + & 'Q1 ', 'J1 ', 'S1 ', 'M2 ', 'S2 ', 'N2 ', & + & 'K2 ', 'nu2 ', 'mu2 ', '2N2 ', 'L2 ', & + & 'T2 ', 'eps2', 'lam2', 'R2 ', 'M3 ', & + & 'MKS2', 'MN4 ', 'MS4 ', 'M4 ', 'N4 ', & + & 'S4 ', 'M6 ', 'M8 ' /) + CALL tide_init_harmonics(ctide_selected, stideconst) + itide = size(stideconst) + ELSE + itide = 0 + ENDIF + + DO jm = 1, jpscanmax + WRITE (cl3i, '(i3.3)') jm + + ! Look for regressor + IF ( xios_is_valid_field( "diamlr_r"//cl3i ) ) THEN + + CALL xios_get_handle( "diamlr_r"//cl3i, slxhdl_regs(ireg+1) ) + ! Retrieve pre-configured value of "enabled" attribute and + ! regressor expression + CALL xios_get_attr ( slxhdl_regs(ireg+1), enabled=llxatt_enabled, expr=clxatt_expr ) + ! If enabled, keep handle in list of active regressors; also + ! substitute placeholders for tidal frequencies, phases, and + ! nodal corrections in regressor expressions + IF ( llxatt_enabled ) THEN + + ! Substitution of placeholders for tidal-constituent + ! parameters (amplitudes, angular veloccities, nodal phase + ! correction) with values that have been obtained from the + ! tidal-forcing implementation (if enabled) + DO jn = 1, itide + ! Compute phase of tidal constituent (incl. current nodal + ! correction) at the start of the model run (i.e. for + ! adatrj=0) + ztide_phase = MOD( stideconst(jn)%u + stideconst(jn)%v0 - adatrj * 86400.0_wp * stideconst(jn)%omega, & + & 2.0_wp * rpi ) + clrepl = "__TDE_"//TRIM( stideconst(jn)%cname_tide )//"_omega__" + DO WHILE ( INDEX( clxatt_expr, TRIM( clrepl ) ) > 0 ) + WRITE (clfloat, '(e25.18)') stideconst(jn)%omega + jl = INDEX( clxatt_expr, TRIM( clrepl ) ) + clxatt_expr = clxatt_expr(1:jl - 1)//clfloat// & + & clxatt_expr(jl + LEN( TRIM( clrepl ) ):LEN( TRIM( clxatt_expr ) )) + END DO + clrepl = "__TDE_"//TRIM( stideconst(jn)%cname_tide )//"_phase__" + DO WHILE ( INDEX( clxatt_expr, TRIM( clrepl ) ) > 0 ) + WRITE (clfloat, '(e25.18)') ztide_phase + jl = INDEX( clxatt_expr, TRIM( clrepl ) ) + clxatt_expr = clxatt_expr(1:jl - 1)//clfloat// & + & clxatt_expr(jl + LEN( TRIM( clrepl ) ):LEN( TRIM( clxatt_expr ) )) + END DO + clrepl = "__TDE_"//TRIM( stideconst(jn)%cname_tide )//"_amplitude__" + DO WHILE (INDEX( clxatt_expr, TRIM( clrepl ) ) > 0 ) + WRITE (clfloat, '(e25.18)') stideconst(jn)%f + jl = INDEX( clxatt_expr, TRIM( clrepl ) ) + clxatt_expr = clxatt_expr(1:jl - 1)//clfloat// & + & clxatt_expr(jl + LEN( TRIM( clrepl ) ):LEN( TRIM( clxatt_expr ) )) + END DO + END DO + + ! Set standard value for comment attribute, including possible + ! existing comment added in parantheses + CALL xios_is_defined_attr( slxhdl_regs(ireg+1), comment=llxatt_comment ) + IF ( llxatt_comment ) THEN + CALL xios_get_attr( slxhdl_regs(ireg+1), comment=clxatt_comment ) + clxatt_comment = "Regressor "//cl3i//" ("//TRIM( clxatt_comment )//") " + ELSE + clxatt_comment = "Regressor "//cl3i + END IF + + ! Set name attribute (and overwrite possible pre-configured + ! name) with field id to enable id string retrieval from + ! stored handle below, re-set expression with possible + ! substitutions, and set or re-set comment attribute + CALL xios_set_attr ( slxhdl_regs(ireg+1), name="diamlr_r"//cl3i, expr=TRIM( clxatt_expr ), & + & comment=TRIM( clxatt_comment ) ) + + ireg = ireg + 1 ! Accept regressor in list of active regressors + + END IF + END IF + + ! Look for field + IF ( xios_is_valid_field( "diamlr_f"//cl3i ) ) THEN + + CALL xios_get_handle( "diamlr_f"//cl3i, slxhdl_flds(ifld+1) ) + ! Retrieve pre-configured value of "enabled" attribute + CALL xios_get_attr ( slxhdl_flds(ifld+1), enabled=llxatt_enabled ) + ! If enabled, keep handle in list of fields selected for analysis + IF ( llxatt_enabled ) THEN + + ! Set name attribute (and overwrite possible pre-configured name) + ! with field id to enable id string retrieval from stored handle + ! below + CALL xios_set_attr ( slxhdl_flds(ifld+1), name="diamlr_f"//cl3i ) + + ifld = ifld + 1 ! Accept field in list of fields selected for analysis + + END IF + END IF + + END DO + + ! Output number of active regressors and fields selected for analysis + IF ( lwp ) WRITE(numout,'(a,i3,a)' ) 'diamlr: ', ireg, ' active regressors found' + IF ( lwp ) WRITE(numout,'(a,i3,a)' ) 'diamlr: ', ifld, ' fields selected for analysis' + + ! Set up output of minimum, maximum, and average values of the time + ! variable available for the computation of regressors (diamlr_time) + CALL xios_get_handle( "diamlr_file_scalar", slxhdl_fil ) + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, "diamlr_time_average" ) +!$AGRIF_DO_NOT_TREAT + CALL xios_set_attr ( slxhdl_fld, standard_name="diamlr_time", & + & long_name="Elapsed model time at start of regression interval", & + & unit="s", operation="average", field_ref="diamlr_time", & + & grid_ref="diamlr_grid_2D_to_scalar" ) +!$AGRIF_END_DO_NOT_TREAT + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, "diamlr_time_minimum" ) +!$AGRIF_DO_NOT_TREAT + CALL xios_set_attr ( slxhdl_fld, standard_name="diamlr_time", & + & long_name="Elapsed model time at start of regression interval", & + & unit="s", operation="minimum", field_ref="diamlr_time", & + & grid_ref="diamlr_grid_2D_to_scalar" ) +!$AGRIF_END_DO_NOT_TREAT + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, "diamlr_time_maximum" ) +!$AGRIF_DO_NOT_TREAT + CALL xios_set_attr ( slxhdl_fld, standard_name="diamlr_time", & + & long_name="Elapsed model time at start of regression interval", & + & unit="s", operation="maximum", field_ref="diamlr_time", & + & grid_ref="diamlr_grid_2D_to_scalar" ) +!$AGRIF_END_DO_NOT_TREAT + + ! For each active regressor: + DO jm = 1, ireg + + ! i) set up 2-dimensional and 3-dimensional versions of the + ! regressors; explicitely set "enabled" attribute; note, while + ! the scalar versions of regressors are part of the + ! configuration, the respective 2-dimensional versions take + ! over the defining expression, while the scalar and + ! 3-dimensional versions are simply obtained via grid + ! transformations from the 2-dimensional version. + CALL xios_get_attr ( slxhdl_regs( jm ), name=clxatt_name1, expr=clxatt_expr, & + & enabled=llxatt_enabled, comment=clxatt_comment ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_T_2D" ) + CALL xios_set_attr ( slxhdl_fld, expr=TRIM( clxatt_expr ), grid_ref="diamlr_grid_T_2D", & + & field_ref="diamlr_time", enabled=llxatt_enabled ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_U_2D" ) + CALL xios_set_attr ( slxhdl_fld, expr=TRIM( clxatt_expr ), grid_ref="diamlr_grid_U_2D", & + & field_ref="diamlr_time", enabled=llxatt_enabled ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_V_2D" ) + CALL xios_set_attr ( slxhdl_fld, expr=TRIM( clxatt_expr ), grid_ref="diamlr_grid_V_2D", & + & field_ref="diamlr_time", enabled=llxatt_enabled ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_W_2D" ) + CALL xios_set_attr ( slxhdl_fld, expr=TRIM( clxatt_expr ), grid_ref="diamlr_grid_W_2D", & + & field_ref="diamlr_time", enabled=llxatt_enabled ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_T_3D") + CALL xios_set_attr ( slxhdl_fld, expr="this", grid_ref="diamlr_grid_2D_to_grid_T_3D", & + & field_ref=TRIM( clxatt_name1 )//"_grid_T_2D", enabled=llxatt_enabled) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_U_3D") + CALL xios_set_attr ( slxhdl_fld, expr="this", grid_ref="diamlr_grid_2D_to_grid_U_3D", & + & field_ref=TRIM( clxatt_name1 )//"_grid_U_2D", enabled=llxatt_enabled) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_V_3D") + CALL xios_set_attr ( slxhdl_fld, expr="this", grid_ref="diamlr_grid_2D_to_grid_V_3D", & + & field_ref=TRIM( clxatt_name1 )//"_grid_V_2D", enabled=llxatt_enabled) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_W_3D") + CALL xios_set_attr ( slxhdl_fld, expr="this", grid_ref="diamlr_grid_2D_to_grid_W_3D", & + & field_ref=TRIM( clxatt_name1 )//"_grid_W_2D", enabled=llxatt_enabled) + CALL xios_set_attr ( slxhdl_regs(jm), expr="this", grid_ref="diamlr_grid_2D_to_scalar", & + & field_ref=TRIM( clxatt_name1 )//"_grid_T_2D", enabled=llxatt_enabled) + + ! ii) set up output of active regressors, including metadata + CALL xios_get_handle( "diamlr_file_scalar", slxhdl_fil ) + ! Add regressor to output file + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, TRIM( clxatt_name1 ) ) + CALL xios_set_attr ( slxhdl_fld, standard_name=TRIM( clxatt_comment ), long_name=TRIM( clxatt_expr ), & + & operation="average" ) + + ! iii) set up the output of scalar products with itself and with + ! other active regressors + CALL xios_get_attr ( slxhdl_regs(jm), name=clxatt_name1 ) + DO jn = 1, jm + ! Field for product between regressors + CALL xios_get_attr ( slxhdl_regs(jn), name=clxatt_name2 ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"."//TRIM( clxatt_name2 ) ) + ! Set appropriate name attribute to avoid the possibility of + ! using an inappropriate inherited name attribute as the variable + ! name in the output file + CALL xios_set_attr ( slxhdl_fld, & + & name=TRIM( clxatt_name1 )//"."//TRIM( clxatt_name2 ), & + & grid_ref="diamlr_grid_scalar", & + & expr="this * "//TRIM( clxatt_name2 ), & + & field_ref=TRIM( clxatt_name1 ), & + & enabled=llxatt_enabled, & + & long_name="Scalar product of regressor "//TRIM( clxatt_name1 )// & + & " and regressor "//TRIM( clxatt_name2 ), & + & standard_name=TRIM( clxatt_name1 )//"."//TRIM( clxatt_name2 ), & + & operation="accumulate") + ! Add regressor-product field to output file + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, TRIM( clxatt_name1 )//"."//TRIM( clxatt_name2 ) ) + END DO + + ! iv) set up definitions for the output of scalar products with + ! fields selected for analysis + DO jn = 1, ifld + CALL xios_get_attr ( slxhdl_flds(jn), name=clxatt_name2, field_ref=clxatt_fieldref ) + CALL xios_get_handle( TRIM( clxatt_fieldref ), slxhdl_fld ) + CALL xios_get_attr ( slxhdl_fld, grid_ref=clxatt_gridref ) + clgt="T" + IF ( INDEX( clxatt_gridref, "_U_" ) > 0 ) clgt="U" + IF ( INDEX( clxatt_gridref, "_V_" ) > 0 ) clgt="V" + IF ( INDEX( clxatt_gridref, "_W_" ) > 0 ) clgt="W" + clgd="2D" + cl7a="" + IF ( INDEX( clxatt_gridref, "_3D" ) > 0 ) THEN + clgd="3D" + ELSE + cl7a="diamlr_" + END IF + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name2 )//"."//TRIM( clxatt_name1 ) ) + ! Set appropriate name attribute to avoid the possibility of + ! using an inappropriate inherited name attribute as the variable + ! name in the output file; use metadata (standard_name and + ! long_name) to refer to the id of the analysed field + CALL xios_set_attr ( slxhdl_fld, & + & name=TRIM( clxatt_name2 )//"."//TRIM( clxatt_name1 ), & + & expr="this * "//TRIM( clxatt_fieldref ), & + & grid_ref=cl7a//"grid_"//clgt//"_"//clgd, & + & field_ref=TRIM( clxatt_name1 )//"_grid_"//clgt//"_"//clgd, & + & enabled=llxatt_enabled, & + & long_name="Scalar product of "//TRIM( clxatt_fieldref )// & + & " and regressor "//TRIM( clxatt_name1 ), & + & standard_name=TRIM( clxatt_fieldref )//"."//TRIM( clxatt_name1 ), & + & operation="accumulate" ) + CALL xios_get_handle( "diamlr_file_grid_"//clgt, slxhdl_fil ) + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, TRIM( clxatt_name2 )//"."//TRIM( clxatt_name1 ) ) + END DO + + END DO + + ! Release list of active regressors and fields selected for analysis + DEALLOCATE( slxhdl_regs, slxhdl_flds ) + + END IF + + END SUBROUTINE dia_mlr_iom_init + + + SUBROUTINE dia_mlr + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_mlr *** + !! + !! ** Purpose : update time used in multiple-linear-regression analysis + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: zadatrj2d + !!---------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('dia_mlr') + + ! Update time to the continuous time since the start of the model run + ! (value of adatrj converted to time in units of seconds) + ! + ! A 2-dimensional field of constant value is sent, and subsequently used directly + ! or transformed to a scalar or a constant 3-dimensional field as required. + zadatrj2d(:,:) = adatrj*86400.0_wp + IF ( iom_use('diamlr_time') ) CALL iom_put('diamlr_time', zadatrj2d) + ! + IF( ln_timing ) CALL timing_stop('dia_mlr') + ! + END SUBROUTINE dia_mlr + + !!====================================================================== +END MODULE diamlr diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dianam.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dianam.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e1492dd89789a3444f021d9bc8e1c50985949595 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dianam.f90 @@ -0,0 +1,149 @@ + + + + + + + + + + + + + +MODULE dianam + !!====================================================================== + !! *** MODULE dianam *** + !! Ocean diagnostics: Builds output file name + !!===================================================================== + !! History : OPA ! 1999-02 (E. Guilyardi) Creation for 30 days/month + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.2 ! 2009-11 (S. Masson) complete rewriting, works for all calendars... + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dia_nam : Builds output file name + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE in_out_manager ! I/O manager + USE ioipsl, ONLY : ju2ymds ! for calendar + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_nam + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dianam.F90 12489 2020-02-28 15:55:11Z davestorkey $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE dia_nam( cdfnam, kfreq, cdsuff, ldfsec ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_nam *** + !! + !! ** Purpose : Builds output file name + !! + !! ** Method : File name is a function of date and output frequency + !! cdfnam=____ + !! = averaging frequency (DA, MO, etc...) + !! , date of beginning and end of run + !! + !!---------------------------------------------------------------------- + CHARACTER (len=*), INTENT( out) :: cdfnam ! file name + CHARACTER (len=*), INTENT(in ) :: cdsuff ! to be added at the end of the file name + INTEGER , INTENT(in ) :: kfreq ! output frequency: > 0 in time-step (or seconds see ldfsec) + ! < 0 in months + ! = 0 no frequency + LOGICAL , INTENT(in ), OPTIONAL :: ldfsec ! kfreq in second(in time-step) if .true.(.false. default) + ! + CHARACTER (len=20) :: clfmt, clfmt0 ! writing format + CHARACTER (len=20) :: clave ! name for output frequency + CHARACTER (len=20) :: cldate1 ! date of the beginning of run + CHARACTER (len=20) :: cldate2 ! date of the end of run + LOGICAL :: llfsec ! local value of ldfsec + INTEGER :: iyear1, imonth1, iday1 ! year, month, day of the first day of the run + INTEGER :: iyear2, imonth2, iday2 ! year, month, day of the last day of the run + INTEGER :: indg ! number of digits needed to write a number + INTEGER :: inbsec, inbmn, inbhr ! output frequency in seconds, minutes and hours + INTEGER :: inbday, inbmo, inbyr ! output frequency in days, months and years + INTEGER :: iyyss, iddss, ihhss, immss ! number of seconds in 1 year, 1 day, 1 hour and 1 minute + INTEGER :: iyymo ! number of months in 1 year + REAL(dp) :: zsec1, zsec2 ! not used + REAL(dp) :: zdrun, zjul ! temporary scalars + !!---------------------------------------------------------------------- + + ! name for output frequency + + IF( PRESENT(ldfsec) ) THEN ; llfsec = ldfsec + ELSE ; llfsec = .FALSE. + ENDIF + + IF( llfsec .OR. kfreq < 0 ) THEN ; inbsec = kfreq ! output frequency already in seconds + ELSE ; inbsec = kfreq * NINT( rn_Dt ) ! from time-step to seconds + ENDIF + iddss = NINT( rday ) ! number of seconds in 1 day + ihhss = NINT( rmmss * rhhmm ) ! number of seconds in 1 hour + immss = NINT( rmmss ) ! number of seconds in 1 minute + iyymo = NINT( raamo ) ! number of months in 1 year + iyyss = iddss * nyear_len(1) ! seconds in 1 year (not good: multi years with leap) + clfmt0 = "('(a,i',i1,',a)')" ! format '(a,ix,a)' with x to be defined + ! + IF( inbsec == 0 ) THEN ; clave = '' ! no frequency + ELSEIF( inbsec < 0 ) THEN + inbmo = -inbsec ! frequency in month + IF( MOD( inbmo, iyymo ) == 0 ) THEN ! frequency in years + inbyr = inbmo / iyymo + indg = INT(LOG10(REAL(inbyr,wp))) + 1 ! number of digits needed to write years frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbyr , 'y' + ELSE ! frequency in month + indg = INT(LOG10(REAL(inbmo,wp))) + 1 ! number of digits needed to write months frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbmo, 'm' + ENDIF + ELSEIF( MOD( inbsec, iyyss ) == 0 ) THEN ! frequency in years + inbyr = inbsec / iyyss + indg = INT(LOG10(REAL(inbyr ,wp))) + 1 ! number of digits needed to write years frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbyr , 'y' + ELSEIF( MOD( inbsec, iddss ) == 0 ) THEN ! frequency in days + inbday = inbsec / iddss + indg = INT(LOG10(REAL(inbday,wp))) + 1 ! number of digits needed to write days frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbday, 'd' + IF( inbday == nmonth_len(nmonth) ) clave = '_1m' + ELSEIF( MOD( inbsec, ihhss ) == 0 ) THEN ! frequency in hours + inbhr = inbsec / ihhss + indg = INT(LOG10(REAL(inbhr ,wp))) + 1 ! number of digits needed to write hours frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbhr , 'h' + ELSEIF( MOD( inbsec, immss ) == 0 ) THEN ! frequency in minutes + inbmn = inbsec / immss + indg = INT(LOG10(REAL(inbmn ,wp))) + 1 ! number of digits needed to write minutes frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbmn , 'mn' + ELSE ! frequency in seconds + indg = INT(LOG10(REAL(inbsec,wp))) + 1 ! number of digits needed to write seconds frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbsec, 's' + ENDIF + + ! date of the beginning and the end of the run + + zdrun = rn_Dt / rday * REAL( nitend - nit000, wp ) ! length of the run in days + zjul = fjulday - rn_Dt / rday + CALL ju2ymds( zjul , iyear1, imonth1, iday1, zsec1 ) ! year/month/day of the beginning of run + CALL ju2ymds( zjul + zdrun, iyear2, imonth2, iday2, zsec2 ) ! year/month/day of the end of run + + IF( iyear2 < 10000 ) THEN ; clfmt = "(i4.4,2i2.2)" ! format used to write the date + ELSE ; WRITE(clfmt, "('(i',i1,',2i2.2)')") INT(LOG10(REAL(iyear2,wp))) + 1 + ENDIF + + WRITE(cldate1, clfmt) iyear1, imonth1, iday1 ! date of the beginning of run + WRITE(cldate2, clfmt) iyear2, imonth2, iday2 ! date of the end of run + + cdfnam = TRIM(cexper)//TRIM(clave)//"_"//TRIM(cldate1)//"_"//TRIM(cldate2)//"_"//TRIM(cdsuff) + IF( .NOT. Agrif_Root() ) cdfnam = TRIM(Agrif_CFixed())//'_'//TRIM(cdfnam) + + END SUBROUTINE dia_nam + + !!====================================================================== +END MODULE dianam diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diaobs.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diaobs.f90 new file mode 100644 index 0000000000000000000000000000000000000000..310a0296fe3b834174baa54269325ba79380cce8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diaobs.f90 @@ -0,0 +1,1145 @@ + + + + + + + + + + + + + +MODULE diaobs + !!====================================================================== + !! *** MODULE diaobs *** + !! Observation diagnostics: Computation of the misfit between data and + !! their model equivalent + !!====================================================================== + !! History : 1.0 ! 2006-03 (K. Mogensen) Original code + !! - ! 2006-05 (K. Mogensen, A. Weaver) Reformatted + !! - ! 2006-10 (A. Weaver) Cleaning and add controls + !! - ! 2007-03 (K. Mogensen) General handling of profiles + !! - ! 2007-04 (G. Smith) Generalized surface operators + !! 2.0 ! 2008-10 (M. Valdivieso) obs operator for velocity profiles + !! 3.4 ! 2014-08 (J. While) observation operator for profiles in all vertical coordinates + !! - ! Incorporated SST bias correction + !! 3.6 ! 2015-02 (M. Martin) Simplification of namelist and code + !! - ! 2015-08 (M. Martin) Combined surface/profile routines. + !! 4.0 ! 2017-11 (G. Madec) style only + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dia_obs_init : Reading and prepare observations + !! dia_obs : Compute model equivalent to observations + !! dia_obs_wri : Write observational diagnostics + !! calc_date : Compute the date of timestep in YYYYMMDD.HHMMSS format + !! ini_date : Compute the initial date YYYYMMDD.HHMMSS + !! fin_date : Compute the final date YYYYMMDD.HHMMSS + !!---------------------------------------------------------------------- + USE par_kind ! Precision variables + USE in_out_manager ! I/O manager + USE par_oce ! ocean parameter + USE dom_oce ! Ocean space and time domain variables + USE sbc_oce ! Sea-ice fraction + ! + USE obs_read_prof ! Reading and allocation of profile obs + USE obs_read_surf ! Reading and allocation of surface obs + USE obs_sstbias ! Bias correction routine for SST + USE obs_readmdt ! Reading and allocation of MDT for SLA. + USE obs_prep ! Preparation of obs. (grid search etc). + USE obs_oper ! Observation operators + USE obs_write ! Writing of observation related diagnostics + USE obs_grid ! Grid searching + USE obs_read_altbias ! Bias treatment for altimeter + USE obs_profiles_def ! Profile data definitions + USE obs_surf_def ! Surface data definitions + USE obs_types ! Definitions for observation types + ! + USE mpp_map ! MPP mapping + USE lib_mpp ! For ctl_warn/stop + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_obs_init ! Initialize and read observations + PUBLIC dia_obs ! Compute model equivalent to observations + PUBLIC dia_obs_wri ! Write model equivalent to observations + PUBLIC dia_obs_dealloc ! Deallocate dia_obs data + PUBLIC calc_date ! Compute the date of a timestep + + LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator + LOGICAL :: ln_sstnight ! Logical switch for night mean SST obs + LOGICAL :: ln_default_fp_indegs ! T=> Default obs footprint size specified in degrees, F=> in metres + LOGICAL :: ln_sla_fp_indegs ! T=> SLA obs footprint size specified in degrees, F=> in metres + LOGICAL :: ln_sst_fp_indegs ! T=> SST obs footprint size specified in degrees, F=> in metres + LOGICAL :: ln_sss_fp_indegs ! T=> SSS obs footprint size specified in degrees, F=> in metres + LOGICAL :: ln_sic_fp_indegs ! T=> sea-ice obs footprint size specified in degrees, F=> in metres + + REAL(wp) :: rn_default_avglamscl ! E/W diameter of SLA observation footprint (metres) + REAL(wp) :: rn_default_avgphiscl ! N/S diameter of SLA observation footprint (metre + REAL(wp) :: rn_sla_avglamscl ! E/W diameter of SLA observation footprint (metres) + REAL(wp) :: rn_sla_avgphiscl ! N/S diameter of SLA observation footprint (metres) + REAL(wp) :: rn_sst_avglamscl ! E/W diameter of SST observation footprint (metres) + REAL(wp) :: rn_sst_avgphiscl ! N/S diameter of SST observation footprint (metres) + REAL(wp) :: rn_sss_avglamscl ! E/W diameter of SSS observation footprint (metres) + REAL(wp) :: rn_sss_avgphiscl ! N/S diameter of SSS observation footprint (metres) + REAL(wp) :: rn_sic_avglamscl ! E/W diameter of sea-ice observation footprint (metres) + REAL(wp) :: rn_sic_avgphiscl ! N/S diameter of sea-ice observation footprint (metres) + + INTEGER :: nn_1dint ! Vertical interpolation method + INTEGER :: nn_2dint_default ! Default horizontal interpolation method + INTEGER :: nn_2dint_sla ! SLA horizontal interpolation method + INTEGER :: nn_2dint_sst ! SST horizontal interpolation method + INTEGER :: nn_2dint_sss ! SSS horizontal interpolation method + INTEGER :: nn_2dint_sic ! Seaice horizontal interpolation method + INTEGER, DIMENSION(imaxavtypes) :: nn_profdavtypes ! Profile data types representing a daily average + INTEGER :: nproftypes ! Number of profile obs types + INTEGER :: nsurftypes ! Number of surface obs types + INTEGER , DIMENSION(:), ALLOCATABLE :: nvarsprof, nvarssurf ! Number of profile & surface variables + INTEGER , DIMENSION(:), ALLOCATABLE :: nextrprof, nextrsurf ! Number of profile & surface extra variables + INTEGER , DIMENSION(:), ALLOCATABLE :: n2dintsurf ! Interpolation option for surface variables + REAL(wp), DIMENSION(:), ALLOCATABLE :: zavglamscl, zavgphiscl ! E/W & N/S diameter of averaging footprint for surface variables + LOGICAL , DIMENSION(:), ALLOCATABLE :: lfpindegs ! T=> surface obs footprint size specified in degrees, F=> in metres + LOGICAL , DIMENSION(:), ALLOCATABLE :: llnightav ! Logical for calculating night-time averages + + TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdata !: Initial surface data + TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdataqc !: Surface data after quality control + TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdata !: Initial profile data + TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdataqc !: Profile data after quality control + + CHARACTER(len=lca), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diaobs.F90 15077 2021-07-03 10:16:35Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_obs_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_obs_init *** + !! + !! ** Purpose : Initialize and read observations + !! + !! ** Method : Read the namelist and call reading routines + !! + !! ** Action : Read the namelist and call reading routines + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level indices + INTEGER, PARAMETER :: jpmaxnfiles = 1000 ! Maximum number of files for each obs type + INTEGER, DIMENSION(:), ALLOCATABLE :: ifilesprof, ifilessurf ! Number of profile & surface files + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: jtype ! Counter for obs types + INTEGER :: jvar ! Counter for variables + INTEGER :: jfile ! Counter for files + INTEGER :: jnumsstbias ! Number of SST bias files to read and apply + INTEGER :: n2dint_type ! Local version of nn_2dint* + ! + CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & + & cn_profbfiles, & ! T/S profile input filenames + & cn_sstfbfiles, & ! Sea surface temperature input filenames + & cn_sssfbfiles, & ! Sea surface salinity input filenames + & cn_slafbfiles, & ! Sea level anomaly input filenames + & cn_sicfbfiles, & ! Seaice concentration input filenames + & cn_velfbfiles, & ! Velocity profile input filenames + & cn_sstbiasfiles ! SST bias input filenames + CHARACTER(LEN=128) :: & + & cn_altbiasfile ! Altimeter bias input filename + CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: & + & clproffiles, & ! Profile filenames + & clsurffiles ! Surface filenames + CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: & + & clvars ! Expected variable names + ! + LOGICAL :: ln_t3d ! Logical switch for temperature profiles + LOGICAL :: ln_s3d ! Logical switch for salinity profiles + LOGICAL :: ln_sla ! Logical switch for sea level anomalies + LOGICAL :: ln_sst ! Logical switch for sea surface temperature + LOGICAL :: ln_sss ! Logical switch for sea surface salinity + LOGICAL :: ln_sic ! Logical switch for sea ice concentration + LOGICAL :: ln_vel3d ! Logical switch for velocity (u,v) obs + LOGICAL :: ln_nea ! Logical switch to remove obs near land + LOGICAL :: ln_altbias ! Logical switch for altimeter bias + LOGICAL :: ln_sstbias ! Logical switch for bias corection of SST + LOGICAL :: ln_ignmis ! Logical switch for ignoring missing files + LOGICAL :: ln_s_at_t ! Logical switch to compute model S at T obs + LOGICAL :: ln_bound_reject ! Logical to remove obs near boundaries in LAMs. + LOGICAL :: ltype_fp_indegs ! Local version of ln_*_fp_indegs + LOGICAL :: ltype_night ! Local version of ln_sstnight (false for other variables) + LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar ! Logical for profile variable read + LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files + ! + REAL(wp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS + REAL(wp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS + REAL(wp) :: ztype_avglamscl ! Local version of rn_*_avglamscl + REAL(wp) :: ztype_avgphiscl ! Local version of rn_*_avgphiscl + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zglam ! Model longitudes for profile variables + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zgphi ! Model latitudes for profile variables + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zmask ! Model land/sea mask associated with variables + !! + NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla, & + & ln_sst, ln_sic, ln_sss, ln_vel3d, & + & ln_altbias, ln_sstbias, ln_nea, & + & ln_grid_global, ln_grid_search_lookup, & + & ln_ignmis, ln_s_at_t, ln_bound_reject, & + & ln_sstnight, ln_default_fp_indegs, & + & ln_sla_fp_indegs, ln_sst_fp_indegs, & + & ln_sss_fp_indegs, ln_sic_fp_indegs, & + & cn_profbfiles, cn_slafbfiles, & + & cn_sstfbfiles, cn_sicfbfiles, & + & cn_velfbfiles, cn_sssfbfiles, & + & cn_sstbiasfiles, cn_altbiasfile, & + & cn_gridsearchfile, rn_gridsearchres, & + & rn_dobsini, rn_dobsend, & + & rn_default_avglamscl, rn_default_avgphiscl, & + & rn_sla_avglamscl, rn_sla_avgphiscl, & + & rn_sst_avglamscl, rn_sst_avgphiscl, & + & rn_sss_avglamscl, rn_sss_avgphiscl, & + & rn_sic_avglamscl, rn_sic_avgphiscl, & + & nn_1dint, nn_2dint_default, & + & nn_2dint_sla, nn_2dint_sst, & + & nn_2dint_sss, nn_2dint_sic, & + & nn_msshc, rn_mdtcorr, rn_mdtcutoff, & + & nn_profdavtypes + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! Read namelist parameters + !----------------------------------------------------------------------- + ! Some namelist arrays need initialising + cn_profbfiles (:) = '' + cn_slafbfiles (:) = '' + cn_sstfbfiles (:) = '' + cn_sicfbfiles (:) = '' + cn_velfbfiles (:) = '' + cn_sssfbfiles (:) = '' + cn_sstbiasfiles(:) = '' + nn_profdavtypes(:) = -1 + + CALL ini_date( rn_dobsini ) + CALL fin_date( rn_dobsend ) + + ! Read namelist namobs : control observation diagnostics + READ ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist' ) + READ ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist' ) + IF(lwm) WRITE ( numond, namobs ) + + IF( .NOT.ln_diaobs ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dia_obs_init : NO Observation diagnostic used' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + RETURN + ENDIF + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_obs_init : Observation diagnostic initialization' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namobs : set observation diagnostic parameters' + WRITE(numout,*) ' Logical switch for T profile observations ln_t3d = ', ln_t3d + WRITE(numout,*) ' Logical switch for S profile observations ln_s3d = ', ln_s3d + WRITE(numout,*) ' Logical switch for SLA observations ln_sla = ', ln_sla + WRITE(numout,*) ' Logical switch for SST observations ln_sst = ', ln_sst + WRITE(numout,*) ' Logical switch for Sea Ice observations ln_sic = ', ln_sic + WRITE(numout,*) ' Logical switch for velocity observations ln_vel3d = ', ln_vel3d + WRITE(numout,*) ' Logical switch for SSS observations ln_sss = ', ln_sss + WRITE(numout,*) ' Global distribution of observations ln_grid_global = ', ln_grid_global + WRITE(numout,*) ' Logical switch for obs grid search lookup ln_grid_search_lookup = ', ln_grid_search_lookup + IF (ln_grid_search_lookup) & + WRITE(numout,*) ' Grid search lookup file header cn_gridsearchfile = ', cn_gridsearchfile + WRITE(numout,*) ' Initial date in window YYYYMMDD.HHMMSS rn_dobsini = ', rn_dobsini + WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS rn_dobsend = ', rn_dobsend + WRITE(numout,*) ' Type of vertical interpolation method nn_1dint = ', nn_1dint + WRITE(numout,*) ' Default horizontal interpolation method nn_2dint_default = ', nn_2dint_default + WRITE(numout,*) ' Type of horizontal interpolation method for SLA nn_2dint_sla = ', nn_2dint_sla + WRITE(numout,*) ' Type of horizontal interpolation method for SST nn_2dint_sst = ', nn_2dint_sst + WRITE(numout,*) ' Type of horizontal interpolation method for SSS nn_2dint_sss = ', nn_2dint_sss + WRITE(numout,*) ' Type of horizontal interpolation method for SIC nn_2dint_sic = ', nn_2dint_sic + WRITE(numout,*) ' Default E/W diameter of obs footprint rn_default_avglamscl = ', rn_default_avglamscl + WRITE(numout,*) ' Default N/S diameter of obs footprint rn_default_avgphiscl = ', rn_default_avgphiscl + WRITE(numout,*) ' Default obs footprint in deg [T] or m [F] ln_default_fp_indegs = ', ln_default_fp_indegs + WRITE(numout,*) ' SLA E/W diameter of obs footprint rn_sla_avglamscl = ', rn_sla_avglamscl + WRITE(numout,*) ' SLA N/S diameter of obs footprint rn_sla_avgphiscl = ', rn_sla_avgphiscl + WRITE(numout,*) ' SLA obs footprint in deg [T] or m [F] ln_sla_fp_indegs = ', ln_sla_fp_indegs + WRITE(numout,*) ' SST E/W diameter of obs footprint rn_sst_avglamscl = ', rn_sst_avglamscl + WRITE(numout,*) ' SST N/S diameter of obs footprint rn_sst_avgphiscl = ', rn_sst_avgphiscl + WRITE(numout,*) ' SST obs footprint in deg [T] or m [F] ln_sst_fp_indegs = ', ln_sst_fp_indegs + WRITE(numout,*) ' SIC E/W diameter of obs footprint rn_sic_avglamscl = ', rn_sic_avglamscl + WRITE(numout,*) ' SIC N/S diameter of obs footprint rn_sic_avgphiscl = ', rn_sic_avgphiscl + WRITE(numout,*) ' SIC obs footprint in deg [T] or m [F] ln_sic_fp_indegs = ', ln_sic_fp_indegs + WRITE(numout,*) ' Rejection of observations near land switch ln_nea = ', ln_nea + WRITE(numout,*) ' Rejection of obs near open bdys ln_bound_reject = ', ln_bound_reject + WRITE(numout,*) ' MSSH correction scheme nn_msshc = ', nn_msshc + WRITE(numout,*) ' MDT correction rn_mdtcorr = ', rn_mdtcorr + WRITE(numout,*) ' MDT cutoff for computed correction rn_mdtcutoff = ', rn_mdtcutoff + WRITE(numout,*) ' Logical switch for alt bias ln_altbias = ', ln_altbias + WRITE(numout,*) ' Logical switch for sst bias ln_sstbias = ', ln_sstbias + WRITE(numout,*) ' Logical switch for ignoring missing files ln_ignmis = ', ln_ignmis + WRITE(numout,*) ' Daily average types nn_profdavtypes = ', nn_profdavtypes + WRITE(numout,*) ' Logical switch for night-time SST obs ln_sstnight = ', ln_sstnight + ENDIF + !----------------------------------------------------------------------- + ! Set up list of observation types to be used + ! and the files associated with each type + !----------------------------------------------------------------------- + + nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) ) + nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic, ln_sss /) ) + + IF( ln_sstbias ) THEN + lmask(:) = .FALSE. + WHERE( cn_sstbiasfiles(:) /= '' ) lmask(:) = .TRUE. + jnumsstbias = COUNT(lmask) + lmask(:) = .FALSE. + ENDIF + + IF( nproftypes == 0 .AND. nsurftypes == 0 ) THEN + CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, but all obs operator logical flags', & + & ' (ln_t3d, ln_s3d, ln_sla, ln_sst, ln_sic, ln_vel3d)', & + & ' are set to .FALSE. so turning off calls to dia_obs' ) + ln_diaobs = .FALSE. + RETURN + ENDIF + + IF( nproftypes > 0 ) THEN + ! + ALLOCATE( cobstypesprof(nproftypes) ) + ALLOCATE( ifilesprof (nproftypes) ) + ALLOCATE( clproffiles (nproftypes,jpmaxnfiles) ) + ! + jtype = 0 + IF( ln_t3d .OR. ln_s3d ) THEN + jtype = jtype + 1 + cobstypesprof(jtype) = 'prof' + clproffiles(jtype,:) = cn_profbfiles + ENDIF + IF( ln_vel3d ) THEN + jtype = jtype + 1 + cobstypesprof(jtype) = 'vel' + clproffiles(jtype,:) = cn_velfbfiles + ENDIF + ! + CALL obs_settypefiles( nproftypes, jpmaxnfiles, ifilesprof, cobstypesprof, clproffiles ) + ! + ENDIF + + IF( nsurftypes > 0 ) THEN + ! + ALLOCATE( cobstypessurf(nsurftypes) ) + ALLOCATE( ifilessurf (nsurftypes) ) + ALLOCATE( clsurffiles (nsurftypes,jpmaxnfiles) ) + ALLOCATE( n2dintsurf (nsurftypes) ) + ALLOCATE( zavglamscl (nsurftypes) ) + ALLOCATE( zavgphiscl (nsurftypes) ) + ALLOCATE( lfpindegs (nsurftypes) ) + ALLOCATE( llnightav (nsurftypes) ) + ! + jtype = 0 + IF( ln_sla ) THEN + jtype = jtype + 1 + cobstypessurf(jtype) = 'sla' + clsurffiles(jtype,:) = cn_slafbfiles + ENDIF + IF( ln_sst ) THEN + jtype = jtype + 1 + cobstypessurf(jtype) = 'sst' + clsurffiles(jtype,:) = cn_sstfbfiles + ENDIF + IF( ln_sss ) THEN + jtype = jtype + 1 + cobstypessurf(jtype) = 'sss' + clsurffiles(jtype,:) = cn_sssfbfiles + ENDIF + ! + CALL obs_settypefiles( nsurftypes, jpmaxnfiles, ifilessurf, cobstypessurf, clsurffiles ) + + DO jtype = 1, nsurftypes + + IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN + IF ( nn_2dint_sla == -1 ) THEN + n2dint_type = nn_2dint_default + ELSE + n2dint_type = nn_2dint_sla + ENDIF + ztype_avglamscl = rn_sla_avglamscl + ztype_avgphiscl = rn_sla_avgphiscl + ltype_fp_indegs = ln_sla_fp_indegs + ltype_night = .FALSE. + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN + IF ( nn_2dint_sst == -1 ) THEN + n2dint_type = nn_2dint_default + ELSE + n2dint_type = nn_2dint_sst + ENDIF + ztype_avglamscl = rn_sst_avglamscl + ztype_avgphiscl = rn_sst_avgphiscl + ltype_fp_indegs = ln_sst_fp_indegs + ltype_night = ln_sstnight + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN + IF ( nn_2dint_sic == -1 ) THEN + n2dint_type = nn_2dint_default + ELSE + n2dint_type = nn_2dint_sic + ENDIF + ztype_avglamscl = rn_sic_avglamscl + ztype_avgphiscl = rn_sic_avgphiscl + ltype_fp_indegs = ln_sic_fp_indegs + ltype_night = .FALSE. + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN + IF ( nn_2dint_sss == -1 ) THEN + n2dint_type = nn_2dint_default + ELSE + n2dint_type = nn_2dint_sss + ENDIF + ztype_avglamscl = rn_sss_avglamscl + ztype_avgphiscl = rn_sss_avgphiscl + ltype_fp_indegs = ln_sss_fp_indegs + ltype_night = .FALSE. + ELSE + n2dint_type = nn_2dint_default + ztype_avglamscl = rn_default_avglamscl + ztype_avgphiscl = rn_default_avgphiscl + ltype_fp_indegs = ln_default_fp_indegs + ltype_night = .FALSE. + ENDIF + + CALL obs_setinterpopts( nsurftypes, jtype, TRIM(cobstypessurf(jtype)), & + & nn_2dint_default, n2dint_type, & + & ztype_avglamscl, ztype_avgphiscl, & + & ltype_fp_indegs, ltype_night, & + & n2dintsurf, zavglamscl, zavgphiscl, & + & lfpindegs, llnightav ) + + END DO + ! + ENDIF + + + !----------------------------------------------------------------------- + ! Obs operator parameter checking and initialisations + !----------------------------------------------------------------------- + ! + IF( ln_vel3d .AND. .NOT.ln_grid_global ) THEN + CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' ) + RETURN + ENDIF + ! + IF( ln_grid_global ) THEN + CALL ctl_warn( 'dia_obs_init: ln_grid_global=T may cause memory issues when used with a large number of processors' ) + ENDIF + ! + IF( nn_1dint < 0 .OR. nn_1dint > 1 ) THEN + CALL ctl_stop('dia_obs_init: Choice of vertical (1D) interpolation method is not available') + ENDIF + ! + IF( nn_2dint_default < 0 .OR. nn_2dint_default > 6 ) THEN + CALL ctl_stop('dia_obs_init: Choice of default horizontal (2D) interpolation method is not available') + ENDIF + ! + CALL obs_typ_init + IF( ln_grid_global ) CALL mppmap_init + ! + CALL obs_grid_setup( ) + + !----------------------------------------------------------------------- + ! Depending on switches read the various observation types + !----------------------------------------------------------------------- + ! + IF( nproftypes > 0 ) THEN + ! + ALLOCATE( profdata (nproftypes) , nvarsprof (nproftypes) ) + ALLOCATE( profdataqc(nproftypes) , nextrprof (nproftypes) ) + ! + DO jtype = 1, nproftypes + ! + IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN + nvarsprof(jtype) = 2 + nextrprof(jtype) = 1 + ALLOCATE( llvar (nvarsprof(jtype)) ) + ALLOCATE( clvars(nvarsprof(jtype)) ) + ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) + llvar(1) = ln_t3d + llvar(2) = ln_s3d + clvars(1) = 'POTM' + clvars(2) = 'PSAL' + zglam(:,:,1) = glamt(:,:) + zglam(:,:,2) = glamt(:,:) + zgphi(:,:,1) = gphit(:,:) + zgphi(:,:,2) = gphit(:,:) + zmask(:,:,:,1) = tmask(:,:,:) + zmask(:,:,:,2) = tmask(:,:,:) + ELSE IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN + nvarsprof(jtype) = 2 + nextrprof(jtype) = 2 + ALLOCATE( llvar (nvarsprof(jtype)) ) + ALLOCATE( clvars(nvarsprof(jtype)) ) + ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) + llvar(1) = ln_vel3d + llvar(2) = ln_vel3d + clvars(1) = 'UVEL' + clvars(2) = 'VVEL' + zglam(:,:,1) = glamu(:,:) + zglam(:,:,2) = glamv(:,:) + zgphi(:,:,1) = gphiu(:,:) + zgphi(:,:,2) = gphiv(:,:) + zmask(:,:,:,1) = umask(:,:,:) + zmask(:,:,:,2) = vmask(:,:,:) + ELSE + nvarsprof(jtype) = 1 + nextrprof(jtype) = 0 + ALLOCATE( llvar (nvarsprof(jtype)) ) + ALLOCATE( clvars(nvarsprof(jtype)) ) + ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) + llvar(1) = .TRUE. + zglam(:,:,1) = glamt(:,:) + zgphi(:,:,1) = gphit(:,:) + zmask(:,:,:,1) = tmask(:,:,:) + ENDIF + ! + ! Read in profile or profile obs types + CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype), & + & clproffiles(jtype,1:ifilesprof(jtype)), & + & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & + & rn_dobsini, rn_dobsend, llvar, & + & ln_ignmis, ln_s_at_t, .FALSE., clvars, & + & kdailyavtypes = nn_profdavtypes ) + ! + DO jvar = 1, nvarsprof(jtype) + CALL obs_prof_staend( profdata(jtype), jvar ) + END DO + ! + CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & + & llvar, & + & jpi, jpj, jpk, & + & zmask, zglam, zgphi, & + & ln_nea, ln_bound_reject, Kmm, & + & kdailyavtypes = nn_profdavtypes ) + ! + DEALLOCATE( llvar, clvars, zglam, zgphi, zmask ) + ! + END DO + ! + DEALLOCATE( ifilesprof, clproffiles ) + ! + ENDIF + ! + IF( nsurftypes > 0 ) THEN + ! + ALLOCATE( surfdata (nsurftypes) , nvarssurf(nsurftypes) ) + ALLOCATE( surfdataqc(nsurftypes) , nextrsurf(nsurftypes) ) + ! + DO jtype = 1, nsurftypes + ! + nvarssurf(jtype) = 1 + nextrsurf(jtype) = 0 + llnightav(jtype) = .FALSE. + IF( TRIM(cobstypessurf(jtype)) == 'sla' ) nextrsurf(jtype) = 2 + IF( TRIM(cobstypessurf(jtype)) == 'sst' ) llnightav(jtype) = ln_sstnight + ! + ALLOCATE( clvars( nvarssurf(jtype) ) ) + IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN + clvars(1) = 'SLA' + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN + clvars(1) = 'SST' + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN + clvars(1) = 'ICECONC' + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN + clvars(1) = 'SSS' + ENDIF + ! + ! Read in surface obs types + CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & + & clsurffiles(jtype,1:ifilessurf(jtype)), & + & nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & + & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype), & + & clvars ) + ! + CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject ) + ! + IF( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN + CALL obs_rea_mdt( surfdataqc(jtype), n2dintsurf(jtype), Kmm ) + IF( ln_altbias ) & + & CALL obs_rea_altbias ( surfdataqc(jtype), n2dintsurf(jtype), cn_altbiasfile ) + ENDIF + ! + IF( TRIM(cobstypessurf(jtype)) == 'sst' .AND. ln_sstbias ) THEN + jnumsstbias = 0 + DO jfile = 1, jpmaxnfiles + IF( TRIM(cn_sstbiasfiles(jfile)) /= '' ) jnumsstbias = jnumsstbias + 1 + END DO + IF( jnumsstbias == 0 ) CALL ctl_stop("ln_sstbias set but no bias files to read in") + ! + CALL obs_app_sstbias( surfdataqc(jtype), n2dintsurf(jtype) , & + & jnumsstbias , cn_sstbiasfiles(1:jnumsstbias) ) + ENDIF + ! + DEALLOCATE( clvars ) + END DO + ! + DEALLOCATE( ifilessurf, clsurffiles ) + ! + ENDIF + ! + END SUBROUTINE dia_obs_init + + + SUBROUTINE dia_obs( kstp, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_obs *** + !! + !! ** Purpose : Call the observation operators on each time step + !! + !! ** Method : Call the observation operators on each time step to + !! compute the model equivalent of the following data: + !! - Profile data, currently T/S or U/V + !! - Surface data, currently SST, SLA or sea-ice concentration. + !! + !! ** Action : + !!---------------------------------------------------------------------- + USE phycst , ONLY : rday ! Physical constants + USE oce , ONLY : ts, uu, vv, ssh ! Ocean dynamics and tracers variables (Kmm time-level only) + USE phycst , ONLY : rday ! Physical constants + + IMPLICIT NONE + + !! * Arguments + INTEGER, INTENT(IN) :: kstp ! Current timestep + INTEGER, INTENT(in) :: Kmm ! ocean time level indices + !! * Local declarations + INTEGER :: idaystp ! Number of timesteps per day + INTEGER :: jtype ! Data loop variable + INTEGER :: jvar ! Variable number + INTEGER :: ji, jj, jk ! Loop counters + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & + & zprofvar ! Model values for variables in a prof ob + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & + & zprofmask ! Mask associated with zprofvar + REAL(wp), DIMENSION(jpi,jpj) :: & + & zsurfvar, & ! Model values equivalent to surface ob. + & zsurfmask ! Mask associated with surface variable + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zglam, & ! Model longitudes for prof variables + & zgphi ! Model latitudes for prof variables + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zdept, zdepw + + !----------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_obs : Call the observation operators', kstp + WRITE(numout,*) '~~~~~~~' + ENDIF + + idaystp = NINT( rday / rn_Dt ) + + !----------------------------------------------------------------------- + ! Call the profile and surface observation operators + !----------------------------------------------------------------------- + + IF ( nproftypes > 0 ) THEN + + ALLOCATE( zdept(jpi,jpj,jpk), zdepw(jpi,jpj,jpk) ) + DO jk = 1, jpk + zdept(:,:,jk) = (gdept_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) + zdepw(:,:,jk) = (gdepw_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) + END DO + + DO jtype = 1, nproftypes + + ! Allocate local work arrays + ALLOCATE( zprofvar (jpi, jpj, jpk, profdataqc(jtype)%nvar) ) + ALLOCATE( zprofmask(jpi, jpj, jpk, profdataqc(jtype)%nvar) ) + ALLOCATE( zglam (jpi, jpj, profdataqc(jtype)%nvar) ) + ALLOCATE( zgphi (jpi, jpj, profdataqc(jtype)%nvar) ) + + ! Defaults which might change + DO jvar = 1, profdataqc(jtype)%nvar + zprofmask(:,:,:,jvar) = tmask(:,:,:) + zglam(:,:,jvar) = glamt(:,:) + zgphi(:,:,jvar) = gphit(:,:) + END DO + + SELECT CASE ( TRIM(cobstypesprof(jtype)) ) + CASE('prof') + zprofvar(:,:,:,1) = ts(:,:,:,jp_tem,Kmm) + zprofvar(:,:,:,2) = ts(:,:,:,jp_sal,Kmm) + CASE('vel') + zprofvar(:,:,:,1) = uu(:,:,:,Kmm) + zprofvar(:,:,:,2) = vv(:,:,:,Kmm) + zprofmask(:,:,:,1) = umask(:,:,:) + zprofmask(:,:,:,2) = vmask(:,:,:) + zglam(:,:,1) = glamu(:,:) + zglam(:,:,2) = glamv(:,:) + zgphi(:,:,1) = gphiu(:,:) + zgphi(:,:,2) = gphiv(:,:) + CASE DEFAULT + CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) + END SELECT + + DO jvar = 1, profdataqc(jtype)%nvar + CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & + & nit000, idaystp, jvar, & + & zprofvar(:,:,:,jvar), & + & zdept(:,:,:), zdepw(:,:,:), & + & zprofmask(:,:,:,jvar), & + & zglam(:,:,jvar), zgphi(:,:,jvar), & + & nn_1dint, nn_2dint_default, & + & kdailyavtypes = nn_profdavtypes ) + END DO + + DEALLOCATE( zprofvar, zprofmask, zglam, zgphi ) + + END DO + + DEALLOCATE( zdept, zdepw ) + + ENDIF + + IF ( nsurftypes > 0 ) THEN + + DO jtype = 1, nsurftypes + + !Defaults which might be changed + zsurfmask(:,:) = tmask(:,:,1) + + SELECT CASE ( TRIM(cobstypessurf(jtype)) ) + CASE('sst') + zsurfvar(:,:) = ts(:,:,1,jp_tem,Kmm) + CASE('sla') + zsurfvar(:,:) = ssh(:,:,Kmm) + CASE('sss') + zsurfvar(:,:) = ts(:,:,1,jp_sal,Kmm) + CASE('sic') + IF ( kstp == 0 ) THEN + IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN + CALL ctl_warn( 'Sea-ice not initialised on zeroth '// & + & 'time-step but some obs are valid then.' ) + WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), & + & ' sea-ice obs will be missed' + ENDIF + surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + & + & surfdataqc(jtype)%nsstp(1) + CYCLE + ELSE + CALL ctl_stop( ' Trying to run sea-ice observation operator', & + & ' but no sea-ice model appears to have been defined' ) + ENDIF + + END SELECT + + CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj, & + & nit000, idaystp, zsurfvar, zsurfmask, & + & n2dintsurf(jtype), llnightav(jtype), & + & zavglamscl(jtype), zavgphiscl(jtype), & + & lfpindegs(jtype) ) + + END DO + + ENDIF + + END SUBROUTINE dia_obs + + SUBROUTINE dia_obs_wri + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_obs_wri *** + !! + !! ** Purpose : Call observation diagnostic output routines + !! + !! ** Method : Call observation diagnostic output routines + !! + !! ** Action : + !! + !! History : + !! ! 06-03 (K. Mogensen) Original code + !! ! 06-05 (K. Mogensen) Reformatted + !! ! 06-10 (A. Weaver) Cleaning + !! ! 07-03 (K. Mogensen) General handling of profiles + !! ! 08-09 (M. Valdivieso) Velocity component (U,V) profiles + !! ! 15-08 (M. Martin) Combined writing for prof and surf types + !!---------------------------------------------------------------------- + !! * Modules used + USE obs_rot_vel ! Rotation of velocities + + IMPLICIT NONE + + !! * Local declarations + INTEGER :: jtype ! Data set loop variable + INTEGER :: jo, jvar, jk + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zu, & + & zv + + !----------------------------------------------------------------------- + ! Depending on switches call various observation output routines + !----------------------------------------------------------------------- + + IF ( nproftypes > 0 ) THEN + + DO jtype = 1, nproftypes + + IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN + + ! For velocity data, rotate the model velocities to N/S, E/W + ! using the compressed data structure. + ALLOCATE( & + & zu(profdataqc(jtype)%nvprot(1)), & + & zv(profdataqc(jtype)%nvprot(2)) & + & ) + + CALL obs_rotvel( profdataqc(jtype), nn_2dint_default, zu, zv ) + + DO jo = 1, profdataqc(jtype)%nprof + DO jvar = 1, 2 + DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar) + + IF ( jvar == 1 ) THEN + profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk) + ELSE + profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk) + ENDIF + + END DO + END DO + END DO + + DEALLOCATE( zu ) + DEALLOCATE( zv ) + + END IF + + CALL obs_prof_decompress( profdataqc(jtype), & + & profdata(jtype), .TRUE., numout ) + + CALL obs_wri_prof( profdata(jtype) ) + + END DO + + ENDIF + + IF ( nsurftypes > 0 ) THEN + + DO jtype = 1, nsurftypes + + CALL obs_surf_decompress( surfdataqc(jtype), & + & surfdata(jtype), .TRUE., numout ) + + CALL obs_wri_surf( surfdata(jtype) ) + + END DO + + ENDIF + + END SUBROUTINE dia_obs_wri + + SUBROUTINE dia_obs_dealloc + IMPLICIT NONE + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_obs_dealloc *** + !! + !! ** Purpose : To deallocate data to enable the obs_oper online loop. + !! Specifically: dia_obs_init --> dia_obs --> dia_obs_wri + !! + !! ** Method : Clean up various arrays left behind by the obs_oper. + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + ! obs_grid deallocation + CALL obs_grid_deallocate + + ! diaobs deallocation + IF ( nproftypes > 0 ) & + & DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof ) + + IF ( nsurftypes > 0 ) & + & DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf, & + & n2dintsurf, zavglamscl, zavgphiscl, lfpindegs, llnightav ) + + END SUBROUTINE dia_obs_dealloc + + SUBROUTINE calc_date( kstp, ddobs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE calc_date *** + !! + !! ** Purpose : Get date in double precision YYYYMMDD.HHMMSS format + !! + !! ** Method : Get date in double precision YYYYMMDD.HHMMSS format + !! + !! ** Action : Get date in double precision YYYYMMDD.HHMMSS format + !! + !! ** Action : Get initial date in double precision YYYYMMDD.HHMMSS format + !! + !! History : + !! ! 06-03 (K. Mogensen) Original code + !! ! 06-05 (K. Mogensen) Reformatted + !! ! 06-10 (A. Weaver) Cleaning + !! ! 06-10 (G. Smith) Calculates initial date the same as method for final date + !! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2 + !! ! 2014-09 (D. Lea) New generic routine now deals with arbitrary initial time of day + !!---------------------------------------------------------------------- + USE phycst, ONLY : & ! Physical constants + & rday + USE dom_oce, ONLY : & ! Ocean space and time domain variables + & rn_Dt + + IMPLICIT NONE + + !! * Arguments + REAL(KIND=wp), INTENT(OUT) :: ddobs ! Date in YYYYMMDD.HHMMSS + INTEGER, INTENT(IN) :: kstp + + !! * Local declarations + INTEGER :: iyea ! date - (year, month, day, hour, minute) + INTEGER :: imon + INTEGER :: iday + INTEGER :: ihou + INTEGER :: imin + INTEGER :: imday ! Number of days in month. + REAL(wp) :: zdayfrc ! Fraction of day + + INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year + + !!---------------------------------------------------------------------- + !! Initial date initialization (year, month, day, hour, minute) + !!---------------------------------------------------------------------- + iyea = ndate0 / 10000 + imon = ( ndate0 - iyea * 10000 ) / 100 + iday = ndate0 - iyea * 10000 - imon * 100 + ihou = nn_time0 / 100 + imin = ( nn_time0 - ihou * 100 ) + + !!---------------------------------------------------------------------- + !! Compute number of days + number of hours + min since initial time + !!---------------------------------------------------------------------- + zdayfrc = kstp * rn_Dt / rday + zdayfrc = zdayfrc - aint(zdayfrc) + imin = imin + int( zdayfrc * 24 * 60 ) + DO WHILE (imin >= 60) + imin=imin-60 + ihou=ihou+1 + END DO + DO WHILE (ihou >= 24) + ihou=ihou-24 + iday=iday+1 + END DO + iday = iday + kstp * rn_Dt / rday + + !----------------------------------------------------------------------- + ! Convert number of days (iday) into a real date + !---------------------------------------------------------------------- + + CALL calc_month_len( iyea, imonth_len ) + + DO WHILE ( iday > imonth_len(imon) ) + iday = iday - imonth_len(imon) + imon = imon + 1 + IF ( imon > 12 ) THEN + imon = 1 + iyea = iyea + 1 + CALL calc_month_len( iyea, imonth_len ) ! update month lengths + ENDIF + END DO + + !---------------------------------------------------------------------- + ! Convert it into YYYYMMDD.HHMMSS format. + !---------------------------------------------------------------------- + ddobs = iyea * 10000_dp + imon * 100_dp + & + & iday + ihou * 0.01_dp + imin * 0.0001_dp + + END SUBROUTINE calc_date + + SUBROUTINE ini_date( ddobsini ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ini_date *** + !! + !! ** Purpose : Get initial date in double precision YYYYMMDD.HHMMSS format + !! + !! ** Method : + !! + !! ** Action : + !! + !! History : + !! ! 06-03 (K. Mogensen) Original code + !! ! 06-05 (K. Mogensen) Reformatted + !! ! 06-10 (A. Weaver) Cleaning + !! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2 + !! ! 2014-09 (D. Lea) Change to call generic routine calc_date + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + !! * Arguments + REAL(KIND=wp), INTENT(OUT) :: ddobsini ! Initial date in YYYYMMDD.HHMMSS + + CALL calc_date( nit000 - 1, ddobsini ) + + END SUBROUTINE ini_date + + SUBROUTINE fin_date( ddobsfin ) + !!---------------------------------------------------------------------- + !! *** ROUTINE fin_date *** + !! + !! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format + !! + !! ** Method : + !! + !! ** Action : + !! + !! History : + !! ! 06-03 (K. Mogensen) Original code + !! ! 06-05 (K. Mogensen) Reformatted + !! ! 06-10 (A. Weaver) Cleaning + !! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2 + !! ! 2014-09 (D. Lea) Change to call generic routine calc_date + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + !! * Arguments + REAL(wp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS + + CALL calc_date( nitend, ddobsfin ) + + END SUBROUTINE fin_date + + SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, ifiles, cobstypes, cfiles ) + + INTEGER, INTENT(IN) :: ntypes ! Total number of obs types + INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type + INTEGER, DIMENSION(ntypes), INTENT(OUT) :: & + & ifiles ! Out number of files for each type + CHARACTER(len=lca), DIMENSION(ntypes), INTENT(IN) :: & + & cobstypes ! List of obs types + CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(IN) :: & + & cfiles ! List of files for all types + + !Local variables + INTEGER :: jfile + INTEGER :: jtype + + DO jtype = 1, ntypes + + ifiles(jtype) = 0 + DO jfile = 1, jpmaxnfiles + IF ( trim(cfiles(jtype,jfile)) /= '' ) & + ifiles(jtype) = ifiles(jtype) + 1 + END DO + + IF ( ifiles(jtype) == 0 ) THEN + CALL ctl_stop( 'Logical for observation type '//TRIM(cobstypes(jtype))// & + & ' set to true but no files available to read' ) + ENDIF + + IF(lwp) THEN + WRITE(numout,*) ' '//cobstypes(jtype)//' input observation file names:' + DO jfile = 1, ifiles(jtype) + WRITE(numout,*) ' '//TRIM(cfiles(jtype,jfile)) + END DO + ENDIF + + END DO + + END SUBROUTINE obs_settypefiles + + SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein, & + & n2dint_default, n2dint_type, & + & ravglamscl_type, ravgphiscl_type, & + & lfp_indegs_type, lavnight_type, & + & n2dint, ravglamscl, ravgphiscl, & + & lfpindegs, lavnight ) + + INTEGER, INTENT(IN) :: ntypes ! Total number of obs types + INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs + INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolation type + INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolation type + REAL(wp), INTENT(IN) :: & + & ravglamscl_type, & !E/W diameter of obs footprint for this type + & ravgphiscl_type !N/S diameter of obs footprint for this type + LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres + LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average + CHARACTER(len=8), INTENT(IN) :: ctypein + + INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & + & n2dint + REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & + & ravglamscl, ravgphiscl + LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & + & lfpindegs, lavnight + + lavnight(jtype) = lavnight_type + + IF ( (n2dint_type >= 0) .AND. (n2dint_type <= 6) ) THEN + n2dint(jtype) = n2dint_type + ELSE IF ( n2dint_type == -1 ) THEN + n2dint(jtype) = n2dint_default + ELSE + CALL ctl_stop(' Choice of '//TRIM(ctypein)//' horizontal (2D) interpolation method', & + & ' is not available') + ENDIF + + ! For averaging observation footprints set options for size of footprint + IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN + IF ( ravglamscl_type > 0._wp ) THEN + ravglamscl(jtype) = ravglamscl_type + ELSE + CALL ctl_stop( 'Incorrect value set for averaging footprint '// & + 'scale (ravglamscl) for observation type '//TRIM(ctypein) ) + ENDIF + + IF ( ravgphiscl_type > 0._wp ) THEN + ravgphiscl(jtype) = ravgphiscl_type + ELSE + CALL ctl_stop( 'Incorrect value set for averaging footprint '// & + 'scale (ravgphiscl) for observation type '//TRIM(ctypein) ) + ENDIF + + lfpindegs(jtype) = lfp_indegs_type + + ENDIF + + ! Write out info + IF(lwp) THEN + IF ( n2dint(jtype) <= 4 ) THEN + WRITE(numout,*) ' '//TRIM(ctypein)// & + & ' model counterparts will be interpolated horizontally' + ELSE IF ( n2dint(jtype) <= 6 ) THEN + WRITE(numout,*) ' '//TRIM(ctypein)// & + & ' model counterparts will be averaged horizontally' + WRITE(numout,*) ' '//' with E/W scale: ',ravglamscl(jtype) + WRITE(numout,*) ' '//' with N/S scale: ',ravgphiscl(jtype) + IF ( lfpindegs(jtype) ) THEN + WRITE(numout,*) ' '//' (in degrees)' + ELSE + WRITE(numout,*) ' '//' (in metres)' + ENDIF + ENDIF + ENDIF + + END SUBROUTINE obs_setinterpopts + +END MODULE diaobs diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diaptr.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diaptr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..daf3b0356b517b3f666bc78a26df20fdbf06b9af --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diaptr.f90 @@ -0,0 +1,792 @@ + + + + + + + + + + + + + +MODULE diaptr + !!====================================================================== + !! *** MODULE diaptr *** + !! Ocean physics: Computes meridonal transports and zonal means + !!===================================================================== + !! History : 1.0 ! 2003-09 (C. Talandier, G. Madec) Original code + !! 2.0 ! 2006-01 (A. Biastoch) Allow sub-basins computation + !! 3.2 ! 2010-03 (O. Marti, S. Flavoni) Add fields + !! 3.3 ! 2010-10 (G. Madec) dynamical allocation + !! 3.6 ! 2014-12 (C. Ethe) use of IOM + !! 3.6 ! 2016-06 (T. Graham) Addition of diagnostics for CMIP6 + !! 4.0 ! 2010-08 ( C. Ethe, J. Deshayes ) Improvment + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dia_ptr : Poleward Transport Diagnostics module + !! dia_ptr_init : Initialization, namelist read + !! ptr_sjk : "zonal" mean computation of a field - tracer or flux array + !! ptr_sj : "zonal" and vertical sum computation of a "meridional" flux array + !! (Generic interface to ptr_sj_3d, ptr_sj_2d) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domtile + USE phycst ! physical constants + ! + USE iom ! IOM library + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + INTERFACE ptr_sum + MODULE PROCEDURE ptr_sum_3d, ptr_sum_2d + END INTERFACE + + INTERFACE ptr_sj + MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d + END INTERFACE + + PUBLIC dia_ptr ! call in step module + PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: pvtr_int, pzon_int !: Other zonal integrals + + LOGICAL, PUBLIC :: l_diaptr !: tracers trend flag + INTEGER, PARAMETER :: jp_msk = 3 + INTEGER, PARAMETER :: jp_vtr = 4 + + REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup + REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rho0 x Cp) + REAL(wp) :: rc_ggram = 1.e-9_wp ! conversion from g to Gg (further x rho0) + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) + + LOGICAL :: ll_init = .TRUE. !: tracers trend flag + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diaptr.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + ! NOTE: [tiling] tiling sometimes changes the diagnostics very slightly, usually where there are few zonal points e.g. the northern Indian Ocean basin. The difference is usually very small, for one point in one diagnostic. Presumably this is because of the additional zonal integration step over tiles. + SUBROUTINE dia_ptr( kt, Kmm, pvtr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_ptr') + + IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init ! -> will define l_diaptr and nbasin + ! + IF( l_diaptr ) THEN + ! Calculate zonal integrals + IF( PRESENT( pvtr ) ) THEN + CALL dia_ptr_zint( Kmm, pvtr ) + ELSE + CALL dia_ptr_zint( Kmm ) + ENDIF + + ! Calculate diagnostics only when zonal integrals have finished + IF( .NOT. l_istiled .OR. ntile == nijtile ) CALL dia_ptr_iom(kt, Kmm, pvtr) + ENDIF + + IF( ln_timing ) CALL timing_stop('dia_ptr') + ! + END SUBROUTINE dia_ptr + + + SUBROUTINE dia_ptr_iom( kt, Kmm, pvtr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_iom *** + !!---------------------------------------------------------------------- + !! ** Purpose : Calculate diagnostics and send to XIOS + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace + ! + !overturning calculation + REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse + REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function + + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: z4d1, z4d2 + REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: z3dtr + !!---------------------------------------------------------------------- + ! + ALLOCATE( z3dtr(jpi,jpj,nbasin) ) + + IF( PRESENT( pvtr ) ) THEN + IF( iom_use( 'zomsf' ) ) THEN ! effective MSF + ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) ) + ! + DO jn = 1, nbasin ! by sub-basins + z4d1(1,:,:,jn) = pvtr_int(:,:,jp_vtr,jn) ! zonal cumulative effective transport excluding closed seas + DO jk = jpkm1, 1, -1 + z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF) + END DO + DO ji = 2, jpi + z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) + ENDDO + END DO + CALL iom_put( 'zomsf', z4d1 * rc_sv ) + ! + DEALLOCATE( z4d1 ) + ENDIF + IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN + ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin), & + & zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) + ! + DO jn = 1, nbasin + sjk(:,:,jn) = pvtr_int(:,:,jp_msk,jn) + r1_sjk(:,:,jn) = 0._wp + WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) + ! i-mean T and S, j-Stream-Function, basin + zt_jk(:,:,jn) = pvtr_int(:,:,jp_tem,jn) * r1_sjk(:,:,jn) + zs_jk(:,:,jn) = pvtr_int(:,:,jp_sal,jn) * r1_sjk(:,:,jn) + v_msf(:,:,jn) = pvtr_int(:,:,jp_vtr,jn) + hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) + hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) + ! + ENDDO + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtove', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstove', z3dtr ) + ! + DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) + ENDIF + + IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN + ! Calculate barotropic heat and salt transport here + ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) + ! + DO jn = 1, nbasin + sjk(:,1,jn) = SUM( pvtr_int(:,:,jp_msk,jn), 2 ) + r1_sjk(:,1,jn) = 0._wp + WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) + ! + zvsum(:) = SUM( pvtr_int(:,:,jp_vtr,jn), 2 ) + ztsum(:) = SUM( pvtr_int(:,:,jp_tem,jn), 2 ) + zssum(:) = SUM( pvtr_int(:,:,jp_sal,jn), 2 ) + hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) + hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) + ! + ENDDO + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtbtr', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstbtr', z3dtr ) + ! + DEALLOCATE( sjk, r1_sjk ) + ENDIF + ! + hstr_ove(:,:,:) = 0._wp ! Zero before next timestep + hstr_btr(:,:,:) = 0._wp + pvtr_int(:,:,:,:) = 0._wp + ELSE + IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface + ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) + ! + DO jn = 1, nbasin + z4d1(1,:,:,jn) = pzon_int(:,:,jp_msk,jn) + DO ji = 2, jpi + z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) + ENDDO + ENDDO + CALL iom_put( 'zosrf', z4d1 ) + ! + DO jn = 1, nbasin + z4d2(1,:,:,jn) = pzon_int(:,:,jp_tem,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) + DO ji = 2, jpi + z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) + ENDDO + ENDDO + CALL iom_put( 'zotem', z4d2 ) + ! + DO jn = 1, nbasin + z4d2(1,:,:,jn) = pzon_int(:,:,jp_sal,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) + DO ji = 2, jpi + z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) + ENDDO + ENDDO + CALL iom_put( 'zosal', z4d2 ) + ! + DEALLOCATE( z4d1, z4d2 ) + ENDIF + ! + ! ! Advective and diffusive heat and salt transport + IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN + ! + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtadv', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstadv', z3dtr ) + ENDIF + ! + IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN + ! + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtldf', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstldf', z3dtr ) + ENDIF + ! + IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN + ! + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophteiv', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopsteiv', z3dtr ) + ENDIF + ! + IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtvtr', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstvtr', z3dtr ) + ENDIF + ! + IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN + CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml + z2d(:,:) = ptr_ci_2d( z2d(:,:) ) + CALL iom_put( 'uocetr_vsum_cumul', z2d ) + ENDIF + ! + hstr_adv(:,:,:) = 0._wp ! Zero before next timestep + hstr_ldf(:,:,:) = 0._wp + hstr_eiv(:,:,:) = 0._wp + hstr_vtr(:,:,:) = 0._wp + pzon_int(:,:,:,:) = 0._wp + ENDIF + ! + DEALLOCATE( z3dtr ) + ! + END SUBROUTINE dia_ptr_iom + + + SUBROUTINE dia_ptr_zint( Kmm, pvtr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_zint *** + !!---------------------------------------------------------------------- + !! ** Purpose : i and i-k sum operations on arrays + !! + !! ** Method : - Call ptr_sjk (i sum) or ptr_sj (i-k sum) to perform the sum operation + !! - Call ptr_sum to add this result to the sum over tiles + !! + !! ** Action : pvtr_int - terms for volume streamfunction, heat/salt transport barotropic/overturning terms + !! pzon_int - terms for i mean temperature/salinity + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmask ! 3D workspace + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zts ! 4D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: sjk, v_msf ! Zonal sum: i-k surface area, j-effective transport + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt_jk, zs_jk ! Zonal sum: i-k surface area * (T, S) + REAL(wp) :: zsfc, zvfc ! i-k surface area + INTEGER :: ji, jj, jk, jn ! dummy loop indices + !!---------------------------------------------------------------------- + + IF( PRESENT( pvtr ) ) THEN + ! i sum of effective j transport excluding closed seas + IF( iom_use( 'zomsf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN + ALLOCATE( v_msf(ntsj-(nn_hls):ntej+(nn_hls),jpk,nbasin) ) + + DO jn = 1, nbasin + v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) + ENDDO + + CALL ptr_sum( pvtr_int(:,:,jp_vtr,:), v_msf(:,:,:) ) + + DEALLOCATE( v_msf ) + ENDIF + + ! i sum of j surface area, j surface area - temperature/salinity product on V grid + IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & + & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN + ALLOCATE( zmask(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), zts(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk,jpts), & + & sjk(ntsj-(nn_hls):ntej+(nn_hls),jpk,nbasin), & + & zt_jk(ntsj-(nn_hls):ntej+(nn_hls),jpk,nbasin), zs_jk(ntsj-(nn_hls):ntej+(nn_hls),jpk,nbasin) ) + + zmask(:,:,:) = 0._wp + zts(:,:,:,:) = 0._wp + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 1) + zvfc = e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc + zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid + zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc + END DO ; END DO ; END DO + + DO jn = 1, nbasin + sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) + zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) + zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) + ENDDO + + CALL ptr_sum( pvtr_int(:,:,jp_msk,:), sjk(:,:,:) ) + CALL ptr_sum( pvtr_int(:,:,jp_tem,:), zt_jk(:,:,:) ) + CALL ptr_sum( pvtr_int(:,:,jp_sal,:), zs_jk(:,:,:) ) + + DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) + ENDIF + ELSE + ! i sum of j surface area - temperature/salinity product on T grid + IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN + ALLOCATE( zmask(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), zts(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk,jpts), & + & sjk(ntsj-(nn_hls):ntej+(nn_hls),jpk,nbasin), & + & zt_jk(ntsj-(nn_hls):ntej+(nn_hls),jpk,nbasin), zs_jk(ntsj-(nn_hls):ntej+(nn_hls),jpk,nbasin) ) + + zmask(:,:,:) = 0._wp + zts(:,:,:,:) = 0._wp + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + zsfc = e1t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc + zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc + zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc + END DO ; END DO ; END DO + + DO jn = 1, nbasin + sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) + zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) + zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) + ENDDO + + CALL ptr_sum( pzon_int(:,:,jp_msk,:), sjk(:,:,:) ) + CALL ptr_sum( pzon_int(:,:,jp_tem,:), zt_jk(:,:,:) ) + CALL ptr_sum( pzon_int(:,:,jp_sal,:), zs_jk(:,:,:) ) + + DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) + ENDIF + + ! i-k sum of j surface area - temperature/salinity product on V grid + IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN + ALLOCATE( zts(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk,jpts) ) + + zts(:,:,:,:) = 0._wp + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 1) + zvfc = e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid + zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc + END DO ; END DO ; END DO + + CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) + CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) + + DEALLOCATE( zts ) + ENDIF + ENDIF + END SUBROUTINE dia_ptr_zint + + + SUBROUTINE dia_ptr_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_init *** + !! + !! ** Purpose : Initialization + !!---------------------------------------------------------------------- + INTEGER :: inum, jn ! local integers + !! + REAL(wp), DIMENSION(jpi,jpj) :: zmsk + !!---------------------------------------------------------------------- + + ! l_diaptr is defined with iom_use + ! --> dia_ptr_init must be done after the call to iom_init + ! --> cannot be .TRUE. without cpp key: 1 --> nbasin define by iom_init is initialized + l_diaptr = iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. & + & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & + & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & + & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & + & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & + & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) + + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) l_diaptr = ', l_diaptr + ENDIF + + IF( l_diaptr ) THEN + ! + IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) + ! + rc_pwatt = rc_pwatt * rho0_rcp ! conversion from K.s-1 to PetaWatt + rc_ggram = rc_ggram * rho0 ! conversion from m3/s to Gg/s + + IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum + + btmsk(:,:,1) = tmask_i(:,:) + IF( nbasin == 5 ) THEN ! nbasin has been initialized in iom_init to define the axis "basin" + CALL iom_open( 'subbasins', inum ) + CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin + CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin + CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) ) ! Indian basin + CALL iom_close( inum ) + btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin + ENDIF + DO jn = 2, nbasin + btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only + END DO + ! JD : modification so that overturning streamfunction is available in Atlantic at 34S to compare with observations + WHERE( gphit(:,:)*tmask_i(:,:) < -34._wp) + zmsk(:,:) = 0._wp ! mask out Southern Ocean + ELSE WHERE + zmsk(:,:) = ssmask(:,:) + END WHERE + btmsk34(:,:,1) = btmsk(:,:,1) + DO jn = 2, nbasin + btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only + ENDDO + + ! Initialise arrays to zero because diatpr is called before they are first calculated + ! Note that this means diagnostics will not be exactly correct when model run is restarted. + hstr_adv(:,:,:) = 0._wp + hstr_ldf(:,:,:) = 0._wp + hstr_eiv(:,:,:) = 0._wp + hstr_ove(:,:,:) = 0._wp + hstr_btr(:,:,:) = 0._wp ! + hstr_vtr(:,:,:) = 0._wp ! + pvtr_int(:,:,:,:) = 0._wp + pzon_int(:,:,:,:) = 0._wp + ! + ll_init = .FALSE. + ! + ENDIF + ! + END SUBROUTINE dia_ptr_init + + + SUBROUTINE dia_ptr_hst( ktra, cptr, pvflx ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_hst *** + !!---------------------------------------------------------------------- + !! Wrapper for heat and salt transport calculations to calculate them for each basin + !! Called from all advection and/or diffusion routines + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktra ! tracer index + CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) , INTENT(in) :: pvflx ! 3D input array of advection/diffusion + REAL(wp), DIMENSION(ntsj-(nn_hls):ntej+(nn_hls),nbasin) :: zsj ! + INTEGER :: jn ! + + DO jn = 1, nbasin + zsj(:,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) + ENDDO + ! + IF( cptr == 'adv' ) THEN + IF( ktra == jp_tem ) CALL ptr_sum( hstr_adv(:,jp_tem,:), zsj(:,:) ) + IF( ktra == jp_sal ) CALL ptr_sum( hstr_adv(:,jp_sal,:), zsj(:,:) ) + ELSE IF( cptr == 'ldf' ) THEN + IF( ktra == jp_tem ) CALL ptr_sum( hstr_ldf(:,jp_tem,:), zsj(:,:) ) + IF( ktra == jp_sal ) CALL ptr_sum( hstr_ldf(:,jp_sal,:), zsj(:,:) ) + ELSE IF( cptr == 'eiv' ) THEN + IF( ktra == jp_tem ) CALL ptr_sum( hstr_eiv(:,jp_tem,:), zsj(:,:) ) + IF( ktra == jp_sal ) CALL ptr_sum( hstr_eiv(:,jp_sal,:), zsj(:,:) ) + ELSE IF( cptr == 'vtr' ) THEN + IF( ktra == jp_tem ) CALL ptr_sum( hstr_vtr(:,jp_tem,:), zsj(:,:) ) + IF( ktra == jp_sal ) CALL ptr_sum( hstr_vtr(:,jp_sal,:), zsj(:,:) ) + ENDIF + ! + END SUBROUTINE dia_ptr_hst + + + SUBROUTINE ptr_sum_2d( phstr, pva ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sum_2d *** + !!---------------------------------------------------------------------- + !! ** Purpose : Add two 2D arrays with (j,nbasin) dimensions + !! + !! ** Method : - phstr = phstr + pva + !! - Call mpp_sum if the final tile + !! + !! ** Action : phstr + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpj,nbasin) , INTENT(inout) :: phstr ! + REAL(wp), DIMENSION(ntsj-(nn_hls):ntej+(nn_hls),nbasin), INTENT(in) :: pva ! + INTEGER :: jj + INTEGER, DIMENSION(1) :: ish1d + INTEGER, DIMENSION(2) :: ish2d + REAL(wp), DIMENSION(jpj*nbasin) :: zwork + + DO jj = ntsj, ntej + phstr(jj,:) = phstr(jj,:) + pva(jj,:) + END DO + + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + ish1d(1) = jpj*nbasin + ish2d(1) = jpj ; ish2d(2) = nbasin + zwork(:) = RESHAPE( phstr(:,:), ish1d ) + CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) + phstr(:,:) = RESHAPE( zwork, ish2d ) + ENDIF + END SUBROUTINE ptr_sum_2d + + + SUBROUTINE ptr_sum_3d( phstr, pva ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sum_3d *** + !!---------------------------------------------------------------------- + !! ** Purpose : Add two 3D arrays with (j,k,nbasin) dimensions + !! + !! ** Method : - phstr = phstr + pva + !! - Call mpp_sum if the final tile + !! + !! ** Action : phstr + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpj,jpk,nbasin) , INTENT(inout) :: phstr ! + REAL(wp), DIMENSION(ntsj-(nn_hls):ntej+(nn_hls),jpk,nbasin), INTENT(in) :: pva ! + INTEGER :: jj, jk + INTEGER, DIMENSION(1) :: ish1d + INTEGER, DIMENSION(3) :: ish3d + REAL(wp), DIMENSION(jpj*jpk*nbasin) :: zwork + + DO jk = 1, jpk + DO jj = ntsj, ntej + phstr(jj,jk,:) = phstr(jj,jk,:) + pva(jj,jk,:) + END DO + END DO + + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + ish1d(1) = jpj*jpk*nbasin + ish3d(1) = jpj ; ish3d(2) = jpk ; ish3d(3) = nbasin + zwork(:) = RESHAPE( phstr(:,:,:), ish1d ) + CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) + phstr(:,:,:) = RESHAPE( zwork, ish3d ) + ENDIF + END SUBROUTINE ptr_sum_3d + + + FUNCTION dia_ptr_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: dia_ptr_alloc ! return value + INTEGER, DIMENSION(2) :: ierr + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ! nbasin has been initialized in iom_init to define the axis "basin" + ! + IF( .NOT. ALLOCATED( btmsk ) ) THEN + ALLOCATE( btmsk(jpi,jpj,nbasin) , btmsk34(jpi,jpj,nbasin), & + & hstr_adv(jpj,jpts,nbasin), hstr_eiv(jpj,jpts,nbasin), & + & hstr_ove(jpj,jpts,nbasin), hstr_btr(jpj,jpts,nbasin), & + & hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1) ) + ! + ALLOCATE( pvtr_int(jpj,jpk,jpts+2,nbasin), & + & pzon_int(jpj,jpk,jpts+1,nbasin), STAT=ierr(2) ) + ! + dia_ptr_alloc = MAXVAL( ierr ) + CALL mpp_sum( 'diaptr', dia_ptr_alloc ) + ENDIF + ! + END FUNCTION dia_ptr_alloc + + + FUNCTION ptr_sj_3d( pvflx, pmsk ) RESULT ( p_fval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sj_3d *** + !! + !! ** Purpose : i-k sum computation of a j-flux array + !! + !! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i). + !! pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v) + !! + !! ** Action : - p_fval: i-k-mean poleward flux of pvflx + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: pvflx ! mask flux array at V-point + REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask + ! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp), DIMENSION(ntsj-(nn_hls):ntej+(nn_hls)) :: p_fval ! function value + !!-------------------------------------------------------------------- + ! + p_fval(:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) + END DO ; END DO ; END DO + END FUNCTION ptr_sj_3d + + + FUNCTION ptr_sj_2d( pvflx, pmsk ) RESULT ( p_fval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sj_2d *** + !! + !! ** Purpose : "zonal" and vertical sum computation of a j-flux array + !! + !! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i). + !! pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v) + !! + !! ** Action : - p_fval: i-k-mean poleward flux of pvflx + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: pvflx ! mask flux array at V-point + REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask + ! + INTEGER :: ji,jj ! dummy loop arguments + REAL(wp), DIMENSION(ntsj-(nn_hls):ntej+(nn_hls)) :: p_fval ! function value + !!-------------------------------------------------------------------- + ! + p_fval(:) = 0._wp + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) + END DO ; END DO + END FUNCTION ptr_sj_2d + + FUNCTION ptr_ci_2d( pva ) RESULT ( p_fval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_ci_2d *** + !! + !! ** Purpose : "meridional" cumulated sum computation of a j-flux array + !! + !! ** Method : - j cumulated sum of pva using the interior 2D vmask (umask_i). + !! + !! ** Action : - p_fval: j-cumulated sum of pva + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point + ! + INTEGER :: ji,jj,jc ! dummy loop arguments + INTEGER :: ijpj ! ??? + REAL(wp), DIMENSION(jpi,jpj) :: p_fval ! function value + !!-------------------------------------------------------------------- + ! + ijpj = jpj ! ??? + p_fval(:,:) = 0._wp + DO jc = 1, jpnj ! looping over all processors in j axis + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) + END DO ; END DO + END DO + ! + END FUNCTION ptr_ci_2d + + + + FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sjk *** + !! + !! ** Purpose : i-sum computation of an array + !! + !! ** Method : - i-sum of field using the interior 2D vmask (pmsk). + !! + !! ** Action : - p_fval: i-sum of masked field + !!---------------------------------------------------------------------- + !! + IMPLICIT none + REAL(wp) , INTENT(in), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: pta ! mask flux array at V-point + REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask + !! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp), DIMENSION(ntsj-(nn_hls):ntej+(nn_hls),jpk) :: p_fval ! return function value + !!-------------------------------------------------------------------- + ! + p_fval(:,:) = 0._wp + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) + END DO ; END DO ; END DO + END FUNCTION ptr_sjk + + + !!====================================================================== +END MODULE diaptr diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diawri.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diawri.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fd634148636707dd0ee16bd4b37c40e58c4ce235 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diawri.f90 @@ -0,0 +1,674 @@ + + + + + + + + + + + + + +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 ! + + 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 + 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 + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! 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 + + !!---------------------------------------------------------------------- + !! '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(ntsi-( 0):ntei+( 0),ntsj-( 0):ntej+( 0)) :: z2d ! 2D workspace + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(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 jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO ; END DO + CALL iom_put( "tpt_dep", z3d ) + ENDIF + + ! --- vertical scale factors --- ! + IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN ! time-varying e3t + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + CALL iom_put( "e3t", z3d ) + IF ( iom_use("e3tdef") ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + 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 DO ; END DO ; END DO + CALL iom_put( "e3tdef", z3d ) + ENDIF + ENDIF + IF ( iom_use("e3u") ) THEN ! time-varying e3u + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + END DO ; END DO ; END DO + CALL iom_put( "e3u" , z3d ) + ENDIF + IF ( iom_use("e3v") ) THEN ! time-varying e3v + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + END DO ; END DO ; END DO + CALL iom_put( "e3v" , z3d ) + ENDIF + IF ( iom_use("e3w") ) THEN ! time-varying e3w + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO ; END DO + CALL iom_put( "e3w" , z3d ) + ENDIF + IF ( iom_use("e3f") ) THEN ! time-varying e3f caution here at Kaa + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = (e3f_0(ji,jj,jk)*(1._wp+r3f(ji,jj)*fe3mask(ji,jj,jk))) + END DO ; END DO ; END DO + 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( iom_use("ht") ) CALL iom_put( "ht" , (ht_0(:,:)*(1._wp+r3t(:,:,Kmm))) ) ! water column at t-point + IF( iom_use("hu") ) CALL iom_put( "hu" , (hu_0(:,:)*(1._wp+r3u(:,:,Kmm))) ) ! water column at u-point + IF( iom_use("hv") ) CALL iom_put( "hv" , (hv_0(:,:)*(1._wp+r3v(:,:,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) + + ! --- 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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ikbot = mbkt(ji,jj) + z2d(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm) + END DO ; END DO + 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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ikbot = mbkt(ji,jj) + z2d(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm) + END DO ; END DO + 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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 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 DO ; END DO + 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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ikbot = mbku(ji,jj) + z2d(ji,jj) = uu(ji,jj,ikbot,Kmm) + END DO ; END DO + 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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ikbot = mbkv(ji,jj) + z2d(ji,jj) = vv(ji,jj,ikbot,Kmm) + END DO ; END DO + CALL iom_put( "sbv", z2d ) ! bottom j-current + ENDIF + + ! ! vertical velocity + IF( ln_zad_Aimp ) THEN + IF( iom_use('woce') ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk) + END DO ; END DO ; END DO + 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 jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = rho0 * e1e2t(ji,jj) * ( ww(ji,jj,jk) + wi(ji,jj,jk) ) + END DO ; END DO ; END DO + ELSE + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = rho0 * e1e2t(ji,jj) * ww(ji,jj,jk) + END DO ; END DO ; END DO + 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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 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 DO ; END DO + CALL iom_put( "sssgrad2", z2d ) ! square of module of sss gradient + IF ( iom_use("sssgrad") ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = SQRT( z2d(ji,jj) ) + END DO ; END DO + CALL iom_put( "sssgrad", z2d ) ! module of sss gradient + ENDIF + ENDIF + + IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 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 DO ; END DO + CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient + IF ( iom_use("sstgrad") ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = SQRT( z2d(ji,jj) ) + END DO ; END DO + CALL iom_put( "sstgrad", z2d ) ! module of sst gradient + ENDIF + ENDIF + + ! heat and salt contents + IF( iom_use("heatc") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = z2d(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * ts(ji,jj,jk,jp_tem,Kmm) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + CALL iom_put( "heatc", rho0_rcp * z2d ) ! vertically integrated heat content (J/m2) + ENDIF + + IF( iom_use("saltc") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = z2d(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + CALL iom_put( "saltc", rho0 * z2d ) ! vertically integrated salt content (PSU*kg/m2) + ENDIF + ! + IF( iom_use("salt2c") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = z2d(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * ts(ji,jj,jk,jp_sal,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + 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 jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + 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 DO ; END DO ; END DO + CALL iom_put( "ke", z3d ) ! kinetic energy + + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = z2d(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + 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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = 0.25_wp * ( uu(ji ,jj,1,Kmm) * uu(ji ,jj,1,Kmm) * e1e2u(ji ,jj) * (e3u_0(ji ,jj,1)*(1._wp+r3u(ji ,jj,Kmm)*umask(ji ,jj,1))) & + & + uu(ji-1,jj,1,Kmm) * uu(ji-1,jj,1,Kmm) * e1e2u(ji-1,jj) * (e3u_0(ji-1,jj,1)*(1._wp+r3u(ji-1,jj,Kmm)*umask(ji-1,jj,1))) & + & + vv(ji,jj ,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji,jj ) * (e3v_0(ji,jj ,1)*(1._wp+r3v(ji,jj ,Kmm)*vmask(ji,jj ,1))) & + & + vv(ji,jj-1,1,Kmm) * vv(ji,jj-1,1,Kmm) * e1e2v(ji,jj-1) * (e3v_0(ji,jj-1,1)*(1._wp+r3v(ji,jj-1,Kmm)*vmask(ji,jj-1,1))) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,1))) * ssmask(ji,jj) + END DO ; END DO + 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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = 0.25_wp * ( uu(ji,jj ,1,Kmm) * uu(ji,jj ,1,Kmm) * e1e2u(ji,jj ) * (e3u_0(ji,jj ,1)*(1._wp+r3u(ji,jj ,Kmm)*umask(ji,jj ,1))) & + & + uu(ji,jj+1,1,Kmm) * uu(ji,jj+1,1,Kmm) * e1e2u(ji,jj+1) * (e3u_0(ji,jj+1,1)*(1._wp+r3u(ji,jj+1,Kmm)*umask(ji,jj+1,1))) & + & + vv(ji ,jj,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji ,jj) * (e3v_0(ji ,jj,1)*(1._wp+r3v(ji ,jj,Kmm)*vmask(ji ,jj,1))) & + & + vv(ji+1,jj,1,Kmm) * vv(ji+1,jj,1,Kmm) * e1e2v(ji+1,jj) * (e3v_0(ji+1,jj,1)*(1._wp+r3v(ji+1,jj,Kmm)*vmask(ji+1,jj,1))) ) & + & * r1_e1e2f(ji,jj) / (e3f_0(ji,jj,1)*(1._wp+r3f(ji,jj)*fe3mask(ji,jj,1))) * ssfmask(ji,jj) + END DO ; END DO + 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 jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = rho0 * uu(ji,jj,jk,Kmm) * e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * umask(ji,jj,jk) + END DO ; END DO ; END DO + CALL iom_put( "u_masstr" , z3d ) ! mass transport in i-direction + + IF( iom_use("u_masstr_vint") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) + END DO ; END DO ; END DO + 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 jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + 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 DO ; END DO ; END DO + CALL iom_put( "u_heattr", z2d ) ! heat transport in i-direction + ENDIF + IF( iom_use("u_salttr") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + 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 DO ; END DO ; END DO + 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 jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = rho0 * vv(ji,jj,jk,Kmm) * e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * vmask(ji,jj,jk) + END DO ; END DO ; END DO + 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 jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + 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 DO ; END DO ; END DO + CALL iom_put( "v_heattr", z2d ) ! heat transport in j-direction + ENDIF + IF( iom_use("v_salttr") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + 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 DO ; END DO ; END DO + CALL iom_put( "v_salttr", z2d ) ! heat transport in j-direction + ENDIF + + ENDIF + + IF( iom_use("tosmint") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = z2d(ji,jj) + rho0 * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * ts(ji,jj,jk,jp_tem,Kmm) + END DO ; END DO ; END DO + CALL iom_put( "tosmint", z2d ) ! Vertical integral of temperature + ENDIF + IF( iom_use("somint") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = z2d(ji,jj) + rho0 * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * ts(ji,jj,jk,jp_sal,Kmm) + END DO ; END DO ; END DO + 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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 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 DO ; END DO + CALL iom_put( "ssrelvor", z2d ) ! relative vorticity ( zeta ) + ! + IF ( iom_use("ssEns") .OR. iom_use("ssrelpotvor") .OR. iom_use("ssabspotvor") ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ze3 = ( (e3t_0(ji,jj+1,1)*(1._wp+r3t(ji,jj+1,Kmm)*tmask(ji,jj+1,1))) * e1e2t(ji,jj+1) + (e3t_0(ji+1,jj+1,1)*(1._wp+r3t(ji+1,jj+1,Kmm)*tmask(ji+1,jj+1,1))) * e1e2t(ji+1,jj+1) & + & + (e3t_0(ji,jj ,1)*(1._wp+r3t(ji,jj ,Kmm)*tmask(ji,jj ,1))) * e1e2t(ji,jj ) + (e3t_0(ji+1,jj ,1)*(1._wp+r3t(ji+1,jj ,Kmm)*tmask(ji+1,jj ,1))) * 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 DO ; END DO + CALL iom_put( "ssrelpotvor", z2d ) ! relative potential vorticity (zeta/h) + ! + IF ( iom_use("ssEns") .OR. iom_use("ssabspotvor") ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ze3 = ( (e3t_0(ji,jj+1,1)*(1._wp+r3t(ji,jj+1,Kmm)*tmask(ji,jj+1,1))) * e1e2t(ji,jj+1) + (e3t_0(ji+1,jj+1,1)*(1._wp+r3t(ji+1,jj+1,Kmm)*tmask(ji+1,jj+1,1))) * e1e2t(ji+1,jj+1) & + & + (e3t_0(ji,jj ,1)*(1._wp+r3t(ji,jj ,Kmm)*tmask(ji,jj ,1))) * e1e2t(ji,jj ) + (e3t_0(ji+1,jj ,1)*(1._wp+r3t(ji+1,jj ,Kmm)*tmask(ji+1,jj ,1))) * 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 DO ; END DO + CALL iom_put( "ssabspotvor", z2d ) ! absolute potential vorticity ( q ) + ! + IF ( iom_use("ssEns") ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = 0.5_wp * z2d(ji,jj) * z2d(ji,jj) + END DO ; END DO + 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 + + + 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 jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk) + END DO ; END DO ; END DO + 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_0(:,:)*(1._wp+r3t(:,:,Kmm))) ) ! 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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj) + END DO ; END DO + CALL iom_rstput( 0, 0, inum, 'sowaflup', z2d ) ! freshwater budget + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = qsr(ji,jj) + qns(ji,jj) + END DO ; END DO + 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 jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ! 3D workspace for qco substitution + END DO ; END DO ; END DO + CALL iom_rstput( 0, 0, inum, 'vovvldep', z3d ) ! T-cell depth + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) ! 3D workspace for qco substitution + END DO ; END DO ; END DO + 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 ) + ! + END SUBROUTINE dia_wri_state + + !!====================================================================== +END MODULE diawri diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diu_bulk.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diu_bulk.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c2a69f95013d336750e0b4dca1378f2154c63f43 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diu_bulk.f90 @@ -0,0 +1,278 @@ + + + + + + + + + + + + + +MODULE diu_bulk + !!====================================================================== + !! *** MODULE diu_bulk *** + !! Takaya model of diurnal warming (Takaya, 2010) + !!===================================================================== + !! History : ! 11-10 (J. While) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! diurnal_sst_bulk_init : initialise diurnal model + !! diurnal_sst_bulk_step : time-step the diurnal model + !!---------------------------------------------------------------------- + USE par_kind + USE phycst + USE dom_oce + USE lib_mpp + USE solfrac_mod + USE in_out_manager + + IMPLICIT NONE + PRIVATE + + ! Namelist parameters + LOGICAL, PUBLIC :: ln_diurnal = .false. ! force definition if diurnal_sst_bulk_init is not called + LOGICAL, PUBLIC :: ln_diurnal_only = .false. ! force definition if diurnal_sst_bulk_init is not called + + ! Parameters + REAL(wp), PRIVATE, PARAMETER :: pp_alpha = 2.0e-4_wp + REAL(wp), PRIVATE, PARAMETER :: pp_veltol = 0._wp + REAL(wp), PRIVATE, PARAMETER :: pp_min_fvel = 1.e-10_wp + + ! Key variables + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_dsst ! Delta SST + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_solfrac ! Fraction of + ! ! absorbed radiation + + PUBLIC diurnal_sst_bulk_init, diurnal_sst_takaya_step + !! * Substitutions + + + + + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE diurnal_sst_bulk_init + !!---------------------------------------------------------------------- + !! *** ROUTINE diurnal_sst_init *** + !! + !! ** Purpose : Initialise the Takaya diurnal model + !!---------------------------------------------------------------------- + INTEGER :: ios ! local integer + !! + NAMELIST /namdiu/ ln_diurnal, ln_diurnal_only + !!---------------------------------------------------------------------- + + ! Read the namelist + READ ( numnam_ref, namdiu, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdiu in reference namelist' ) + READ ( numnam_cfg, namdiu, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdiu in configuration namelist' ) + ! + IF( ln_diurnal_only .AND. ( .NOT. ln_diurnal ) ) THEN + CALL ctl_stop( "ln_diurnal_only set, but ln_diurnal = FALSE !" ) + ENDIF + + IF( ln_diurnal ) THEN + ! + ALLOCATE( x_dsst(jpi,jpj), x_solfrac(jpi,jpj) ) + ! + x_solfrac = 0._wp ! Initialise the solar fraction + x_dsst = 0._wp + ! + IF( ln_diurnal_only ) THEN + CALL ctl_warn( "ln_diurnal_only set; only the diurnal component of SST will be calculated" ) + ENDIF + ENDIF + + END SUBROUTINE diurnal_sst_bulk_init + + + SUBROUTINE diurnal_sst_takaya_step(kt, psolflux, pqflux, ptauflux, prho, p_rdt, & + & pla, pthick, pcoolthick, pmu, & + & p_fvel_bkginc, p_hflux_bkginc) + !!---------------------------------------------------------------------- + !! *** ROUTINE diurnal_sst_takaya_step *** + !! + !! ** Purpose : Time-step the Takaya diurnal model + !! + !! ** Method : 1) Calculate the Obukhov length + !! 2) Calculate the Similarity function + !! 2) Calculate the increment to dsst + !! 3) Apply the increment + !! ** Reference : Refinements to a prognostic scheme of skin sea surface + !! temperature, Takaya et al, JGR, 2010 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: psolflux ! solar flux (Watts) + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: pqflux ! heat (non-solar) flux (Watts) + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: ptauflux ! wind stress (kg/ m s^2) + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: prho ! water density (kg/m^3) + REAL(wp) , INTENT(in) :: p_rdt ! time-step + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pla ! Langmuir number + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pthick ! warm layer thickness (m) + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pcoolthick ! cool skin thickness (m) + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pmu ! mu parameter + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: p_hflux_bkginc ! increment to the heat flux + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: p_fvel_bkginc ! increment to the friction velocity + ! + INTEGER :: ji,jj + LOGICAL :: ll_calcfrac + REAL(wp), DIMENSION(jpi,jpj) :: z_fvel ! friction velocity + REAL(wp), DIMENSION(jpi,jpj) :: zthick, zcoolthick, zmu, zla + REAL(wp), DIMENSION(jpi,jpj) :: z_abflux ! absorbed flux + REAL(wp), DIMENSION(jpi,jpj) :: z_fla ! Langmuir function value + !!---------------------------------------------------------------------- + + ! Set optional arguments to their defaults + IF( .NOT. PRESENT( pthick ) ) THEN ; zthick(:,:) = 3._wp + ELSE ; zthick(:,:) = pthick(:,:) + ENDIF + IF( .NOT. PRESENT(pcoolthick) ) THEN ; zcoolthick(:,:) = 0._wp + ELSE ; zcoolthick(:,:) = pcoolthick(:,:) + ENDIF + IF( .NOT. PRESENT( pmu ) ) THEN ; zmu(:,:) = 0.3_wp + ELSE ; zmu(:,:) = pmu(:,:) + ENDIF + IF( .NOT. PRESENT(pla) ) THEN ; zla(:,:) = 0.3_wp + ELSE ; zla(:,:) = pla(:,:) + ENDIF + + ! If not done already, calculate the solar fraction + IF ( kt==nit000 ) THEN + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + IF( ( x_solfrac(ji,jj) == 0._wp ) .AND. ( tmask(ji,jj,1) == 1._wp ) ) & + & x_solfrac(ji,jj) = solfrac( zcoolthick(ji,jj),zthick(ji,jj) ) + END DO ; END DO + ENDIF + + ! convert solar flux and heat flux to absorbed flux + WHERE ( tmask(:,:,1) == 1._wp) + z_abflux(:,:) = ( x_solfrac(:,:) * psolflux (:,:)) + pqflux(:,:) + ELSEWHERE + z_abflux(:,:) = 0._wp + ENDWHERE + IF( PRESENT(p_hflux_bkginc) ) z_abflux(:,:) = z_abflux(:,:) + p_hflux_bkginc ! Optional increment + WHERE ( ABS( z_abflux(:,:) ) < rsmall ) + z_abflux(:,:) = rsmall + ENDWHERE + + ! Calculate the friction velocity + WHERE ( (ptauflux /= 0) .AND. ( tmask(:,:,1) == 1.) ) + z_fvel(:,:) = SQRT( ptauflux(:,:) / prho(:,:) ) + ELSEWHERE + z_fvel(:,:) = 0._wp + ENDWHERE + IF( PRESENT(p_fvel_bkginc) ) z_fvel(:,:) = z_fvel(:,:) + p_fvel_bkginc ! Optional increment + + + + ! Calculate the Langmuir function value + WHERE ( tmask(:,:,1) == 1.) + z_fla(:,:) = MAX( 1._wp, zla(:,:)**( -2._wp / 3._wp ) ) + ELSEWHERE + z_fla(:,:) = 0._wp + ENDWHERE + + ! Increment the temperature using the implicit solution + x_dsst(:,:) = t_imp( x_dsst(:,:), p_rdt, z_abflux(:,:), z_fvel(:,:), & + & z_fla(:,:), zmu(:,:), zthick(:,:), prho(:,:) ) + ! + END SUBROUTINE diurnal_sst_takaya_step + + + FUNCTION t_imp(p_dsst, p_rdt, p_abflux, p_fvel, & + p_fla, pmu, pthick, prho ) + + IMPLICIT NONE + + ! Function definition + REAL(wp), DIMENSION(jpi,jpj) :: t_imp + ! Dummy variables + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_dsst ! Delta SST + REAL(wp), INTENT(IN) :: p_rdt ! Time-step + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_abflux ! Heat forcing + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fvel ! Friction velocity + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fla ! Langmuir number + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pmu ! Structure parameter + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pthick ! Layer thickness + REAL(dp), DIMENSION(jpi,jpj), INTENT(IN) :: prho ! Water density + + ! Local variables + REAL(wp) :: z_olength ! Obukhov length + REAL(wp) :: z_sigma, z_sigma2 + REAL(wp) :: z_term1, z_term2 + REAL(wp) :: z_stabfunc ! stability function value + REAL(wp) :: z_fvel + + CHARACTER(200) :: warn_string + + INTEGER :: ji,jj + + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + + ! Only calculate outside tmask + IF ( tmask(ji,jj,1) /= 1._wp ) THEN + t_imp(ji,jj) = 0._wp + CYCLE + END IF + + IF (p_fvel(ji,jj) < pp_min_fvel) THEN + z_fvel = pp_min_fvel + WRITE(warn_string,*) "diurnal_sst_takaya step: "& + &//"friction velocity < minimum\n" & + &//"Setting friction velocity =",pp_min_fvel + CALL ctl_warn(warn_string) + + ELSE + z_fvel = p_fvel(ji,jj) + ENDIF + + ! Calculate the Obukhov length + IF ( (z_fvel < pp_veltol ) .AND. & + & (p_dsst(ji,jj) > 0._wp) ) THEN + z_olength = z_fvel / & + & SQRT( p_dsst(ji,jj) * vkarmn * grav * & + & pp_alpha / ( 5._wp * pthick(ji,jj) ) ) + ELSE + z_olength = & + & ( prho(ji,jj) * rcp * z_fvel**3._wp ) / & + & ( vkarmn * grav * pp_alpha *& + & p_abflux(ji,jj) ) + ENDIF + + ! Calculate the stability function + z_sigma = pthick(ji,jj) / z_olength + z_sigma2 = z_sigma * z_sigma + IF ( z_sigma >= 0. ) THEN + z_stabfunc = 1._wp + & + & ( ( 5._wp * z_sigma + 4._wp * z_sigma2 ) / & + & ( 1._wp + 3._wp * z_sigma + 0.25_wp * & + & z_sigma2 ) ) + ELSE + z_stabfunc = 1._wp / & + & SQRT( 1._wp - 16._wp * z_sigma ) + ENDIF + + ! Calculate the T increment + z_term1 = ( p_abflux(ji,jj) * ( pmu(ji,jj) + 1._wp) / & + & ( pmu(ji,jj) * pthick(ji,jj) * prho(ji,jj) * rcp ) ) + + + z_term2 = -( ( pmu(ji,jj) + 1._wp) * & + & ( vkarmn * z_fvel * p_fla(ji,jj) ) / & + & ( pthick(ji,jj) * z_stabfunc ) ) + + t_imp(ji,jj) = ( p_dsst(ji,jj) + p_rdt * z_term1 ) / & + ( 1._wp - p_rdt * z_term2 ) + + END DO ; END DO + + END FUNCTION t_imp + +END MODULE diu_bulk diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diu_coolskin.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diu_coolskin.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2ab43e38aae0bb71079eca9cf1b11b86bd4ba987 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diu_coolskin.f90 @@ -0,0 +1,159 @@ + + + + + + + + + + + + + +MODULE diu_coolskin + !!====================================================================== + !! *** MODULE diu_coolskin *** + !! Cool skin thickness and delta T correction using Artele et al. (2002) + !! [see also Tu and Tsuang (2005)] + !! + !!===================================================================== + !! History : ! 2012-01 (P. Sykes) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! diurnal_sst_coolskin_init : initialisation of the cool skin + !! diurnal_sst_coolskin_step : time-stepping of the cool skin corrections + !!---------------------------------------------------------------------- + USE par_kind + USE phycst + USE dom_oce + USE in_out_manager + USE sbc_oce + USE lib_mpp + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + ! Namelist parameters + + ! Parameters + REAL(wp), PRIVATE, PARAMETER :: pp_k = 0.596_wp ! Thermal conductivity of seawater + REAL(wp), PRIVATE, PARAMETER :: pp_v = 1.05e-6_wp ! Kinematic viscosity of seawater + REAL(wp), PRIVATE, PARAMETER :: pp_C = 86400 ! seconds [see Tu and Tsuang (2005)] + REAL(wp), PRIVATE, PARAMETER :: pp_cw = 3993._wp ! specific heat capacity of seawater + REAL(wp), PRIVATE, PARAMETER :: pp_h = 10._wp ! reference depth [using 10m from Artale et al. (2002)] + REAL(wp), PRIVATE, PARAMETER :: pp_rhoa = 1.20421_wp ! density of air (at 20C) + REAL(wp), PRIVATE, PARAMETER :: pp_cda = 1.45e-3_wp ! assumed air-sea drag coefficient for calculating wind speed + + ! Key variables + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_csdsst ! Cool skin delta SST + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_csthick ! Cool skin thickness + PUBLIC diurnal_sst_coolskin_step, diurnal_sst_coolskin_init + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diu_coolskin.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + CONTAINS + + SUBROUTINE diurnal_sst_coolskin_init + !!---------------------------------------------------------------------- + !! *** ROUTINE diurnal_sst_coolskin_init *** + !! + !! ** Purpose : initialise the cool skin model + !! + !! ** Method : + !! + !! ** Reference : + !! + !!---------------------------------------------------------------------- + ALLOCATE( x_csdsst(jpi,jpj), x_csthick(jpi,jpj) ) + x_csdsst = 0. + x_csthick = 0. + ! + END SUBROUTINE diurnal_sst_coolskin_init + + + SUBROUTINE diurnal_sst_coolskin_step(psqflux, pstauflux, psrho, pDt) + !!---------------------------------------------------------------------- + !! *** ROUTINE diurnal_sst_takaya_step *** + !! + !! ** Purpose : Time-step the Artale cool skin model + !! + !! ** Method : + !! + !! ** Reference : + !!---------------------------------------------------------------------- + ! Dummy variables + REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psqflux ! Heat (non-solar)(Watts) + REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: pstauflux ! Wind stress (kg/ m s^2) + REAL(dp), INTENT(IN), DIMENSION(jpi,jpj) :: psrho ! Water density (kg/m^3) + REAL(wp), INTENT(IN) :: pDt ! Time-step + + ! Local variables + REAL(wp), DIMENSION(jpi,jpj) :: z_fv ! Friction velocity + REAL(wp), DIMENSION(jpi,jpj) :: z_gamma ! Dimensionless function of wind speed + REAL(wp), DIMENSION(jpi,jpj) :: z_lamda ! Sauders (dimensionless) proportionality constant + REAL(wp), DIMENSION(jpi,jpj) :: z_wspd ! Wind speed (m/s) + REAL(wp) :: z_ztx ! Temporary u wind stress + REAL(wp) :: z_zty ! Temporary v wind stress + REAL(wp) :: z_zmod ! Temporary total wind stress + + INTEGER :: ji,jj + !!---------------------------------------------------------------------- + ! + IF( .NOT. (ln_blk .OR. ln_abl) ) CALL ctl_stop("diu_coolskin.f90: diurnal flux processing only implemented for bulk forcing") + ! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ! + ! Calcualte wind speed from wind stress and friction velocity + IF( tmask(ji,jj,1) == 1. .AND. pstauflux(ji,jj) /= 0 .AND. psrho(ji,jj) /=0 ) THEN + z_fv(ji,jj) = SQRT( pstauflux(ji,jj) / psrho(ji,jj) ) + z_wspd(ji,jj) = SQRT( pstauflux(ji,jj) / ( pp_cda * pp_rhoa ) ) + ELSE + z_fv(ji,jj) = 0. + z_wspd(ji,jj) = 0. + ENDIF + ! + ! Calculate gamma function which is dependent upon wind speed + IF( tmask(ji,jj,1) == 1. ) THEN + IF( ( z_wspd(ji,jj) <= 7.5 ) ) z_gamma(ji,jj) = ( 0.2 * z_wspd(ji,jj) ) + 0.5 + IF( ( z_wspd(ji,jj) > 7.5 ) .AND. ( z_wspd(ji,jj) < 10. ) ) z_gamma(ji,jj) = ( 1.6 * z_wspd(ji,jj) ) - 10. + IF( ( z_wspd(ji,jj) >= 10. ) ) z_gamma(ji,jj) = 6. + ENDIF + ! + ! Calculate lamda function + IF( tmask(ji,jj,1) == 1. .AND. z_fv(ji,jj) /= 0 ) THEN + z_lamda(ji,jj) = ( z_fv(ji,jj) * pp_k * pp_C ) / ( z_gamma(ji,jj) * psrho(ji,jj) * pp_cw * pp_h * pp_v ) + ELSE + z_lamda(ji,jj) = 0. + ENDIF + ! + ! Calculate the cool skin thickness - only when heat flux is out of the ocean + IF( tmask(ji,jj,1) == 1. .AND. z_fv(ji,jj) /= 0 .AND. psqflux(ji,jj) < 0 ) THEN + x_csthick(ji,jj) = ( z_lamda(ji,jj) * pp_v ) / z_fv(ji,jj) + ELSE + x_csthick(ji,jj) = 0. + ENDIF + ! + ! Calculate the cool skin correction - only when the heat flux is out of the ocean + IF( tmask(ji,jj,1) == 1. .AND. x_csthick(ji,jj) /= 0. .AND. psqflux(ji,jj) < 0. ) THEN + x_csdsst(ji,jj) = ( psqflux(ji,jj) * x_csthick(ji,jj) ) / pp_k + ELSE + x_csdsst(ji,jj) = 0. + ENDIF + ! + END DO ; END DO + ! + END SUBROUTINE diurnal_sst_coolskin_step + + !!====================================================================== +END MODULE diu_coolskin diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diu_layers.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diu_layers.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f77b49d1fe6fa6b0deff2d1eaa12fc8b4b5664fd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/diu_layers.f90 @@ -0,0 +1,64 @@ + + + + + + + + + + + + + +MODULE diu_layers + !!====================================================================== + !! *** MODULE diu_layers ** + !! Apply coolskin and warm layer calculations + !!====================================================================== + !! History : 3.7 ! 2015-11 (J. While) Original code + + USE diu_bulk ! diurnal SST bulk routines (diurnal_sst_takaya routine) + USE diu_coolskin ! diurnal cool skin correction (diurnal_sst_coolskin routine) + USE oce + USE iom + USE sbc_oce + USE sbcmod ! surface boundary condition (sbc routine) + + IMPLICIT NONE + PRIVATE + + PUBLIC diurnal_sst_bulk_init ! called by nemogcm.F90 + PUBLIC diurnal_sst_coolskin_init ! called by nemogcm.F90 + PUBLIC diurnal_layers ! called by step.F90 or step_diu.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: step_diu.F90 10922 2019-05-02 15:10:39Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + CONTAINS + + SUBROUTINE diurnal_layers( kstp ) + INTEGER, INTENT(in) :: kstp ! ocean time-step index + !!---------------------------------------------------------------------- + !! *** ROUTINE diurnal_layers *** + !! + !! ** Purpose : - Apply coolskin and warm layer calculations + !! + !!---------------------------------------------------------------------- + + ! Cool skin + + CALL diurnal_sst_coolskin_step( qns, taum, rhop(:,:,1), rn_Dt) + + CALL iom_put( "sst_wl" , x_dsst ) ! warm layer (write out before update below). + CALL iom_put( "sst_cs" , x_csdsst ) ! cool skin + + ! Diurnal warm layer model + CALL diurnal_sst_takaya_step( kstp, qsr, qns, taum, rhop(:,:,1), rn_Dt) + + END SUBROUTINE diurnal_layers + +END MODULE diu_layers diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/divhor.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/divhor.f90 new file mode 100644 index 0000000000000000000000000000000000000000..570d0d3676962c9b37065412df12e5853f26cc71 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/divhor.f90 @@ -0,0 +1,129 @@ + + + + + + + + + + + + + +MODULE divhor + !!============================================================================== + !! *** MODULE divhor *** + !! Ocean diagnostic variable : now horizontal divergence + !!============================================================================== + !! History : 1.0 ! 2002-09 (G. Madec, E. Durand) Free form, F90 + !! - ! 2005-01 (J. Chanut) Unstructured open boundaries + !! - ! 2003-08 (G. Madec) merged of cur and div, free form, F90 + !! - ! 2005-01 (J. Chanut, A. Sellar) unstructured open boundaries + !! 3.3 ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module + !! - ! 2010-10 (R. Furner, G. Madec) runoff and cla added directly here + !! 3.7 ! 2014-01 (G. Madec) suppression of velocity curl from in-core memory + !! - ! 2014-12 (G. Madec) suppression of cross land advection option + !! - ! 2015-10 (G. Madec) add velocity and rnf flag in argument of div_hor + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! div_hor : Compute the horizontal divergence field + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce, ONLY : ln_rnf ! river runoff + USE sbcrnf , ONLY : sbc_rnf_div ! river runoff + USE isf_oce, ONLY : ln_isf ! ice shelf + USE isfhdiv, ONLY : isf_hdiv ! ice shelf + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC div_hor ! routine called by step.F90 and istate.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: divhor.F90 15150 2021-07-27 10:38:24Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE div_hor( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE div_hor *** + !! + !! ** Purpose : compute the horizontal divergence at now time-step + !! + !! ** Method : the now divergence is computed as : + !! hdiv = 1/(e1e2t*e3t) ( di[e2u*e3u un] + dj[e1v*e3v vn] ) + !! and correct with runoff inflow (div_rnf) and cross land flow (div_cla) + !! + !! ** Action : - update hdiv, the now horizontal divergence + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('div_hor') + ! + IF( kt == nit000 ) THEN + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'div_hor : horizontal velocity divergence ' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + hdiv(ji,jj,jk) = 0._wp ! initialize hdiv for the halos at the first time step + END DO ; END DO ; END DO + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls-1)*nthr) !== Horizontal divergence ==! + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + hdiv(ji,jj,jk) = ( ( e2u(ji ,jj) * (e3u_0(ji ,jj,jk)*(1._wp+r3u(ji ,jj,Kmm)*umask(ji ,jj,jk))) * uu(ji ,jj,jk,Kmm) & + & - e2u(ji-1,jj) * (e3u_0(ji-1,jj,jk)*(1._wp+r3u(ji-1,jj,Kmm)*umask(ji-1,jj,jk))) * uu(ji-1,jj,jk,Kmm) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( e1v(ji,jj ) * (e3v_0(ji,jj ,jk)*(1._wp+r3v(ji,jj ,Kmm)*vmask(ji,jj ,jk))) * vv(ji,jj ,jk,Kmm) & + & - e1v(ji,jj-1) * (e3v_0(ji,jj-1,jk)*(1._wp+r3v(ji,jj-1,Kmm)*vmask(ji,jj-1,jk))) * vv(ji,jj-1,jk,Kmm) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + IF( ln_rnf ) CALL sbc_rnf_div( hdiv, Kmm ) !== runoffs ==! (update hdiv field) + ! + IF( ln_isf ) CALL isf_hdiv( kt, Kmm, hdiv ) !== ice shelf ==! (update hdiv field) + ! + IF( nn_hls==1 ) CALL lbc_lnk( 'divhor', hdiv, 'T', 1.0_wp ) ! (no sign change) + ! ! needed for ww in sshwzv + IF( ln_timing ) CALL timing_stop('div_hor') + ! + END SUBROUTINE div_hor + + !!====================================================================== +END MODULE divhor diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dom_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dom_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..305c3d22aa8174d554f82fb8c62669adb7519445 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dom_oce.f90 @@ -0,0 +1,321 @@ + + + + + + + + + + + + + +MODULE dom_oce + !!====================================================================== + !! *** MODULE dom_oce *** + !! ** Purpose : Define in memory all the ocean space domain variables + !!====================================================================== + !! History : 1.0 ! 2005-10 (A. Beckmann, G. Madec) reactivate s-coordinate + !! 3.3 ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level + !! 3.4 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation + !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) Add arrays associated + !! to the optimization of BDY communications + !! 3.7 ! 2015-11 (G. Madec) introduce surface and scale factor ratio + !! - ! 2015-11 (G. Madec, A. Coward) time varying zgr by default + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename prognostic variables in preparation for new time scheme. + !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! Agrif_Root : dummy function used when lk_agrif=F + !! Agrif_Fixed : dummy function used when lk_agrif=F + !! Agrif_CFixed : dummy function used when lk_agrif=F + !! dom_oce_alloc : dynamical allocation of dom_oce arrays + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + + IMPLICIT NONE + PUBLIC ! allows the acces to par_oce when dom_oce is used (exception to coding rules) + + PUBLIC dom_oce_alloc ! Called from nemogcm.F90 + + !!---------------------------------------------------------------------- + !! time & space domain namelist + !! ---------------------------- + ! !!* Namelist namdom : time & space domain * + LOGICAL , PUBLIC :: ln_linssh !: =T linear free surface ==>> model level are fixed in time + LOGICAL , PUBLIC :: ln_meshmask !: =T create a mesh-mask file (mesh_mask.nc) + REAL(wp), PUBLIC :: rn_Dt !: time step for the dynamics and tracer + REAL(wp), PUBLIC :: rn_atfp !: asselin time filter parameter + LOGICAL , PUBLIC :: ln_1st_euler !: =T start with forward time step or not (=F) + LOGICAL , PUBLIC :: ln_crs !: Apply grid coarsening to dynamical model output or online passive tracers + LOGICAL , PUBLIC :: ln_c1d !: =T single column domain (1x1 pt) + + !! Free surface parameters + !! ======================= + LOGICAL , PUBLIC :: ln_dynspg_exp !: Explicit free surface flag + LOGICAL , PUBLIC :: ln_dynspg_ts !: Split-Explicit free surface flag + + !! Time splitting parameters + !! ========================= + LOGICAL, PUBLIC :: ln_bt_fw !: Forward integration of barotropic sub-stepping + LOGICAL, PUBLIC :: ln_bt_av !: Time averaging of barotropic variables + LOGICAL, PUBLIC :: ln_bt_auto !: Set number of barotropic iterations automatically + INTEGER, PUBLIC :: nn_bt_flt !: Filter choice + INTEGER, PUBLIC :: nn_e !: Number of barotropic iterations during one baroclinic step (rn_Dt) + REAL(wp), PUBLIC :: rn_bt_cmax !: Maximum allowed courant number (used if ln_bt_auto=T) + REAL(wp), PUBLIC :: rn_bt_alpha !: Time stepping diffusion parameter + + + ! !!! associated variables + LOGICAL , PUBLIC :: l_1st_euler !: Euler 1st time-step flag (=T if ln_restart=F or ln_1st_euler=T) + REAL(wp), PUBLIC :: rDt, r1_Dt !: Current model timestep and reciprocal + !: rDt = 2 * rn_Dt if leapfrog and l_1st_euler = F + !: = rn_Dt if leapfrog and l_1st_euler = T + !: = rn_Dt if RK3 + + !!---------------------------------------------------------------------- + !! space domain parameters + !!---------------------------------------------------------------------- + LOGICAL , PUBLIC :: l_Iperio, l_Jperio ! i- j-periodicity + LOGICAL , PUBLIC :: l_NFold ! North Pole folding + CHARACTER(len=1), PUBLIC :: c_NFtype ! type of North pole Folding: T or F point + + ! Tiling namelist + LOGICAL, PUBLIC :: ln_tile + INTEGER :: nn_ltile_i, nn_ltile_j + + ! Domain tiling + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntsi_a !: start of internal part of tile domain + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntsj_a ! + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntei_a !: end of internal part of tile domain + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntej_a ! + LOGICAL, PUBLIC :: l_istiled ! whether tiling is currently active or not + + ! !: domain MPP decomposition parameters + INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom + INTEGER , PUBLIC :: narea !: number for local area (starting at 1) = MPI rank + 1 + INTEGER, PUBLIC :: nidom !: IOIPSL things... + + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain, including halos (jpiglo), i-index + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg !: local ==> global domain, including halos (jpjglo), j-index + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig0 !: local ==> global domain, excluding halos (Ni0glo), i-index + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg0 !: local ==> global domain, excluding halos (Nj0glo), j-index + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global, including halos (jpiglo) ==> local domain i-index + ! !: (mi0=1 and mi1=0 if global index not in local domain) + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global, including halos (jpjglo) ==> local domain j-index + ! !: (mj0=1 and mj1=0 if global index not in local domain) + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nfimpp, nfproc, nfjpi + + !!---------------------------------------------------------------------- + !! horizontal curvilinear coordinate and scale factors + !! --------------------------------------------------------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: glamt , glamu, glamv , glamf !: longitude at t, u, v, f-points [degree] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: gphit , gphiu, gphiv , gphif !: latitude at t, u, v, f-points [degree] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: r1_e1t, r1_e2t!: t-point horizontal scale factors [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1t, e2t!: t-point horizontal scale factors [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e2u, r1_e1u, r1_e2u!: horizontal scale factors at u-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1u!: horizontal scale factors at u-point [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1v, r1_e1v, r1_e2v!: horizontal scale factors at v-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e2v!: horizontal scale factors at v-point [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: r1_e1f, r1_e2f!: horizontal scale factors at f-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1f, e2f!: horizontal scale factors at f-point [m] + ! + REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2t , r1_e1e2t !: associated metrics at t-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u !: associated metrics at u-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v !: associated metrics at v-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ff_f , ff_t !: Coriolis factor at f- & t-points [1/s] + + !!---------------------------------------------------------------------- + !! vertical coordinate and scale factors + !! --------------------------------------------------------------------- + LOGICAL, PUBLIC, PARAMETER :: lk_qco = .TRUE. !: qco key flag + LOGICAL, PUBLIC, PARAMETER :: lk_linssh = .FALSE. !: linssh key flag + LOGICAL, PUBLIC :: ln_zco !: z-coordinate - full step + LOGICAL, PUBLIC :: ln_zps !: z-coordinate - partial step + LOGICAL, PUBLIC :: ln_sco !: s-coordinate or hybrid z-s coordinate + LOGICAL, PUBLIC :: ln_isfcav !: presence of ISF + ! ! reference scale factors + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_0 !: t- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3u_0 !: u- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3v_0 !: v- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f_0 !: f- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3w_0 !: w- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3uw_0 !: uw-vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_0 !: vw-vert. scale factor [m] + + ! ! time-dependent scale factors (domvvl) + ! ! time-dependent ratio ssh / h_0 (domqco) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r3u, r3v!: time-dependent ratio at t-, u- and v-point [-] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r3t!: time-dependent ratio at t-, u- and v-point [-] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3f !: mid-time-level ratio at f-point [-] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3u_f, r3v_f!: now time-filtered ratio at t-, u- and v-point [-] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3t_f!: now time-filtered ratio at t-, u- and v-point [-] + + ! ! reference depths of cells + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m] + + ! ! time-dependent depths of cells (domvvl) + ! ! reference heights of ocean water column and its inverse + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0, r1_ht_0 !: t-depth [m] and [1/m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0, r1_hu_0 !: u-depth [m] and [1/m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0, r1_hv_0 !: v-depth [m] and [1/m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hf_0, r1_hf_0 !: f-depth [m] and [1/m] + + ! ! time-dependent heights of ocean water column (domvvl) + INTEGER, PUBLIC :: nla10 !: deepest W level Above ~10m (nlb10 - 1) + INTEGER, PUBLIC :: nlb10 !: shallowest W level Bellow ~10m (nla10 + 1) + + !! 1D reference vertical coordinate + !! =-----------------====------ + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gdept_1d, gdepw_1d !: reference depth of t- and w-points (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_1d , e3w_1d !: reference vertical scale factors at T- and W-pts (m) + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfdep, bathy + + !!---------------------------------------------------------------------- + !! masks, top and bottom ocean point position + !! --------------------------------------------------------------------- +!!gm Proposition of new name for top/bottom vertical indices +! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mtk_t, mtk_u, mtk_v !: top first wet T-, U-, and V-level (ISF) +! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbk_t, mbk_u, mbk_v !: bottom last wet T-, U-, and V-level +!!gm + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt, mbku, mbkv, mbkf !: bottom last wet T-, U-, V- and F-level + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior (excluding halos+duplicated points) domain T-point mask + + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF) + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WU- and WV-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: fe3mask !: land/ocean mask at F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_upd, umask_upd, vmask_upd !: land/ocean mask at F-pts + + !!---------------------------------------------------------------------- + !! calendar variables + !! --------------------------------------------------------------------- + INTEGER , PUBLIC :: nyear !: current year + INTEGER , PUBLIC :: nmonth !: current month + INTEGER , PUBLIC :: nday !: current day of the month + INTEGER , PUBLIC :: nhour !: current hour + INTEGER , PUBLIC :: nminute !: current minute + INTEGER , PUBLIC :: ndastp !: time step date in yyyymmdd format + INTEGER , PUBLIC :: nday_year !: current day counted from jan 1st of the current year + INTEGER , PUBLIC :: nsec_year !: seconds between 00h jan 1st of the current year and half of the current time step + INTEGER , PUBLIC :: nsec_month !: seconds between 00h 1st day of the current month and half of the current time step + INTEGER , PUBLIC :: nsec_monday !: seconds between 00h of the last Monday and half of the current time step + INTEGER , PUBLIC :: nsec_day !: seconds between 00h of the current day and half of the current time step + REAL(dp), PUBLIC :: fjulday !: current julian day + REAL(dp), PUBLIC :: fjulstartyear !: first day of the current year in julian days + REAL(wp), PUBLIC :: adatrj !: number of elapsed days since the begining of the whole simulation + ! !: (cumulative duration of previous runs that may have used different time-step size) + INTEGER , PUBLIC, DIMENSION( 0: 2) :: nyear_len !: length in days of the previous/current/next year + INTEGER , PUBLIC, DIMENSION(-11:25) :: nmonth_len !: length in days of the months of the current year + INTEGER , PUBLIC, DIMENSION(-11:25) :: nmonth_beg !: second since Jan 1st 0h of the current year and the half of the months + INTEGER , PUBLIC :: nsec1jan000 !: second since Jan 1st 0h of nit000 year and Jan 1st 0h the current year + INTEGER , PUBLIC :: nsec000_1jan000 !: second since Jan 1st 0h of nit000 year and nit000 + INTEGER , PUBLIC :: nsecend_1jan000 !: second since Jan 1st 0h of nit000 year and nitend + + !!---------------------------------------------------------------------- + !! variable defined here to avoid circular dependencies... + !! --------------------------------------------------------------------- + INTEGER, PUBLIC :: nbasin ! number of basin to be considered in diaprt (glo, atl, pac, ind, ipc) + + !!---------------------------------------------------------------------- + !! agrif domain + !!---------------------------------------------------------------------- + LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .FALSE. !: agrif flag + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dom_oce.F90 15556 2021-11-29 15:23:06Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + !!---------------------------------------------------------------------- + !! NOT 'key_agrif' dummy function No AGRIF zoom + !!---------------------------------------------------------------------- + LOGICAL FUNCTION Agrif_Root() + Agrif_Root = .TRUE. + END FUNCTION Agrif_Root + + INTEGER FUNCTION Agrif_Fixed() + Agrif_Fixed = 0 + END FUNCTION Agrif_Fixed + + CHARACTER(len=3) FUNCTION Agrif_CFixed() + Agrif_CFixed = '0' + END FUNCTION Agrif_CFixed + + INTEGER FUNCTION dom_oce_alloc() + !!---------------------------------------------------------------------- + INTEGER :: ii + INTEGER, DIMENSION(30) :: ierr + !!---------------------------------------------------------------------- + ii = 0 ; ierr(:) = 0 + ! + ii = ii+1 + ALLOCATE( glamt(jpi,jpj) , glamu(jpi,jpj) , glamv(jpi,jpj) , glamf(jpi,jpj) , & + & gphit(jpi,jpj) , gphiu(jpi,jpj) , gphiv(jpi,jpj) , gphif(jpi,jpj) , & + & e1t (jpi,jpj) , e2t (jpi,jpj) , r1_e1t(jpi,jpj) , r1_e2t(jpi,jpj) , & + & e1u (jpi,jpj) , e2u (jpi,jpj) , r1_e1u(jpi,jpj) , r1_e2u(jpi,jpj) , & + & e1v (jpi,jpj) , e2v (jpi,jpj) , r1_e1v(jpi,jpj) , r1_e2v(jpi,jpj) , & + & e1f (jpi,jpj) , e2f (jpi,jpj) , r1_e1f(jpi,jpj) , r1_e2f(jpi,jpj) , & + & e1e2t(jpi,jpj) , r1_e1e2t(jpi,jpj) , & + & e1e2u(jpi,jpj) , r1_e1e2u(jpi,jpj) , e2_e1u(jpi,jpj) , & + & e1e2v(jpi,jpj) , r1_e1e2v(jpi,jpj) , e1_e2v(jpi,jpj) , & + & e1e2f(jpi,jpj) , r1_e1e2f(jpi,jpj) , & + & ff_f (jpi,jpj) , ff_t (jpi,jpj) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( gdept_0 (jpi,jpj,jpk) , gdepw_0 (jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) , & + & gdept_1d( jpk) , gdepw_1d( jpk) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( e3t_0 (jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) , e3v_0 (jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) , & + & e3w_0 (jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , & + & e3t_1d( jpk) , e3w_1d( jpk) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , hf_0(jpi,jpj) , & + & r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) , r1_hv_0(jpi,jpj), r1_hf_0(jpi,jpj) , STAT=ierr(ii) ) + ! + ! qco : ssh to h ratio and specific fmask + ii = ii+1 + ALLOCATE( r3t (jpi,jpj,jpt) , r3u (jpi,jpj,jpt) , r3v (jpi,jpj,jpt) , r3f (jpi,jpj) , & + & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) ) + ! + ii = ii+1 + ! + ! + ii = ii+1 + ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( tmask_i(jpi,jpj) , & + & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , & + & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , mbkf(jpi,jpj) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & + & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , fe3mask(jpi,jpj,jpk), STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) ) + ! + ! + dom_oce_alloc = MAXVAL(ierr) + ! + END FUNCTION dom_oce_alloc + + !!====================================================================== +END MODULE dom_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domain.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domain.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5b231728890fb485fa790e1bf26db578fc26f0bc --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domain.f90 @@ -0,0 +1,669 @@ + + + + + + + + + + + + + +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 + USE domqco ! quasi-eulerian coord. + 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 + + + + + + !!------------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domain.F90 15270 2021-09-17 14:27:55Z smasson $ + !! 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 + 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 + !!---------------------------------------------------------------------- + ! + 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 jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + hf_0(ji,jj) = hf_0(ji,jj) + e3f_0(ji,jj,jk)*vmask(ji,jj,jk)*vmask(ji+1,jj,jk) + END DO ; END DO ; END DO + 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 jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 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 DO ; END DO + ENDIF + ! + ! !== initialisation of time varying coordinate ==! + ! + ! != ssh initialization + ! + IF( l_SAS ) THEN !* No ocean dynamics calculation : set to 0 + ssh(:,:,:) = 0._wp + ELSE !* Read in restart file or set by user + CALL rst_read_ssh( Kbb, Kmm, Kaa ) + ENDIF + ! + ! != Quasi-Euerian coordinate case + ! + IF( .NOT.l_offline ) CALL dom_qco_init( Kbb, Kmm, Kaa ) + + ! + + 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 , 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(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(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 + rDt = 2._wp * rn_Dt + r1_Dt = 1._wp / rDt + ! + IF( l_SAS .AND. .NOT.ln_linssh ) THEN + CALL ctl_warn( 'SAS requires linear ssh : force ln_linssh = T' ) + ln_linssh = .TRUE. + ENDIF + ! + IF( ln_linssh ) CALL ctl_stop( 'STOP','domain: key_qco and ln_linssh=T or key_linssh are incompatible' ) + ! + ! !=======================! + ! !== 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(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,*) ' 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 + 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 + ! !== 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 + ! + ! !== 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( 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 + ! + snc4set%luse = .FALSE. ! No NetCDF 4 case + ! + 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', REAL(glamt(:,:),dp), llmsk, zglmin, imil ) + CALL mpp_minloc( 'domain', REAL(gphit(:,:),dp), llmsk, zgpmin, imip ) + CALL mpp_minloc( 'domain', REAL(e1t(:,:),dp), llmsk, ze1min, imi1 ) + CALL mpp_minloc( 'domain', REAL(e2t(:,:),dp), llmsk, ze2min, imi2 ) + CALL mpp_maxloc( 'domain', REAL(glamt(:,:),dp), llmsk, zglmax, imal ) + CALL mpp_maxloc( 'domain', REAL(gphit(:,:),dp), 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/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domhgr.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domhgr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ffd898b43ec6e8156cc5475c4c76f68c54c714d5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domhgr.f90 @@ -0,0 +1,262 @@ + + + + + + + + + + + + + +MODULE domhgr + !!============================================================================== + !! *** MODULE domhgr *** + !! Ocean initialization : domain initialization + !!============================================================================== + !! History : OPA ! 1988-03 (G. Madec) Original code + !! 7.0 ! 1996-01 (G. Madec) terrain following coordinates + !! 8.0 ! 1997-02 (G. Madec) print mesh informations + !! 8.1 ! 1999-11 (M. Imbard) NetCDF format with IO-IPSL + !! 8.2 ! 2000-08 (D. Ludicone) Reduced section at Bab el Mandeb + !! - ! 2001-09 (M. Levy) eel config: grid in km, beta-plane + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module, namelist + !! - ! 2004-01 (A.M. Treguier, J.M. Molines) Case 4 (Mercator mesh) + !! use of parameters in par_CONFIG-Rxx.h90, not in namelist + !! - ! 2004-05 (A. Koch-Larrouy) Add Gyre configuration + !! 3.7 ! 2015-09 (G. Madec, S. Flavoni) add cell surface and their inverse + !! add optional read of e1e2u & e1e2v + !! - ! 2016-04 (S. Flavoni, G. Madec) new configuration interface: read or usrdef.F90 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_hgr : initialize the horizontal mesh + !! hgr_read : read horizontal information in the domain configuration file + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + USE usrdef_hgr ! User defined routine + ! + 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 timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_hgr ! called by domain.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domhgr.F90 15056 2021-06-25 07:37:44Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_hgr + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_hgr *** + !! + !! ** Purpose : Read or compute the geographical position (in degrees) + !! of the model grid-points, the horizontal scale factors (in meters), + !! the associated horizontal metrics, and the Coriolis factor (in s-1). + !! + !! ** Method : Controlled by ln_read_cfg logical + !! =T : all needed arrays are read in mesh_mask.nc file + !! =F : user-defined configuration, all needed arrays + !! are computed in usr-def_hgr subroutine + !! + !! If Coriolis factor is neither read nor computed (iff=0) + !! it is computed from gphit assuming that the mesh is + !! defined on the sphere : + !! ff = 2.*omega*sin(gphif) (in s-1) + !! + !! If u- & v-surfaces are neither read nor computed (ie1e2u_v=0) + !! (i.e. no use of reduced scale factors in some straits) + !! they are computed from e1u, e2u, e1v and e2v as: + !! e1e2u = e1u*e2u and e1e2v = e1v*e2v + !! + !! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in degrees) + !! - define Coriolis parameter at f-point (in 1/s) + !! - define i- & j-scale factors at t-, u-, v- and f-points (in meters) + !! - define associated horizontal metrics at t-, u-, v- and f-points + !! (inverse of scale factors 1/e1 & 1/e2, surface e1*e2, ratios e1/e2 & e2/e1) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ie1e2u_v ! flag for u- & v-surfaces + INTEGER :: iff ! flag for Coriolis parameter + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dom_hgr') + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_hgr : define the horizontal mesh from ithe following par_oce parameters ' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' namcfg : read (=T) or user defined (=F) configuration ln_read_cfg = ', ln_read_cfg + ENDIF + ! + IF( ln_read_cfg ) THEN !== read in mesh_mask.nc file ==! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> read horizontal mesh in ', TRIM( cn_domcfg ), ' file' + ! + CALL hgr_read ( glamt , glamu , glamv , glamf , & ! geographic position (required) + & gphit , gphiu , gphiv , gphif , & ! - - + & iff , ff_f , ff_t , & ! Coriolis parameter (if not on the sphere) + & e1t , e1u , e1v , e1f , & ! scale factors (required) + & e2t , e2u , e2v , e2f , & ! - - - + & ie1e2u_v , e1e2u , e1e2v ) ! u- & v-surfaces (if gridsize reduction in some straits) + ! + ELSE !== User defined configuration ==! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' User defined horizontal mesh (usr_def_hgr)' + ! + CALL usr_def_hgr( glamt , glamu , glamv , glamf , & ! geographic position (required) + & gphit , gphiu , gphiv , gphif , & ! + & iff , ff_f , ff_t , & ! Coriolis parameter (if domain not on the sphere) + & e1t , e1u , e1v , e1f , & ! scale factors (required) + & e2t , e2u , e2v , e2f , & ! + & ie1e2u_v , e1e2u , e1e2v ) ! u- & v-surfaces (if gridsize reduction is used in strait(s)) + ! + ! make sure that periodicities are properly applied + CALL lbc_lnk( 'dom_hgr', glamt, 'T', 1._wp, glamu, 'U', 1._wp, glamv, 'V', 1._wp, glamf, 'F', 1._wp, & + & gphit, 'T', 1._wp, gphiu, 'U', 1._wp, gphiv, 'V', 1._wp, gphif, 'F', 1._wp, & + & e2u, 'U', 1._wp, e1v, 'V', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries + CALL lbc_lnk( 'dom_hgr', e1t, 'T', 1._dp, e2t, 'T', 1._dp, e1u, 'U', 1._dp, e2v, 'V', 1._dp, & + & e1f, 'F', 1._dp, e2f, 'F', 1._dp, kfillmode = jpfillcopy) + ! + ENDIF + ! + ! !== Coriolis parameter ==! (if necessary) + ! + IF( iff == 0 ) THEN ! Coriolis parameter has not been defined + IF(lwp) WRITE(numout,*) ' Coriolis parameter calculated on the sphere from gphif & gphit' + ff_f(:,:) = 2._wp * omega * SIN( rad * gphif(:,:) ) ! compute it on the sphere at f-point + ff_t(:,:) = 2._wp * omega * SIN( rad * gphit(:,:) ) ! - - - at t-point + ELSE + IF( ln_read_cfg ) THEN + IF(lwp) WRITE(numout,*) ' Coriolis parameter have been read in ', TRIM( cn_domcfg ), ' file' + ELSE + CALL lbc_lnk( 'dom_hgr', ff_t, 'T', 1._wp, ff_f, 'F', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 if closed + IF(lwp) WRITE(numout,*) ' Coriolis parameter have been set in usr_def_hgr routine' + ENDIF + ENDIF + ! + ! !== associated horizontal metrics ==! + ! + r1_e1t(:,:) = 1._wp / e1t(:,:) ; r1_e2t (:,:) = 1._wp / e2t(:,:) + r1_e1u(:,:) = 1._wp / e1u(:,:) ; r1_e2u (:,:) = 1._wp / e2u(:,:) + r1_e1v(:,:) = 1._wp / e1v(:,:) ; r1_e2v (:,:) = 1._wp / e2v(:,:) + r1_e1f(:,:) = 1._wp / e1f(:,:) ; r1_e2f (:,:) = 1._wp / e2f(:,:) + ! + e1e2t (:,:) = e1t(:,:) * e2t(:,:) ; r1_e1e2t(:,:) = 1._wp / e1e2t(:,:) + e1e2f (:,:) = e1f(:,:) * e2f(:,:) ; r1_e1e2f(:,:) = 1._wp / e1e2f(:,:) + IF( ie1e2u_v == 0 ) THEN ! u- & v-surfaces have not been defined + IF(lwp) WRITE(numout,*) ' u- & v-surfaces calculated as e1 e2 product' + e1e2u (:,:) = e1u(:,:) * e2u(:,:) ! compute them + e1e2v (:,:) = e1v(:,:) * e2v(:,:) + ELSE + IF( ln_read_cfg ) THEN + IF(lwp) WRITE(numout,*) ' u- & v-surfaces have been read in ', TRIM( cn_domcfg ), ' file:' + IF(lwp) WRITE(numout,*) ' grid size reduction in strait(s) is used' + ELSE + CALL lbc_lnk( 'dom_hgr', e1e2u, 'U', 1._wp, e1e2v, 'V', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 if closed + IF(lwp) WRITE(numout,*) ' u- & v-surfaces have been have been set in usr_def_hgr routine' + ENDIF + ENDIF + r1_e1e2u(:,:) = 1._wp / e1e2u(:,:) ! compute their invert in any cases + r1_e1e2v(:,:) = 1._wp / e1e2v(:,:) + ! + e2_e1u(:,:) = e2u(:,:) / e1u(:,:) + e1_e2v(:,:) = e1v(:,:) / e2v(:,:) + ! + IF( ln_timing ) CALL timing_stop('dom_hgr') + ! + END SUBROUTINE dom_hgr + + + SUBROUTINE hgr_read( plamt , plamu , plamv , plamf , & ! gridpoints position (required) + & pphit , pphiu , pphiv , pphif , & + & kff , pff_f , pff_t , & ! Coriolis parameter (if not on the sphere) + & pe1t , pe1u , pe1v , pe1f , & ! scale factors (required) + & pe2t , pe2u , pe2v , pe2f , & + & ke1e2u_v , pe1e2u , pe1e2v ) ! u- & v-surfaces (if gridsize reduction in some straits) + !!--------------------------------------------------------------------- + !! *** ROUTINE hgr_read *** + !! + !! ** Purpose : Read a mesh_mask file in NetCDF format using IOM + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(out) :: plamt, plamu, plamv, plamf ! longitude outputs + REAL(wp), DIMENSION(:,:), INTENT(out) :: pphit, pphiu, pphiv, pphif ! latitude outputs + INTEGER , INTENT(out) :: kff ! =1 Coriolis parameter read here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point (if found in file) + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1v! i-scale factors + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1f! i-scale factors + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2u! j-scale factors + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2v, pe2f! j-scale factors + INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces read here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if found in file) + ! + INTEGER :: inum ! logical unit + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' hgr_read : read the horizontal coordinates in mesh_mask' + WRITE(numout,*) ' ~~~~~~~~ jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpk = ', jpk + ENDIF + ! + CALL iom_open( cn_domcfg, inum ) + ! + CALL iom_get( inum, jpdom_global, 'glamt', plamt, cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'glamu', plamu, cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'glamv', plamv, cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'glamf', plamf, cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + ! + CALL iom_get( inum, jpdom_global, 'gphit', pphit, cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'gphiu', pphiu, cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'gphiv', pphiv, cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'gphif', pphif, cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + ! + CALL iom_get( inum, jpdom_global, 'e1t' , pe1t , cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e1u' , pe1u , cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e1v' , pe1v , cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e1f' , pe1f , cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + ! + CALL iom_get( inum, jpdom_global, 'e2t' , pe2t , cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e2u' , pe2u , cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e2v' , pe2v , cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e2f' , pe2f , cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + ! + IF( iom_varid( inum, 'ff_f', ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'ff_t', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' Coriolis factor at f- and t-points read in ', TRIM( cn_domcfg ), ' file' + CALL iom_get( inum, jpdom_global, 'ff_f', pff_f, cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'ff_t', pff_t, cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) + kff = 1 + ELSE + kff = 0 + ENDIF + ! + IF( iom_varid( inum, 'e1e2u', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' e1e2u & e1e2v read in ', TRIM( cn_domcfg ), ' file' + CALL iom_get( inum, jpdom_global, 'e1e2u', pe1e2u, cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e1e2v', pe1e2v, cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + ke1e2u_v = 1 + ELSE + ke1e2u_v = 0 + ENDIF + ! + CALL iom_close( inum ) + ! + END SUBROUTINE hgr_read + + !!====================================================================== +END MODULE domhgr diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dommsk.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dommsk.f90 new file mode 100644 index 0000000000000000000000000000000000000000..37ab0e5695103e91f3a4c7994f40ee8dacad663f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dommsk.f90 @@ -0,0 +1,240 @@ + + + + + + + + + + + + + +MODULE dommsk + !!====================================================================== + !! *** MODULE dommsk *** + !! Ocean initialization : domain land/sea mask + !!====================================================================== + !! History : OPA ! 1987-07 (G. Madec) Original code + !! 6.0 ! 1993-03 (M. Guyon) symetrical conditions (M. Guyon) + !! 7.0 ! 1996-01 (G. Madec) suppression of common work arrays + !! - ! 1996-05 (G. Madec) mask computed from tmask + !! 8.0 ! 1997-02 (G. Madec) mesh information put in domhgr.F + !! 8.1 ! 1997-07 (G. Madec) modification of kbat and fmask + !! - ! 1998-05 (G. Roullet) free surface + !! 8.2 ! 2000-03 (G. Madec) no slip accurate + !! - ! 2001-09 (J.-M. Molines) Open boundaries + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !! 3.6 ! 2015-05 (P. Mathiot) ISF: add wmask,wumask and wvmask + !! 4.0 ! 2016-06 (G. Madec, S. Flavoni) domain configuration / user defined interface + !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_msk : compute land/ocean mask + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE domutl ! + USE usrdef_fmask ! user defined fmask + USE bdy_oce ! open boundary + ! + USE in_out_manager ! I/O manager + USE iom ! IOM library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! Massively Parallel Processing library + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_msk ! routine called by inidom.F90 + + ! !!* Namelist namlbc : lateral boundary condition * + REAL(wp) :: rn_shlat ! type of lateral boundary condition on velocity + LOGICAL, PUBLIC :: ln_vorlat ! consistency of vorticity boundary condition + ! with analytical eqs. + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dommsk.F90 15556 2021-11-29 15:23:06Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_msk( k_top, k_bot ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_msk *** + !! + !! ** Purpose : Compute land/ocean mask arrays at tracer points, hori- + !! zontal velocity points (u & v), vorticity points (f) points. + !! + !! ** Method : The ocean/land mask at t-point is deduced from ko_top + !! and ko_bot, the indices of the fist and last ocean t-levels which + !! are either defined in usrdef_zgr or read in zgr_read. + !! The velocity masks (umask, vmask, wmask, wumask, wvmask) + !! are deduced from a product of the two neighboring tmask. + !! The vorticity mask (fmask) is deduced from tmask taking + !! into account the choice of lateral boundary condition (rn_shlat) : + !! rn_shlat = 0, free slip (no shear along the coast) + !! rn_shlat = 2, no slip (specified zero velocity at the coast) + !! 0 < rn_shlat < 2, partial slip | non-linear velocity profile + !! 2 < rn_shlat, strong slip | in the lateral boundary layer + !! + !! ** Action : tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask + !! at t-, u-, v- w, wu-, and wv-points (=0. or 1.) + !! fmask : land/ocean mask at f-point (=0., or =1., or + !! =rn_shlat along lateral boundaries) + !! ssmask , ssumask, ssvmask, ssfmask : 2D ocean mask, i.e. at least 1 wet cell in the vertical + !! tmask_i : ssmask * ( excludes halo+duplicated points (NP folding) ) + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! first and last ocean level + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iktop, ikbot ! - - + INTEGER :: ios, inum + !! + NAMELIST/namlbc/ rn_shlat, ln_vorlat + NAMELIST/nambdy/ ln_bdy ,nb_bdy, ln_coords_file, cn_coords_file, & + & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & + & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & + & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & + & cn_ice, nn_ice_dta, & + & ln_vol, nn_volctl, nn_rimwidth + !!--------------------------------------------------------------------- + ! + READ ( numnam_ref, namlbc, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in reference namelist' ) + READ ( numnam_cfg, namlbc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist' ) + IF(lwm) WRITE ( numond, namlbc ) + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dommsk : ocean mask ' + WRITE(numout,*) '~~~~~~' + WRITE(numout,*) ' Namelist namlbc' + WRITE(numout,*) ' lateral momentum boundary cond. rn_shlat = ',rn_shlat + WRITE(numout,*) ' consistency with analytical form ln_vorlat = ',ln_vorlat + ENDIF + ! + IF(lwp) WRITE(numout,*) + IF ( rn_shlat == 0. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral free-slip' + ELSEIF ( rn_shlat == 2. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral no-slip' + ELSEIF ( 0. < rn_shlat .AND. rn_shlat < 2. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral partial-slip' + ELSEIF ( 2. < rn_shlat ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral strong-slip' + ELSE + CALL ctl_stop( 'dom_msk: wrong value for rn_shlat (i.e. a negalive value). We stop.' ) + ENDIF + + ! Ocean/land mask at t-point (computed from ko_top and ko_bot) + ! ---------------------------- + ! + tmask(:,:,:) = 0._wp + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + iktop = k_top(ji,jj) + ikbot = k_bot(ji,jj) + IF( iktop /= 0 ) THEN ! water in the column + tmask(ji,jj,iktop:ikbot) = 1._wp + ENDIF + END DO ; END DO + ! + ! Mask corrections for bdy (read in mppini2) + READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' ) + READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' ) + ! ------------------------ + IF ( ln_bdy .AND. ln_mask_file ) THEN + CALL iom_open( cn_mask_file, inum ) + CALL iom_get ( inum, jpdom_global, 'bdy_msk', bdytmask(:,:) ) + CALL iom_close( inum ) + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + tmask(ji,jj,jk) = tmask(ji,jj,jk) * bdytmask(ji,jj) + END DO ; END DO ; END DO + ENDIF + + ! Ocean/land mask at u-, v-, and f-points (computed from tmask) + ! ---------------------------------------- + ! NB: at this point, fmask is designed for free slip lateral boundary condition + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + umask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) + vmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji ,jj+1,jk) + fmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) & + & * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk) + END DO ; END DO ; END DO + ! + ! In case of a coarsened grid, account her for possibly aditionnal + ! masked points; these have been read in the mesh file and stored in mbku, mbkv, mbkf + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + IF ( MAXVAL(umask(ji,jj,:))/=0._wp ) umask(ji,jj,mbku(ji,jj)+1:jpk) = 0._wp + IF ( MAXVAL(vmask(ji,jj,:))/=0._wp ) vmask(ji,jj,mbkv(ji,jj)+1:jpk) = 0._wp + IF ( MAXVAL(fmask(ji,jj,:))/=0._wp ) fmask(ji,jj,mbkf(ji,jj)+1:jpk) = 0._wp + END DO ; END DO + CALL lbc_lnk( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp ) ! Lateral boundary conditions + + ! Ocean/land mask at wu-, wv- and w points (computed from tmask) + !----------------------------------------- + wmask (:,:,1) = tmask(:,:,1) ! surface + wumask(:,:,1) = umask(:,:,1) + wvmask(:,:,1) = vmask(:,:,1) + DO jk = 2, jpk ! interior values + wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1) + wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1) + wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1) + END DO + + ! Ocean/land column mask at t-, u-, and v-points (i.e. at least 1 wet cell in the vertical) + ! ---------------------------------------------- + ssmask (:,:) = MAXVAL( tmask(:,:,:), DIM=3 ) + ssumask(:,:) = MAXVAL( umask(:,:,:), DIM=3 ) + ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 ) + ssfmask(:,:) = MAXVAL( fmask(:,:,:), DIM=3 ) + IF( lk_SWE ) THEN ! Shallow Water Eq. case : redefine ssfmask + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ssfmask(ji,jj) = MAX( ssmask(ji,jj+1), ssmask(ji+1,jj+1), & + & ssmask(ji,jj ), ssmask(ji+1,jj ) ) + END DO ; END DO + CALL lbc_lnk( 'dommsk', ssfmask, 'F', 1.0_wp ) + ENDIF + fe3mask(:,:,:) = fmask(:,:,:) + + ! Interior domain mask (used for global sum) : 2D ocean mask x (halo+duplicated points) mask + ! -------------------- + ! + CALL dom_uniq( tmask_i, 'T' ) + tmask_i(:,:) = ssmask(:,:) * tmask_i(:,:) + + ! Lateral boundary conditions on velocity (modify fmask) + ! --------------------------------------- + IF( rn_shlat /= 0._wp ) THEN ! Not free-slip lateral boundary condition + ! + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + IF( fmask(ji,jj,jk) == 0._wp ) THEN + fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(ji,jj,jk), umask(ji,jj+1,jk), & + & vmask(ji,jj,jk), vmask(ji+1,jj,jk) ) ) + ENDIF + END DO ; END DO ; END DO + CALL lbc_lnk( 'dommsk', fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask + ! + ! CAUTION : The fmask may be further modified in dyn_vor_init ( dynvor.F90 ) depending on ln_vorlat + ! + ENDIF + + ! User defined alteration of fmask (use to reduce ocean transport in specified straits) + ! -------------------------------- + ! + CALL usr_def_fmask( cn_cfg, nn_cfg, fmask ) + ! + ! + END SUBROUTINE dom_msk + + !!====================================================================== +END MODULE dommsk diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domqco.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domqco.f90 new file mode 100644 index 0000000000000000000000000000000000000000..46a692603226d79b1327d6ab5baba5e48e51c594 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domqco.f90 @@ -0,0 +1,276 @@ + + + + + + + + + + + + + +MODULE domqco + !!====================================================================== + !! *** MODULE domqco *** + !! Ocean : + !!====================================================================== + !! History : 2.0 ! 2006-06 (B. Levier, L. Marie) original code + !! 3.1 ! 2009-02 (G. Madec, M. Leclair, R. Benshila) pure z* coordinate + !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: vvl option includes z_star and z_tilde coordinates + !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) add time level indices for prognostic variables + !! - ! 2020-02 (S. Techene, G. Madec) quasi-eulerian coordinate (z* or s*) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_qco_init : define initial vertical scale factors, depths and column thickness + !! dom_qco_zgr : Set ssh/h_0 ratio at t + !! dom_qco_r3c : Compute ssh/h_0 ratio at t-, u-, v-, and optionally f-points + !! qco_ctl : Check the vvl options + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE phycst ! physical constant + USE dom_oce ! ocean space and time domain + USE dynadv , ONLY : ln_dynadv_vec + USE isf_oce ! iceshelf cavities + USE sbc_oce ! ocean surface boundary condition + USE wet_dry ! wetting and drying + USE usrdef_istate ! user defined initial state (wad only) + USE restart ! ocean restart + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! distributed memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_qco_init ! called by domain.F90 + PUBLIC dom_qco_zgr ! called by isfcpl.F90 + PUBLIC dom_qco_r3c ! called by steplf.F90 + + ! !!* Namelist nam_vvl + LOGICAL , PUBLIC :: ln_vvl_zstar = .FALSE. ! zstar vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_ztilde = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_layer = .FALSE. ! level vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_ztilde_as_zstar = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_zstar_at_eqtor = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_kepe = .FALSE. ! kinetic/potential energy transfer + ! ! conservation: not used yet + ! + INTEGER :: nn_vvl_interp = 0 ! scale factors anomaly interpolation method at U-V-F points + ! =0 linear with no bottom correction over steps (old) + ! =1 linear with bottom correction over steps + ! =2 "qco like", i.e. proportional to thicknesses at rest + ! + REAL(wp) :: rn_ahe3 ! thickness diffusion coefficient + REAL(wp) :: rn_rst_e3t ! ztilde to zstar restoration timescale [days] + REAL(wp) :: rn_lf_cutoff ! cutoff frequency for low-pass filter [days] + REAL(wp) :: rn_zdef_max ! maximum fractional e3t deformation + LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE. ! debug control prints + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domvvl.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_qco_init( Kbb, Kmm, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_qco_init *** + !! + !! ** Purpose : Initialization of all ssh. to h._0 ratio + !! + !! ** Method : - use restart file and/or initialize + !! - compute ssh. to h._0 ratio + !! + !! ** Action : - r3(t/u/v)_b + !! - r3(t/u/v/f)_n + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! time level indices + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_qco_init : Variable volume activated' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ! + CALL qco_ctl ! choose vertical coordinate (z_star, z_tilde or layer) + ! + CALL dom_qco_zgr( Kbb, Kmm ) ! interpolation scale factor, depth and water column + ! + ! + END SUBROUTINE dom_qco_init + + + SUBROUTINE dom_qco_zgr( Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_qco_init *** + !! + !! ** Purpose : Initialization of all r3. = ssh./h._0 ratios + !! + !! ** Method : Call domqco using Kbb and Kmm + !! NB: dom_qco_zgr is called by dom_qco_init it uses ssh from ssh_init + !! + !! ** Action : - r3(t/u/v)(Kbb) + !! - r3(t/u/v/f)(Kmm) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm ! time level indices + !!---------------------------------------------------------------------- + ! + ! !== Set of all other vertical scale factors ==! (now and before) + ! ! Horizontal interpolation of e3t + CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) ) + CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm), r3f(:,:) ) + ! dom_qco_r3c defines over [nn_hls, nn_hls-1, nn_hls, nn_hls-1] + IF( nn_hls == 2 ) CALL lbc_lnk( 'dom_qco_zgr', r3u(:,:,Kbb), 'U', 1._wp, r3v(:,:,Kbb), 'V', 1._wp, & + & r3u(:,:,Kmm), 'U', 1._wp, r3v(:,:,Kmm), 'V', 1._wp, r3f(:,:), 'F', 1._wp ) + ! ! r3f is needed for agrif + END SUBROUTINE dom_qco_zgr + + + SUBROUTINE dom_qco_r3c( pssh, pr3t, pr3u, pr3v, pr3f ) + !!--------------------------------------------------------------------- + !! *** ROUTINE r3c *** + !! + !! ** Purpose : compute the filtered ratio ssh/h_0 at t-,u-,v-,f-points + !! + !! ** Method : - compute the ssh at u- and v-points (f-point optional) + !! Vector Form : surface weighted averaging + !! Flux Form : simple averaging + !! - compute the ratio ssh/h_0 at t-,u-,v-pts, (f-pt optional) + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:) , INTENT(in ) :: pssh ! sea surface height [m] + REAL(wp), DIMENSION(:,:) , INTENT( out) :: pr3u, pr3v! ssh/h0 ratio at t-, u-, v-,points [-] + REAL(dp), DIMENSION(:,:) , INTENT( out) :: pr3t! ssh/h0 ratio at t-, u-, v-,points [-] + REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT( out) :: pr3f ! ssh/h0 ratio at f-point [-] + ! + INTEGER :: ji, jj ! dummy loop indices + !!---------------------------------------------------------------------- + ! + ! + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + pr3t(ji,jj) = pssh(ji,jj) * r1_ht_0(ji,jj) !== ratio at t-point ==! + END DO ; END DO + ! + ! + ! !== ratio at u-,v-point ==! + ! +!!st IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) + ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls)*nthr) + pr3u(ji,jj) = 0.5_wp * ( e1e2t(ji ,jj) * pssh(ji ,jj) & + & + e1e2t(ji+1,jj) * pssh(ji+1,jj) ) * r1_hu_0(ji,jj) * r1_e1e2u(ji,jj) + pr3v(ji,jj) = 0.5_wp * ( e1e2t(ji,jj ) * pssh(ji,jj ) & + & + e1e2t(ji,jj+1) * pssh(ji,jj+1) ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj) + END DO ; END DO +!!st ELSE !- Flux Form (simple averaging) + ! + IF( .NOT.PRESENT( pr3f ) ) THEN !- lbc on ratio at u-, v-points only + IF (nn_hls==1) CALL lbc_lnk( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp ) + ! + ! + ELSE !== ratio at f-point ==! + ! +!!st IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) + ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average + + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls)*nthr) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + pr3f(ji,jj) = 0.25_wp * ( ( e1e2t(ji ,jj ) * pssh(ji ,jj ) & + & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( e1e2t(ji ,jj+1) * pssh(ji ,jj+1) & + & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj) + END DO ; END DO +!!st ELSE !- Flux Form (simple averaging) + ! ! lbc on ratio at u-,v-,f-points + IF (nn_hls==1) CALL lbc_lnk( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp, pr3f, 'F', 1._wp ) + ! + ENDIF + ! + END SUBROUTINE dom_qco_r3c + + + SUBROUTINE qco_ctl + !!--------------------------------------------------------------------- + !! *** ROUTINE qco_ctl *** + !! + !! ** Purpose : Control the consistency between namelist options + !! for vertical coordinate + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ios + !! + NAMELIST/nam_vvl/ ln_vvl_zstar, ln_vvl_ztilde, ln_vvl_layer, ln_vvl_ztilde_as_zstar, & + & ln_vvl_zstar_at_eqtor , rn_ahe3 , rn_rst_e3t , & + & rn_lf_cutoff , rn_zdef_max , ln_vvl_dbg , & ! not yet implemented: ln_vvl_kepe + & nn_vvl_interp + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_vvl in reference namelist' ) + READ ( numnam_cfg, nam_vvl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_vvl ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'qco_ctl : choice/control of the variable vertical coordinate' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist nam_vvl : chose a vertical coordinate' + WRITE(numout,*) ' zstar ln_vvl_zstar = ', ln_vvl_zstar + WRITE(numout,*) ' ztilde ln_vvl_ztilde = ', ln_vvl_ztilde + WRITE(numout,*) ' layer ln_vvl_layer = ', ln_vvl_layer + WRITE(numout,*) ' ztilde as zstar ln_vvl_ztilde_as_zstar = ', ln_vvl_ztilde_as_zstar + WRITE(numout,*) ' ztilde near the equator ln_vvl_zstar_at_eqtor = ', ln_vvl_zstar_at_eqtor + WRITE(numout,*) ' !' + WRITE(numout,*) ' thickness diffusion coefficient rn_ahe3 = ', rn_ahe3 + WRITE(numout,*) ' maximum e3t deformation fractional change rn_zdef_max = ', rn_zdef_max + IF( ln_vvl_ztilde_as_zstar ) THEN + WRITE(numout,*) ' ztilde running in zstar emulation mode (ln_vvl_ztilde_as_zstar=T) ' + WRITE(numout,*) ' ignoring namelist timescale parameters and using:' + WRITE(numout,*) ' hard-wired : z-tilde to zstar restoration timescale (days)' + WRITE(numout,*) ' rn_rst_e3t = 0.e0' + WRITE(numout,*) ' hard-wired : z-tilde cutoff frequency of low-pass filter (days)' + WRITE(numout,*) ' rn_lf_cutoff = 1.0/rn_Dt' + ELSE + WRITE(numout,*) ' z-tilde to zstar restoration timescale (days) rn_rst_e3t = ', rn_rst_e3t + WRITE(numout,*) ' z-tilde cutoff frequency of low-pass filter (days) rn_lf_cutoff = ', rn_lf_cutoff + ENDIF + WRITE(numout,*) ' debug prints flag ln_vvl_dbg = ', ln_vvl_dbg + ENDIF + ! + ioptio = 0 ! Parameter control + IF( ln_vvl_ztilde_as_zstar ) ln_vvl_ztilde = .true. + IF( ln_vvl_zstar ) ioptio = ioptio + 1 + IF( ln_vvl_ztilde ) ioptio = ioptio + 1 + IF( ln_vvl_layer ) ioptio = ioptio + 1 + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' ) + ! + IF(lwp) THEN ! Print the choice + WRITE(numout,*) + IF( ln_vvl_zstar ) WRITE(numout,*) ' ==>>> zstar vertical coordinate is used' + IF( ln_vvl_ztilde ) WRITE(numout,*) ' ==>>> ztilde vertical coordinate is used' + IF( ln_vvl_layer ) WRITE(numout,*) ' ==>>> layer vertical coordinate is used' + IF( ln_vvl_ztilde_as_zstar ) WRITE(numout,*) ' ==>>> to emulate a zstar coordinate' + ENDIF + ! + ! + END SUBROUTINE qco_ctl + + !!====================================================================== +END MODULE domqco diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domtile.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domtile.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c8c2bfad2ef784b870985ab04b9529dc0c7f6d38 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domtile.f90 @@ -0,0 +1,267 @@ + + + + + + + + + + + + + +MODULE domtile + !!====================================================================== + !! *** MODULE domtile *** + !! Tiling utilities + !!====================================================================== + !! History : 4.2 ! 2020-12 (D. Calvert) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_tile : Set/initialise the current tile and domain indices + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + ! + USE prtctl ! Print control (prt_ctl_info routine) + USE lib_mpp , ONLY : ctl_stop, ctl_warn + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_tile ! called by step.F90 + PUBLIC dom_tile_start ! called by various + PUBLIC dom_tile_stop ! " " + PUBLIC dom_tile_init ! called by domain.F90 + + LOGICAL, ALLOCATABLE, DIMENSION(:) :: l_tilefin ! whether a tile is finished or not + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.2 , NEMO Consortium (2020) + !! $Id: domtile.F90 13982 2020-12-04 10:57:05Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_tile_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_tile_init *** + !! + !! ** Purpose : Initialise tile domain variables + !! + !! ** Action : - ntsi, ntsj : start of internal part of domain + !! - ntei, ntej : end of internal part of domain + !! - ntile : current tile number + !! - nijtile : total number of tiles + !! - nthl, nthr : modifier on DO loop macro bound offset (left, right) + !! - nthb, ntht : " " (bottom, top) + !! - l_istiled : whether tiling is currently active or not + !! - l_tilefin : whether a tile is finished or not + !!---------------------------------------------------------------------- + INTEGER :: jt ! dummy loop argument + INTEGER :: iitile, ijtile ! Local integers + !!---------------------------------------------------------------------- + IF( ln_tile .AND. nn_hls /= 2 ) CALL ctl_stop('dom_tile_init: Tiling is only supported for nn_hls = 2') + + ntile = 0 ! Initialise to full domain + nijtile = 1 + ntsi = Nis0 + ntsj = Njs0 + ntei = Nie0 + ntej = Nje0 + nthl = 0 + nthr = 0 + nthb = 0 + ntht = 0 + l_istiled = .FALSE. + + IF( ln_tile ) THEN ! Calculate tile domain indices + iitile = Ni_0 / nn_ltile_i ! Number of tiles + ijtile = Nj_0 / nn_ltile_j + IF( MOD( Ni_0, nn_ltile_i ) /= 0 ) iitile = iitile + 1 + IF( MOD( Nj_0, nn_ltile_j ) /= 0 ) ijtile = ijtile + 1 + + nijtile = iitile * ijtile + ALLOCATE( ntsi_a(0:nijtile), ntsj_a(0:nijtile), ntei_a(0:nijtile), ntej_a(0:nijtile), l_tilefin(nijtile) ) + + l_tilefin(:) = .FALSE. + + ntsi_a(0) = Nis0 ! Full domain + ntsj_a(0) = Njs0 + ntei_a(0) = Nie0 + ntej_a(0) = Nje0 + + DO jt = 1, nijtile ! Tile domains + ntsi_a(jt) = Nis0 + nn_ltile_i * MOD(jt - 1, iitile) + ntsj_a(jt) = Njs0 + nn_ltile_j * ((jt - 1) / iitile) + ntei_a(jt) = MIN(ntsi_a(jt) + nn_ltile_i - 1, Nie0) + ntej_a(jt) = MIN(ntsj_a(jt) + nn_ltile_j - 1, Nje0) + ENDDO + ENDIF + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dom_tile : Domain tiling decomposition' + WRITE(numout,*) '~~~~~~~~' + IF( ln_tile ) THEN + WRITE(numout,*) iitile, 'tiles in i' + WRITE(numout,*) ' Starting indices' + WRITE(numout,*) ' ', (ntsi_a(jt), jt=1, iitile) + WRITE(numout,*) ' Ending indices' + WRITE(numout,*) ' ', (ntei_a(jt), jt=1, iitile) + WRITE(numout,*) ijtile, 'tiles in j' + WRITE(numout,*) ' Starting indices' + WRITE(numout,*) ' ', (ntsj_a(jt), jt=1, nijtile, iitile) + WRITE(numout,*) ' Ending indices' + WRITE(numout,*) ' ', (ntej_a(jt), jt=1, nijtile, iitile) + ELSE + WRITE(numout,*) 'No domain tiling' + WRITE(numout,*) ' i indices =', ntsi, ':', ntei + WRITE(numout,*) ' j indices =', ntsj, ':', ntej + ENDIF + ENDIF + END SUBROUTINE dom_tile_init + + + SUBROUTINE dom_tile( ktsi, ktsj, ktei, ktej, ktile, ldhold, cstr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_tile *** + !! + !! ** Purpose : Set the current tile and its domain indices + !! + !! ** Action : - ktsi, ktsj : start of internal part of domain + !! - ktei, ktej : end of internal part of domain + !! - nthl, nthr : modifier on DO loop macro bound offset (left, right) + !! - nthb, ntht : " " (bottom, top) + !! - ktile : set the current tile number (ntile) + !!---------------------------------------------------------------------- + INTEGER, INTENT(out) :: ktsi, ktsj, ktei, ktej ! Tile domain indices + INTEGER, INTENT(in) :: ktile ! Tile number + LOGICAL, INTENT(in), OPTIONAL :: ldhold ! Pause/resume (.true.) or set (.false.) current tile + CHARACTER(len=*), INTENT(in), OPTIONAL :: cstr ! Debug information (added to warnings) + CHARACTER(len=23) :: clstr + LOGICAL :: llhold + CHARACTER(len=11) :: charout + INTEGER :: iitile + !!---------------------------------------------------------------------- + llhold = .FALSE. + IF( PRESENT(ldhold) ) llhold = ldhold + clstr = '' + IF( PRESENT(cstr) ) clstr = TRIM(' ('//TRIM(cstr)//')') + + IF( .NOT. ln_tile ) CALL ctl_stop('Cannot use dom_tile with ln_tile = .false.') + IF( .NOT. llhold ) THEN + IF( .NOT. l_istiled ) THEN + CALL ctl_warn('Cannot call dom_tile when tiling is inactive'//clstr) + RETURN + ENDIF + + IF( ntile /= 0 ) l_tilefin(ntile) = .TRUE. ! If setting a new tile, the current tile is complete + + ntile = ktile ! Set the new tile + IF(sn_cfctl%l_prtctl) THEN + WRITE(charout, FMT="('ntile =', I4)") ntile + CALL prt_ctl_info( charout ) + ENDIF + ENDIF + + ktsi = ntsi_a(ktile) ! Set the domain indices + ktsj = ntsj_a(ktile) + ktei = ntei_a(ktile) + ktej = ntej_a(ktile) + + ! Calculate the modifying factor on DO loop bounds (1 = do not work on points that have already been processed by a neighbouring tile) + nthl = 0 ; nthr = 0 ; nthb = 0 ; ntht = 0 + iitile = Ni_0 / nn_ltile_i + IF( MOD( Ni_0, nn_ltile_i ) /= 0 ) iitile = iitile + 1 + IF( ktsi > Nis0 ) THEN ; IF( l_tilefin(ktile - 1 ) ) nthl = 1 ; ENDIF ! Left adjacent tile + IF( ktei < Nie0 ) THEN ; IF( l_tilefin(ktile + 1 ) ) nthr = 1 ; ENDIF ! Right " " + IF( ktsj > Njs0 ) THEN ; IF( l_tilefin(ktile - iitile) ) nthb = 1 ; ENDIF ! Bottom " " + IF( ktej < Nje0 ) THEN ; IF( l_tilefin(ktile + iitile) ) ntht = 1 ; ENDIF ! Top " " + END SUBROUTINE dom_tile + + + SUBROUTINE dom_tile_start( ldhold, cstr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_tile_start *** + !! + !! ** Purpose : Start or resume the use of tiling + !! + !! ** Method : dom_tile_start & dom_tile_stop are used to declare a tiled region of code. + !! + !! Tiling is active/inactive (l_istiled = .true./.false.) within/outside of this code region. + !! After enabling tiling, no tile will initially be set (the full domain will be used) and dom_tile must + !! be called to set a specific tile to work on. Furthermore, all tiles will be marked as incomplete + !! (ln_tilefin(:) = .false.). + !! + !! Tiling can be paused/resumed within the tiled code region by calling dom_tile_stop/dom_tile_start + !! with ldhold = .true.. This can be used to temporarily revert back to using the full domain. + !! + !! CALL dom_tile_start ! Enable tiling + !! CALL dom_tile(ntsi, ntei, ntsj, ntej, ktile=n) ! Set current tile "n" + !! ... + !! CALL dom_tile_stop(.TRUE.) ! Pause tiling (temporarily disable) + !! ... + !! CALL dom_tile_start(.TRUE.) ! Resume tiling + !! CALL dom_tile_stop ! Disable tiling + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in), OPTIONAL :: ldhold ! Resume (.true.) or start (.false.) + LOGICAL :: llhold + CHARACTER(len=*), INTENT(in), OPTIONAL :: cstr ! Debug information (added to warnings) + CHARACTER(len=23) :: clstr + !!---------------------------------------------------------------------- + llhold = .FALSE. + IF( PRESENT(ldhold) ) llhold = ldhold + clstr = '' + IF( PRESENT(cstr) ) clstr = TRIM(' ('//TRIM(cstr)//')') + + IF( .NOT. ln_tile ) CALL ctl_stop('Cannot resume/start tiling as ln_tile = .false.') + IF( l_istiled ) THEN + CALL ctl_warn('Cannot resume/start tiling as it is already active'//clstr) + RETURN + ! TODO: [tiling] this warning will always be raised outside a tiling loop (cannot check for pause rather than stop) + ELSE IF( llhold .AND. ntile == 0 ) THEN + CALL ctl_warn('Cannot resume tiling as it is not paused'//clstr) + RETURN + ENDIF + + ! Whether resumed or started, the tiling is made active. If resumed, the domain indices for the current tile are used. + IF( llhold ) CALL dom_tile(ntsi, ntsj, ntei, ntej, ktile=ntile, ldhold=.TRUE., cstr='dom_tile_start'//clstr) + l_istiled = .TRUE. + END SUBROUTINE dom_tile_start + + + SUBROUTINE dom_tile_stop( ldhold, cstr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_tile_stop *** + !! + !! ** Purpose : End or pause the use of tiling + !! + !! ** Method : See dom_tile_start + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in), OPTIONAL :: ldhold ! Pause (.true.) or stop (.false.) + LOGICAL :: llhold + CHARACTER(len=*), INTENT(in), OPTIONAL :: cstr ! Debug information (added to warnings) + CHARACTER(len=23) :: clstr + !!---------------------------------------------------------------------- + llhold = .FALSE. + IF( PRESENT(ldhold) ) llhold = ldhold + clstr = '' + IF( PRESENT(cstr) ) clstr = TRIM(' ('//TRIM(cstr)//')') + + IF( .NOT. ln_tile ) CALL ctl_stop('Cannot pause/stop tiling as ln_tile = .false.') + IF( .NOT. l_istiled ) THEN + CALL ctl_warn('Cannot pause/stop tiling as it is inactive'//clstr) + RETURN + ENDIF + + ! Whether paused or stopped, the tiling is made inactive and the full domain indices are used. + ! If stopped, there is no active tile (ntile = 0) and the finished tile indicators are reset + CALL dom_tile(ntsi, ntsj, ntei, ntej, ktile=0, ldhold=llhold, cstr='dom_tile_stop'//clstr) + IF( .NOT. llhold ) l_tilefin(:) = .FALSE. + l_istiled = .FALSE. + END SUBROUTINE dom_tile_stop + !!====================================================================== +END MODULE domtile diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domutl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domutl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c24b08c3b0be6ddb0b349d4d41a25f4809997f65 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domutl.f90 @@ -0,0 +1,196 @@ + + + + + + + + + + + + + +MODULE domutl + !!====================================================================== + !! *** MODULE domutl *** + !! Grid utilities: + !!====================================================================== + !! History : 4.2 ! 2020-04 (S. Masson) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_ngb : find the closest grid point from a given lon/lat position + !! dom_uniq : identify unique point of a grid (TUVF) + !!---------------------------------------------------------------------- + ! + USE dom_oce ! ocean space and time domain + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! for mppsum + + IMPLICIT NONE + PRIVATE + + INTERFACE is_tile + MODULE PROCEDURE is_tile_2d_sp, is_tile_3d_sp, is_tile_4d_sp, is_tile_2d_dp, is_tile_3d_dp, is_tile_4d_dp + END INTERFACE is_tile + + PUBLIC dom_ngb ! routine called in iom.F90 module + PUBLIC dom_uniq ! Called by dommsk and domwri + PUBLIC is_tile + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.2 , NEMO Consortium (2020) + !! $Id: domutl.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_ngb( plon, plat, kii, kjj, cdgrid, kkk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_ngb *** + !! + !! ** Purpose : find the closest grid point from a given lon/lat position + !! + !! ** Method : look for minimum distance in cylindrical projection + !! -> not good if located at too high latitude... + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: plon, plat ! longitude,latitude of the point + INTEGER , INTENT( out) :: kii, kjj ! i-,j-index of the closes grid point + INTEGER , INTENT(in ), OPTIONAL :: kkk ! k-index of the mask level used + CHARACTER(len=1), INTENT(in ) :: cdgrid ! grid name 'T', 'U', 'V', 'W' + ! + INTEGER :: ik ! working level + INTEGER , DIMENSION(2) :: iloc + REAL(wp) :: zlon, zmini + REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zdist + LOGICAL , DIMENSION(jpi,jpj) :: llmsk + !!-------------------------------------------------------------------- + ! + ik = 1 + IF ( PRESENT(kkk) ) ik=kkk + ! + SELECT CASE( cdgrid ) + CASE( 'U' ) ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; llmsk(:,:) = tmask_i(:,:) * umask(:,:,ik) == 1._wp + CASE( 'V' ) ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; llmsk(:,:) = tmask_i(:,:) * vmask(:,:,ik) == 1._wp + CASE( 'F' ) ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; llmsk(:,:) = tmask_i(:,:) * fmask(:,:,ik) == 1._wp + CASE DEFAULT; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; llmsk(:,:) = tmask_i(:,:) * tmask(:,:,ik) == 1._wp + END SELECT + ! + zlon = MOD( plon + 720., 360. ) ! plon between 0 and 360 + zglam(:,:) = MOD( zglam(:,:) + 720., 360. ) ! glam between 0 and 360 + IF( zlon > 270. ) zlon = zlon - 360. ! zlon between -90 and 270 + IF( zlon < 90. ) WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360. ! glam between -180 and 180 + zglam(:,:) = zglam(:,:) - zlon + ! + zgphi(:,:) = zgphi(:,:) - plat + zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:) + ! + CALL mpp_minloc( 'domngb', REAL(zdist(:,:),dp), llmsk, zmini, iloc, ldhalo = .TRUE. ) + kii = iloc(1) + kjj = iloc(2) + ! + END SUBROUTINE dom_ngb + + + SUBROUTINE dom_uniq( puniq, cdgrd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_uniq *** + !! + !! ** Purpose : identify unique point of a grid (TUVF) + !! + !! ** Method : 1) aplly lbc_lnk on an array with different values for each element + !! 2) check which elements have been changed + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cdgrd ! + REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq ! + ! + REAL(wp) :: zshift ! shift value link to the process number + INTEGER :: ji ! dummy loop indices + LOGICAL , DIMENSION(jpi,jpj,1) :: lluniq ! store whether each point is unique or not + REAL(wp), DIMENSION(jpi,jpj ) :: ztstref + !!---------------------------------------------------------------------- + ! + ! build an array with different values for each element + ! in mpp: make sure that these values are different even between process + ! -> apply a shift value according to the process number + zshift = jpimax * jpjmax * ( narea - 1 ) + ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) ) + ! + puniq(:,:) = ztstref(:,:) ! default definition + CALL lbc_lnk( 'domwri', puniq, cdgrd, 1._wp ) ! apply boundary conditions + lluniq(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have not been changed + ! + puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp ) + ! + END SUBROUTINE dom_uniq + + + INTEGER FUNCTION is_tile_2d_sp( pt ) + REAL(sp), DIMENSION(:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_2d_sp = 1 + ELSE + is_tile_2d_sp = 0 + ENDIF + END FUNCTION is_tile_2d_sp + + + INTEGER FUNCTION is_tile_2d_dp( pt ) + REAL(dp), DIMENSION(:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_2d_dp = 1 + ELSE + is_tile_2d_dp = 0 + ENDIF + END FUNCTION is_tile_2d_dp + + + INTEGER FUNCTION is_tile_3d_sp( pt ) + REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_3d_sp = 1 + ELSE + is_tile_3d_sp = 0 + ENDIF + END FUNCTION is_tile_3d_sp + + + INTEGER FUNCTION is_tile_3d_dp( pt ) + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_3d_dp = 1 + ELSE + is_tile_3d_dp = 0 + ENDIF + END FUNCTION is_tile_3d_dp + + + INTEGER FUNCTION is_tile_4d_sp( pt ) + REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_4d_sp = 1 + ELSE + is_tile_4d_sp = 0 + ENDIF + END FUNCTION is_tile_4d_sp + + + INTEGER FUNCTION is_tile_4d_dp( pt ) + REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_4d_dp = 1 + ELSE + is_tile_4d_dp = 0 + ENDIF + END FUNCTION is_tile_4d_dp + !!====================================================================== +END MODULE domutl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domvvl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domvvl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e189a092eca7894b1f9fa279bc1944fefd8ca1c7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domvvl.f90 @@ -0,0 +1,78 @@ + + + + + + + + + + + + + +MODULE domvvl + !!====================================================================== + !! *** MODULE domvvl *** + !! Ocean : + !!====================================================================== + !! History : 2.0 ! 2006-06 (B. Levier, L. Marie) original code + !! 3.1 ! 2009-02 (G. Madec, M. Leclair, R. Benshila) pure z* coordinate + !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: vvl option includes z_star and z_tilde coordinates + !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename dom_vvl_sf_swp -> dom_vvl_sf_update for new timestepping + !! - ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio + !!---------------------------------------------------------------------- + + USE oce ! ocean dynamics and tracers + USE phycst ! physical constant + USE dom_oce ! ocean space and time domain + USE sbc_oce ! ocean surface boundary condition + USE wet_dry ! wetting and drying + USE usrdef_istate ! user defined initial state (wad only) + USE restart ! ocean restart + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! distributed memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + ! !!* Namelist nam_vvl + LOGICAL , PUBLIC :: ln_vvl_zstar = .FALSE. ! zstar vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_ztilde = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_layer = .FALSE. ! level vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_ztilde_as_zstar = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_zstar_at_eqtor = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_kepe = .FALSE. ! kinetic/potential energy transfer + ! + INTEGER :: nn_vvl_interp = 0 ! scale factors anomaly interpolation method at U-V-F points + ! =0 linear with no bottom correction over steps (old) + ! =1 linear with bottom correction over steps + ! =2 "qco like", i.e. proportional to thicknesses at rest + ! + ! ! conservation: not used yet + REAL(wp) :: rn_ahe3 ! thickness diffusion coefficient + REAL(wp) :: rn_rst_e3t ! ztilde to zstar restoration timescale [days] + REAL(wp) :: rn_lf_cutoff ! cutoff frequency for low-pass filter [days] + REAL(wp) :: rn_zdef_max ! maximum fractional e3t deformation + LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE. ! debug control prints + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_td, vn_td ! thickness diffusion transport + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv_lf ! low frequency part of hz divergence + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_b, tilde_e3t_n ! baroclinic scale factors + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_a, dtilde_e3t_a ! baroclinic scale factors + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_e3t ! retoring period for scale factors + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence + + !!---------------------------------------------------------------------- + !! 'key_qco' Quasi-Eulerian vertical coordinate + !! OR EMPTY MODULE + !! 'key_linssh' Fix in time vertical coordinate + !!---------------------------------------------------------------------- + + !!====================================================================== +END MODULE domvvl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domwri.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domwri.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6e5a009518672efae856129aa1a07d1e38663ea0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domwri.f90 @@ -0,0 +1,259 @@ + + + + + + + + + + + + + +MODULE domwri + !!====================================================================== + !! *** MODULE domwri *** + !! Ocean initialization : write the ocean domain mesh file(s) + !!====================================================================== + !! History : OPA ! 1997-02 (G. Madec) Original code + !! 8.1 ! 1999-11 (M. Imbard) NetCDF FORMAT with IOIPSL + !! NEMO 1.0 ! 2002-08 (G. Madec) F90 and several file + !! 3.0 ! 2008-01 (S. Masson) add dom_uniq + !! 4.0 ! 2016-01 (G. Madec) simplified mesh_mask.nc file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_wri : create and write mesh and mask file(s) + !! dom_stiff : diagnose maximum grid stiffness/hydrostatic consistency (s-coordinate) + !!---------------------------------------------------------------------- + ! + USE dom_oce ! ocean space and time domain + USE domutl ! + USE phycst , ONLY : rsmall + USE wet_dry, ONLY : ll_wd ! Wetting and drying + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lbclnk ! lateral boundary conditions - mpp exchanges + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_wri ! routine called by inidom.F90 + PUBLIC dom_stiff ! routine called by inidom.F90 + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domwri.F90 15033 2021-06-21 10:24:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_wri + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_wri *** + !! + !! ** Purpose : Create the NetCDF file(s) which contain(s) all the + !! ocean domain informations (mesh and mask arrays). This (these) + !! file(s) is (are) used for visualisation (SAXO software) and + !! diagnostic computation. + !! + !! ** Method : create a file with all domain related arrays + !! + !! ** output file : meshmask.nc : domain size, horizontal grid-point position, + !! masks, depth and vertical scale factors + !!---------------------------------------------------------------------- + INTEGER :: inum ! temprary units for 'mesh_mask.nc' file + CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zprt, zprw ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepu, zdepv ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_wri : create NetCDF mesh and mask information file(s)' + IF(lwp) WRITE(numout,*) '~~~~~~~' + + clnam = 'mesh_mask' ! filename (mesh and mask informations) + + ! ! ============================ + ! ! create 'mesh_mask.nc' file + ! ! ============================ + 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 ) + ! ! 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/) ) ) + ! ! masks + CALL iom_rstput( 0, 0, inum, 'tmask', tmask, ktype = jp_i1 ) ! ! land-sea mask + CALL iom_rstput( 0, 0, inum, 'umask', umask, ktype = jp_i1 ) + CALL iom_rstput( 0, 0, inum, 'vmask', vmask, ktype = jp_i1 ) + CALL iom_rstput( 0, 0, inum, 'fmask', fmask, ktype = jp_i1 ) + + CALL dom_uniq( zprw, 'T' ) + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zprt(ji,jj) = ssmask(ji,jj) * zprw(ji,jj) ! ! unique point mask + END DO ; END DO + CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq( zprw, 'U' ) + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zprt(ji,jj) = ssumask(ji,jj) * zprw(ji,jj) ! ! unique point mask + END DO ; END DO + CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq( zprw, 'V' ) + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zprt(ji,jj) = ssvmask(ji,jj) * zprw(ji,jj) ! ! unique point mask + END DO ; END DO + CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 ) +!!gm ssfmask has been removed ==>> find another solution to defined fmaskutil +!! Here we just remove the output of fmaskutil. +! CALL dom_uniq( zprw, 'F' ) +! DO jj = 1, jpj +! DO ji = 1, jpi +! zprt(ji,jj) = ssfmask(ji,jj) * zprw(ji,jj) ! ! unique point mask +! END DO +! END DO +! CALL iom_rstput( 0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1 ) +!!gm + + ! ! horizontal mesh (inum3) + 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 ) ! ! e1 scale factors + 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 ) ! ! e2 scale factors + 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 ) + + ! note that mbkt is set to 1 over land ==> use surface tmask + zprt(:,:) = REAL( mbkt(:,:) , wp ) + CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points + zprt(:,:) = REAL( mikt(:,:) , wp ) + CALL iom_rstput( 0, 0, inum, 'misf', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points + ! ! vertical mesh + CALL iom_rstput( 0, 0, inum, 'e3t_1d', e3t_1d, ktype = jp_r8 ) ! ! scale factors + 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 ) + 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 ) + ! + CALL iom_rstput( 0, 0, inum, 'gdept_1d' , gdept_1d , ktype = jp_r8 ) ! stretched system + CALL iom_rstput( 0, 0, inum, 'gdepw_1d' , gdepw_1d , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'gdept_0' , gdept_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'gdepw_0' , gdepw_0 , ktype = jp_r8 ) + ! + IF( ln_sco ) THEN ! s-coordinate stiffness + CALL dom_stiff( zprt ) + CALL iom_rstput( 0, 0, inum, 'stiffness', zprt ) ! Max. grid stiffness ratio + ENDIF + ! + IF( ll_wd ) CALL iom_rstput( 0, 0, inum, 'ht_0' , ht_0 , ktype = jp_r8 ) + + ! ! ============================ + CALL iom_close( inum ) ! close the files + ! ! ============================ + END SUBROUTINE dom_wri + + + SUBROUTINE dom_stiff( px1 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_stiff *** + !! + !! ** Purpose : Diagnose maximum grid stiffness/hydrostatic consistency + !! + !! ** Method : Compute Haney (1991) hydrostatic condition ratio + !! Save the maximum in the vertical direction + !! (this number is only relevant in s-coordinates) + !! + !! Haney, 1991, J. Phys. Oceanogr., 21, 610-619. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(out), OPTIONAL :: px1 ! stiffness + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zrxmax + REAL(wp), DIMENSION(4) :: zr1 + REAL(wp), DIMENSION(jpi,jpj) :: zx1 + !!---------------------------------------------------------------------- + zx1(:,:) = 0._wp + zrxmax = 0._wp + zr1(:) = 0._wp + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + !!gm remark: dk(gdepw) = e3t ===>>> possible simplification of the following calculation.... + !! especially since it is gde3w which is used to compute the pressure gradient + !! furthermore, I think gdept_0 should be used below instead of w point in the numerator + !! so that the ratio is computed at the same point (i.e. uw and vw) .... + zr1(1) = ABS( ( gdepw_0(ji ,jj,jk )-gdepw_0(ji-1,jj,jk ) & + & +gdepw_0(ji ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) ) & + & / ( gdepw_0(ji ,jj,jk )+gdepw_0(ji-1,jj,jk ) & + & -gdepw_0(ji ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) + rsmall ) ) * umask(ji-1,jj,jk) + zr1(2) = ABS( ( gdepw_0(ji+1,jj,jk )-gdepw_0(ji ,jj,jk ) & + & +gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji ,jj,jk+1) ) & + & / ( gdepw_0(ji+1,jj,jk )+gdepw_0(ji ,jj,jk ) & + & -gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji ,jj,jk+1) + rsmall ) ) * umask(ji ,jj,jk) + zr1(3) = ABS( ( gdepw_0(ji,jj+1,jk )-gdepw_0(ji,jj ,jk ) & + & +gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj ,jk+1) ) & + & / ( gdepw_0(ji,jj+1,jk )+gdepw_0(ji,jj ,jk ) & + & -gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj ,jk+1) + rsmall ) ) * vmask(ji,jj ,jk) + zr1(4) = ABS( ( gdepw_0(ji,jj ,jk )-gdepw_0(ji,jj-1,jk ) & + & +gdepw_0(ji,jj ,jk+1)-gdepw_0(ji,jj-1,jk+1) ) & + & / ( gdepw_0(ji,jj ,jk )+gdepw_0(ji,jj-1,jk ) & + & -gdepw_0(ji,jj ,jk+1)-gdepw_0(ji,jj-1,jk+1) + rsmall ) ) * vmask(ji,jj-1,jk) + zrxmax = MAXVAL( zr1(1:4) ) + zx1(ji,jj) = MAX( zx1(ji,jj) , zrxmax ) + END DO ; END DO ; END DO + CALL lbc_lnk( 'domwri', zx1, 'T', 1.0_wp ) + ! + IF( PRESENT( px1 ) ) px1 = zx1 + ! + zrxmax = MAXVAL( zx1 ) + ! + CALL mpp_max( 'domwri', zrxmax ) ! max over the global domain + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_stiff : maximum grid stiffness ratio: ', zrxmax + WRITE(numout,*) '~~~~~~~~~' + ENDIF + ! + END SUBROUTINE dom_stiff + + !!====================================================================== +END MODULE domwri diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domzgr.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domzgr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..16a95464429dfe8f3b8fd76f36a90eb9c2f1716c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/domzgr.f90 @@ -0,0 +1,455 @@ + + + + + + + + + + + + + +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 + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domzgr.F90 15556 2021-11-29 15:23:06Z jchanut $ + !! 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 :: 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 + 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 + & is_mbkuvf, mbku, mbkv, mbkf ) ! U/V/F points bottom levels + ! + 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 + & 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 + ! + ! 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) + 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( 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,*) + 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, is_mbkuvf ) ! with a minimum value set to 1 + ! + ! ! ice shelf draft and bathymetry + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( 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 DO ; END DO + ! + ! ! 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( 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 + & k_mbkuvf , k_bot_u , k_bot_v , k_bot_f ) ! U/V/F points bottom levels + !!--------------------------------------------------------------------- + !! *** 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) :: 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 :: 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 + 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_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_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_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._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3v_0' , pe3v , cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3f_0' , pe3f , cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3w_0' , pe3w , cd_type = 'W', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3uw_0' , pe3uw, cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3vw_0' , pe3vw, cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + ! + ! !* 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_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(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 + ! + 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._dp, kfill = jpfillcopy ) + k_bot_u(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_global, 'mbkv', z2d, cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + k_bot_v(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_global, 'mbkf', z2d, cd_type = 'F', psgn = 1._dp, 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 ) + ! + CALL iom_close( inum ) + ! + END SUBROUTINE zgr_read + + + SUBROUTINE zgr_top_bot( k_top, k_bot, k_mbkuvf ) + !!---------------------------------------------------------------------- + !! *** 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 + !! 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 + !!---------------------------------------------------------------------- + ! + 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 = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 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 DO ; END DO + + IF ( k_mbkuvf==0 ) THEN + IF(lwp) WRITE(numout,*) ' mbku, mbkv, mbkf computed from mbkt' + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + mbku(ji,jj) = MIN( mbkt(ji+1,jj ) , mbkt(ji,jj) ) + mbkv(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj) ) + mbkf(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj), mbkt(ji+1,jj ), mbkt(ji+1,jj+1) ) + END DO ; END DO + 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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 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 DO ; END DO + ENDIF + ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zk(ji,jj) = REAL( miku(ji,jj), wp ) + END DO ; END DO + CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) + miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zk(ji,jj) = REAL( mikv(ji,jj), wp ) + END DO ; END DO + CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) + mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zk(ji,jj) = REAL( mikf(ji,jj), wp ) + END DO ; END DO + CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) + mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zk(ji,jj) = REAL( mbku(ji,jj), wp ) + END DO ; END DO + CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) + mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zk(ji,jj) = REAL( mbkv(ji,jj), wp ) + END DO ; END DO + CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) + mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zk(ji,jj) = REAL( mbkf(ji,jj), wp ) + END DO ; END DO + CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) + mbkf(:,:) = MAX( NINT( zk(:,:) ), 1 ) + ! + END SUBROUTINE zgr_top_bot + + !!====================================================================== +END MODULE domzgr diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dtatsd.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dtatsd.f90 new file mode 100644 index 0000000000000000000000000000000000000000..25351152120e939d9158259c651745b7a7545b7d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dtatsd.f90 @@ -0,0 +1,294 @@ + + + + + + + + + + + + + +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 + + + + + !!---------------------------------------------------------------------- + !! 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 ) 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(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(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(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 + 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 jk = 1, jpk ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + 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 DO ; END DO ; END DO + ! +! JC I think it's more convenient to consider the general sco case as the rule +! 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 .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 jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( 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 DO ; END DO + ! +! ELSE !== z- or zps- coordinate ==! +! ! +! DO jk = 1, jpk ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) +! 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 DO ; END DO ; END DO +! ! +! IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level +! DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( 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 DO ; END DO +! 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/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dtauvd.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dtauvd.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9a5229574a97b6c45eda4513d19db847492457f3 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dtauvd.f90 @@ -0,0 +1,252 @@ + + + + + + + + + + + + + +MODULE dtauvd + !!====================================================================== + !! *** MODULE dtauvd *** + !! Ocean data : read ocean U & V current data from gridded data + !!====================================================================== + !! History : 3.5 ! 2013-08 (D. Calvert) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dta_uvd_init : read namelist and allocate data structures + !! dta_uvd : read and time-interpolate ocean U & V current data + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain + ! + USE in_out_manager ! I/O manager + USE fldread ! read input fields + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dta_uvd_init ! called by nemogcm.F90 + PUBLIC dta_uvd ! called by istate.F90 and dyndmp.90 + + LOGICAL , PUBLIC :: ln_uvd_init = .FALSE. ! Flag to initialise with U & V current data + LOGICAL , PUBLIC :: ln_uvd_dyndmp = .FALSE. ! Flag for Newtonian damping toward U & V current data + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_uvd ! structure for input U & V current (file information and data) + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dtauvd.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dta_uvd_init( ld_dyndmp ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_uvd_init *** + !! + !! ** Purpose : initialization of U & V current input data + !! + !! ** Method : - read namc1d_uvd namelist + !! - allocate U & V current data structure + !! - fld_fill data structure with namelist information + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in), OPTIONAL :: ld_dyndmp ! force the initialization when dyndmp is used + ! + INTEGER :: ios, ierr0, ierr1, ierr2, ierr3 ! local integers + CHARACTER(len=100) :: cn_dir ! Root directory for location of files to be used + TYPE(FLD_N), DIMENSION(2) :: suv_i ! Combined U & V namelist information + TYPE(FLD_N) :: sn_ucur, sn_vcur ! U & V data namelist information + !! + NAMELIST/namc1d_uvd/ ln_uvd_init, ln_uvd_dyndmp, cn_dir, sn_ucur, sn_vcur + !!---------------------------------------------------------------------- + ! + ierr0 = 0 ; ierr1 = 0 ; ierr2 = 0 ; ierr3 = 0 + + READ ( numnam_ref, namc1d_uvd, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in reference namelist' ) + ! + READ ( numnam_cfg, namc1d_uvd, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in configuration namelist' ) + IF(lwm) WRITE ( numond, namc1d_uvd ) + + ! ! force the initialization when dyndmp is used + IF( PRESENT( ld_dyndmp ) ) ln_uvd_dyndmp = .TRUE. + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dta_uvd_init : U & V current data ' + WRITE(numout,*) '~~~~~~~~~~~~ ' + WRITE(numout,*) ' Namelist namc1d_uvd : Set flags' + WRITE(numout,*) ' Initialization of ocean U & V current with input data ln_uvd_init = ', ln_uvd_init + WRITE(numout,*) ' Damping of ocean U & V current toward input data ln_uvd_dyndmp = ', ln_uvd_dyndmp + WRITE(numout,*) + IF( .NOT. ln_uvd_init .AND. .NOT. ln_uvd_dyndmp ) THEN + WRITE(numout,*) + WRITE(numout,*) ' U & V current data not used' + ENDIF + ENDIF + ! ! no initialization when restarting + IF( ln_rstart .AND. ln_uvd_init ) THEN + CALL ctl_warn( 'dta_uvd_init: ocean restart and U & V current data initialization, ', & + & 'we keep the restart U & V current values and set ln_uvd_init to FALSE' ) + ln_uvd_init = .FALSE. + ENDIF + + ! + IF( ln_uvd_init .OR. ln_uvd_dyndmp ) THEN + ! !== allocate the data arrays ==! + ALLOCATE( sf_uvd(2), STAT=ierr0 ) + IF( ierr0 > 0 ) THEN + CALL ctl_stop( 'dta_uvd_init: unable to allocate sf_uvd structure' ) ; RETURN + ENDIF + ! + ALLOCATE( sf_uvd(1)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) + IF( sn_ucur%ln_tint ) ALLOCATE( sf_uvd(1)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 ) + ALLOCATE( sf_uvd(2)%fnow(jpi,jpj,jpk) , STAT=ierr2 ) + IF( sn_vcur%ln_tint ) ALLOCATE( sf_uvd(2)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 ) + ! + IF( ierr0 + ierr1 + ierr2 + ierr3 > 0 ) THEN + CALL ctl_stop( 'dta_uvd_init : unable to allocate U & V current data arrays' ) ; RETURN + ENDIF + ! !== fill sf_uvd with sn_ucur, sn_vcur and control print ==! + suv_i(1) = sn_ucur ; suv_i(2) = sn_vcur + CALL fld_fill( sf_uvd, suv_i, cn_dir, 'dta_uvd', 'U & V current data', 'namc1d_uvd' ) + ! + ENDIF + ! + END SUBROUTINE dta_uvd_init + + + SUBROUTINE dta_uvd( kt, Kmm, pud, pvd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_uvd *** + !! + !! ** Purpose : provides U & V current data at time step kt + !! + !! ** Method : - call fldread routine + !! - ORCA_R2: make some hand made alterations to the data (EMPTY) + !! - s- or mixed s-zps coordinate: vertical interpolation onto model mesh + !! - zps coordinate: vertical interpolation onto last partial level + !! - ln_uvd_dyndmp=False: deallocate the U & V current data structure, + !! as the data is no longer used + !! + !! ** Action : puvd, U & V current data interpolated onto model mesh at time-step kt + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pud ! U & V current data + REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pvd ! U & V current data + ! + INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies + INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers + REAL(wp):: zl, zi ! local floats + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zup, zvp ! 1D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dta_uvd') + ! + CALL fld_read( kt, 1, sf_uvd ) !== read U & V current data at time step kt ==! + ! + pud(:,:,:) = sf_uvd(1)%fnow(:,:,:) ! NO mask + pvd(:,:,:) = sf_uvd(2)%fnow(:,:,:) + ! + IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! + ! + ALLOCATE( zup(jpk), zvp(jpk) ) + ! + IF( kt == nit000 .AND. lwp )THEN + WRITE(numout,*) + WRITE(numout,*) 'dta_uvd: interpolate U & V current data onto the s- or mixed s-z-coordinate mesh' + ENDIF + ! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) ! vertical interpolation of U & V current: + DO jk = 1, jpk + zl = (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + IF ( zl < gdept_1d(1 ) ) THEN ! extrapolate above the first level of data + zup(jk) = pud(ji,jj,1) + zvp(jk) = pvd(ji,jj,1) + ELSEIF( zl > gdept_1d(jpk) ) THEN ! extrapolate below the last level of data + zup(jk) = pud(ji,jj,jpkm1) + zvp(jk) = pvd(ji,jj,jpkm1) + ELSE ! inbetween : vertical interpolation between jkk & jkk+1 + DO jkk = 1, jpkm1 ! when dept(jkk) < zl < dept(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)) + zup(jk) = pud(ji,jj,jkk) + ( pud(ji,jj,jkk+1) - pud(ji,jj,jkk) ) * zi + zvp(jk) = pvd(ji,jj,jkk) + ( pvd(ji,jj,jkk+1) - pvd(ji,jj,jkk) ) * zi + ENDIF + END DO + ENDIF + END DO + DO jk = 1, jpkm1 ! apply mask + pud(ji,jj,jk) = zup(jk) * umask(ji,jj,jk) + pvd(ji,jj,jk) = zvp(jk) * vmask(ji,jj,jk) + END DO + pud(ji,jj,jpk) = 0._wp + pvd(ji,jj,jpk) = 0._wp + END DO ; END DO + ! + DEALLOCATE( zup, zvp ) + ! + ELSE !== z- or zps- coordinate ==! + ! + pud(:,:,:) = pud(:,:,:) * umask(:,:,:) ! apply mask + pvd(:,:,:) = pvd(:,:,:) * vmask(:,:,:) + ! + IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ik = mbkt(ji,jj) + IF( ik > 1 ) THEN + zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) + pud(ji,jj,ik) = (1.-zl) * pud(ji,jj,ik) + zl * pud(ji,jj,ik-1) + pvd(ji,jj,ik) = (1.-zl) * pvd(ji,jj,ik) + zl * pvd(ji,jj,ik-1) + ENDIF + END DO ; END DO + ENDIF + ! + ENDIF + ! + IF( .NOT. ln_uvd_dyndmp ) THEN !== deallocate U & V current structure ==! + ! !== (data used only for initialization) ==! + IF(lwp) WRITE(numout,*) 'dta_uvd: deallocate U & V current arrays as they are only used to initialize the run' + DEALLOCATE( sf_uvd(1)%fnow ) ! U current arrays in the structure + IF( sf_uvd(1)%ln_tint ) DEALLOCATE( sf_uvd(1)%fdta ) + DEALLOCATE( sf_uvd(2)%fnow ) ! V current arrays in the structure + IF( sf_uvd(2)%ln_tint ) DEALLOCATE( sf_uvd(2)%fdta ) + DEALLOCATE( sf_uvd ) ! the structure itself + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dta_uvd') + ! + END SUBROUTINE dta_uvd + + !!====================================================================== +END MODULE dtauvd diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynadv.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynadv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..30cb698728228a0f215e65924307cf166c0df53f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynadv.f90 @@ -0,0 +1,158 @@ + + + + + + + + + + + + + +MODULE dynadv + !!============================================================================== + !! *** MODULE dynadv *** + !! Ocean active tracers: advection scheme control + !!============================================================================== + !! History : 1.0 ! 2006-11 (G. Madec) Original code + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.6 ! 2015-05 (N. Ducousso, G. Madec) add Hollingsworth scheme as an option + !! 4.0 ! 2017-07 (G. Madec) add a linear dynamics option + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_adv : compute the momentum advection trend + !! dyn_adv_init : control the different options of advection scheme + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE dynadv_cen2 ! centred flux form advection (dyn_adv_cen2 routine) + USE dynadv_ubs ! UBS flux form advection (dyn_adv_ubs routine) + USE dynkeg ! kinetic energy gradient (dyn_keg routine) + USE dynzad ! vertical advection (dyn_zad routine) + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_adv ! routine called by step module + PUBLIC dyn_adv_init ! routine called by opa module + + ! !!* namdyn_adv namelist * + LOGICAL, PUBLIC :: ln_dynadv_OFF !: linear dynamics (no momentum advection) + LOGICAL, PUBLIC :: ln_dynadv_vec !: vector form + INTEGER, PUBLIC :: nn_dynkeg !: scheme of grad(KE): =0 C2 ; =1 Hollingsworth + LOGICAL, PUBLIC :: ln_dynadv_cen2 !: flux form - 2nd order centered scheme flag + LOGICAL, PUBLIC :: ln_dynadv_ubs !: flux form - 3rd order UBS scheme flag + + INTEGER, PUBLIC :: n_dynadv !: choice of the formulation and scheme for momentum advection + ! ! associated indices: + INTEGER, PUBLIC, PARAMETER :: np_LIN_dyn = 0 ! no advection: linear dynamics + INTEGER, PUBLIC, PARAMETER :: np_VEC_c2 = 1 ! vector form : 2nd order centered scheme + INTEGER, PUBLIC, PARAMETER :: np_FLX_c2 = 2 ! flux form : 2nd order centered scheme + INTEGER, PUBLIC, PARAMETER :: np_FLX_ubs = 3 ! flux form : 3rd order Upstream Biased Scheme + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynadv.F90 14053 2020-12-03 13:48:38Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_adv( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_adv *** + !! + !! ** Purpose : compute the ocean momentum advection trend. + !! + !! ** Method : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the advection term following n_dynadv + !! + !! NB: in flux form advection (ln_dynadv_cen2 or ln_dynadv_ubs=T) + !! a metric term is add to the coriolis term while in vector form + !! it is the relative vorticity which is added to coriolis term + !! (see dynvor module). + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'dyn_adv' ) + ! + SELECT CASE( n_dynadv ) !== compute advection trend and add it to general trend ==! + CASE( np_VEC_c2 ) + CALL dyn_keg ( kt, nn_dynkeg, Kmm, puu, pvv, Krhs ) ! vector form : horizontal gradient of kinetic energy + CALL dyn_zad ( kt, Kmm, puu, pvv, Krhs ) ! vector form : vertical advection + CASE( np_FLX_c2 ) + CALL dyn_adv_cen2( kt, Kmm, puu, pvv, Krhs ) ! 2nd order centered scheme + CASE( np_FLX_ubs ) + CALL dyn_adv_ubs ( kt, Kbb, Kmm, puu, pvv, Krhs ) ! 3rd order UBS scheme (UP3) + END SELECT + ! + IF( ln_timing ) CALL timing_stop( 'dyn_adv' ) + ! + END SUBROUTINE dyn_adv + + + SUBROUTINE dyn_adv_init + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_adv_init *** + !! + !! ** Purpose : Control the consistency between namelist options for + !! momentum advection formulation & scheme and set n_dynadv + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ios ! Local integer + ! + NAMELIST/namdyn_adv/ ln_dynadv_OFF, ln_dynadv_vec, nn_dynkeg, ln_dynadv_cen2, ln_dynadv_ubs + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_adv_init : choice/control of the momentum advection scheme' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + READ ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' ) + READ ( numnam_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' ) + IF(lwm) WRITE ( numond, namdyn_adv ) + + IF(lwp) THEN ! Namelist print + WRITE(numout,*) ' Namelist namdyn_adv : chose a advection formulation & scheme for momentum' + WRITE(numout,*) ' linear dynamics : no momentum advection ln_dynadv_OFF = ', ln_dynadv_OFF + WRITE(numout,*) ' Vector form: 2nd order centered scheme ln_dynadv_vec = ', ln_dynadv_vec + WRITE(numout,*) ' with Hollingsworth scheme (=1) or not (=0) nn_dynkeg = ', nn_dynkeg + WRITE(numout,*) ' flux form: 2nd order centred scheme ln_dynadv_cen2 = ', ln_dynadv_cen2 + WRITE(numout,*) ' 3rd order UBS scheme ln_dynadv_ubs = ', ln_dynadv_ubs + ENDIF + + ioptio = 0 ! parameter control and set n_dynadv + IF( ln_dynadv_OFF ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_LIN_dyn ; ENDIF + IF( ln_dynadv_vec ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_VEC_c2 ; ENDIF + IF( ln_dynadv_cen2 ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_FLX_c2 ; ENDIF + IF( ln_dynadv_ubs ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_FLX_ubs ; ENDIF + + IF( ioptio /= 1 ) CALL ctl_stop( 'choose ONE and only ONE advection scheme' ) + IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW ) CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' ) + + IF(lwp) THEN ! Print the choice + WRITE(numout,*) + SELECT CASE( n_dynadv ) + CASE( np_LIN_dyn ) ; WRITE(numout,*) ' ==>>> linear dynamics : no momentum advection used' + CASE( np_VEC_c2 ) ; WRITE(numout,*) ' ==>>> vector form : keg + zad + vor is used' + IF( nn_dynkeg == nkeg_C2 ) WRITE(numout,*) ' with Centered standard keg scheme' + IF( nn_dynkeg == nkeg_HW ) WRITE(numout,*) ' with Hollingsworth keg scheme' + CASE( np_FLX_c2 ) ; WRITE(numout,*) ' ==>>> flux form : 2nd order scheme is used' + CASE( np_FLX_ubs ) ; WRITE(numout,*) ' ==>>> flux form : UBS scheme is used' + END SELECT + ENDIF + ! + END SUBROUTINE dyn_adv_init + + !!====================================================================== +END MODULE dynadv diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynadv_cen2.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynadv_cen2.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7b9a84c4363fc7f11bf83263943b831d5c21282f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynadv_cen2.f90 @@ -0,0 +1,172 @@ + + + + + + + + + + + + + +MODULE dynadv_cen2 + !!====================================================================== + !! *** MODULE dynadv *** + !! Ocean dynamics: Update the momentum trend with the flux form advection + !! using a 2nd order centred scheme + !!====================================================================== + !! History : 2.0 ! 2006-08 (G. Madec, S. Theetten) Original code + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_adv_cen2 : flux form momentum advection (ln_dynadv_cen2=T) using a 2nd order centred scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE prtctl ! Print control + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_adv_cen2 ! routine called by step.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynadv_cen2.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_adv_cen2( kt, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_adv_cen2 *** + !! + !! ** Purpose : Compute the now momentum advection trend in flux form + !! and the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! + !! ** Action : (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) updated with the now vorticity term trend + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zfu_f, zfu + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zfu_t, zfu_uw + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zfv_f, zfv, zfw + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zfv_t, zfv_vw + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_adv_cen2 : 2nd order flux form momentum advection' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + IF( l_trddyn ) THEN ! trends: store the input trends + zfu_uw(:,:,:) = puu(:,:,:,Krhs) + zfv_vw(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! + ! !== Horizontal advection ==! + ! + DO jk = 1, jpkm1 ! horizontal transport + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zfu(ji,jj,jk) = 0.25_wp * e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * puu(ji,jj,jk,Kmm) + zfv(ji,jj,jk) = 0.25_wp * e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * pvv(ji,jj,jk,Kmm) + END DO ; END DO + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) ! horizontal momentum fluxes (at T- and F-point) + zfu_t(ji+1,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj ,jk,Kmm) ) + zfv_f(ji ,jj ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) + zfu_f(ji ,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) ) + zfv_t(ji ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji ,jj+1,jk,Kmm) ) + END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! divergence of horizontal momentum fluxes + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) & + & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) & + & / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfu_f(ji,jj ,jk) - zfu_f(ji-1,jj,jk) & + & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) & + & / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + END DO ; END DO + END DO + ! + IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic + zfu_uw(:,:,:) = puu(:,:,:,Krhs) - zfu_uw(:,:,:) + zfv_vw(:,:,:) = pvv(:,:,:,Krhs) - zfv_vw(:,:,:) + CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt, Kmm ) + zfu_t(:,:,:) = puu(:,:,:,Krhs) + zfv_t(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! + ! !== Vertical advection ==! + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! surface/bottom advective fluxes set to zero + zfu_uw(ji,jj,jpk) = 0._wp ; zfv_vw(ji,jj,jpk) = 0._wp + zfu_uw(ji,jj, 1 ) = 0._wp ; zfv_vw(ji,jj, 1 ) = 0._wp + END DO ; END DO + IF( ln_linssh ) THEN ! linear free surface: advection through the surface + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji+1,jj) * ww(ji+1,jj,1) ) * puu(ji,jj,1,Kmm) + zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji,jj+1) * ww(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm) + END DO ; END DO + ENDIF + DO jk = 2, jpkm1 ! interior advective fluxes + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) ! 1/4 * Vertical transport + zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) + END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji+1,jj ,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji,jj,jk-1,Kmm) ) + zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji ,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk-1,Kmm) ) + END DO ; END DO + END DO + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! divergence of vertical momentum flux divergence + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & + & / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) & + & / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic + zfu_t(:,:,:) = puu(:,:,:,Krhs) - zfu_t(:,:,:) + zfv_t(:,:,:) = pvv(:,:,:,Krhs) - zfv_t(:,:,:) + CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt, Kmm ) + ENDIF + ! ! Control print + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' cen2 adv - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + END SUBROUTINE dyn_adv_cen2 + + !!============================================================================== +END MODULE dynadv_cen2 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynadv_ubs.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynadv_ubs.f90 new file mode 100644 index 0000000000000000000000000000000000000000..49141680f93b2a89c0279bd2cf36ed68baa6cdb0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynadv_ubs.f90 @@ -0,0 +1,285 @@ + + + + + + + + + + + + + +MODULE dynadv_ubs + !!====================================================================== + !! *** MODULE dynadv_ubs *** + !! Ocean dynamics: Update the momentum trend with the flux form advection + !! trend using a 3rd order upstream biased scheme + !!====================================================================== + !! History : 2.0 ! 2006-08 (R. Benshila, L. Debreu) Original code + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_adv_ubs : flux form momentum advection using (ln_dynadv=T) + !! an 3rd order Upstream Biased Scheme or Quick scheme + !! combined with 2nd or 4th order finite differences + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + REAL(wp), PARAMETER :: gamma1 = 1._wp/3._wp ! =1/4 quick ; =1/3 3rd order UBS + REAL(wp), PARAMETER :: gamma2 = 1._wp/32._wp ! =0 2nd order ; =1/32 4th order centred + + PUBLIC dyn_adv_ubs ! routine called by step.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynadv_ubs.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_adv_ubs( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_adv_ubs *** + !! + !! ** Purpose : Compute the now momentum advection trend in flux form + !! and the general trend of the momentum equation. + !! + !! ** Method : The scheme is the one implemeted in ROMS. It depends + !! on two parameter gamma1 and gamma2. The former control the + !! upstream baised part of the scheme and the later the centred + !! part: gamma1 = 0 pure centered (no diffusive part) + !! = 1/4 Quick scheme + !! = 1/3 3rd order Upstream biased scheme + !! gamma2 = 0 2nd order finite differencing + !! = 1/32 4th order finite differencing + !! For stability reasons, the first term of the fluxes which cor- + !! responds to a second order centered scheme is evaluated using + !! the now velocity (centered in time) while the second term which + !! is the diffusive part of the scheme, is evaluated using the + !! before velocity (forward in time). + !! Default value (hard coded in the begining of the module) are + !! gamma1=1/3 and gamma2=1/32. + !! + !! ** Action : - (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) updated with the 3D advective momentum trends + !! + !! Reference : Shchepetkin & McWilliams, 2005, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zui, zvj, zfuj, zfvi, zl_u, zl_v ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zfu_f, zfu + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zfu_t, zfu_uw + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zfv_f, zfv, zfw + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zfv_t, zfv_vw + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk,2) :: zlu_uu, zlu_uv + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk,2) :: zlv_vv, zlv_vu + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_adv_ubs : UBS flux form momentum advection' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! + zfu_t(:,:,:) = 0._wp + zfv_t(:,:,:) = 0._wp + zfu_f(:,:,:) = 0._wp + zfv_f(:,:,:) = 0._wp + ! + zlu_uu(:,:,:,:) = 0._wp + zlv_vv(:,:,:,:) = 0._wp + zlu_uv(:,:,:,:) = 0._wp + zlv_vu(:,:,:,:) = 0._wp + ! + IF( l_trddyn ) THEN ! trends: store the input trends + zfu_uw(:,:,:) = puu(:,:,:,Krhs) + zfv_vw(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! ! =========================== ! + DO jk = 1, jpkm1 ! Laplacian of the velocity ! + ! ! =========================== ! + ! ! horizontal volume fluxes + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zfu(ji,jj,jk) = e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * puu(ji,jj,jk,Kmm) + zfv(ji,jj,jk) = e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * pvv(ji,jj,jk,Kmm) + END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! laplacian + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zlu_uu(ji,jj,jk,1) = ( ( puu (ji+1,jj ,jk,Kbb) - puu (ji ,jj ,jk,Kbb) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( puu (ji-1,jj ,jk,Kbb) - puu (ji ,jj ,jk,Kbb) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * umask(ji ,jj ,jk) + zlv_vv(ji,jj,jk,1) = ( ( pvv (ji ,jj+1,jk,Kbb) - pvv (ji ,jj ,jk,Kbb) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( pvv (ji ,jj-1,jk,Kbb) - pvv (ji ,jj ,jk,Kbb) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * vmask(ji ,jj ,jk) + zlu_uv(ji,jj,jk,1) = ( puu (ji ,jj+1,jk,Kbb) - puu (ji ,jj ,jk,Kbb) ) * fmask(ji ,jj ,jk) & + & - ( puu (ji ,jj ,jk,Kbb) - puu (ji ,jj-1,jk,Kbb) ) * fmask(ji ,jj-1,jk) + zlv_vu(ji,jj,jk,1) = ( pvv (ji+1,jj ,jk,Kbb) - pvv (ji ,jj ,jk,Kbb) ) * fmask(ji ,jj ,jk) & + & - ( pvv (ji ,jj ,jk,Kbb) - pvv (ji-1,jj ,jk,Kbb) ) * fmask(ji-1,jj ,jk) + ! + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zlu_uu(ji,jj,jk,2) = ( ( zfu(ji+1,jj ,jk) - zfu(ji ,jj ,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zfu(ji-1,jj ,jk) - zfu(ji ,jj ,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * umask(ji ,jj ,jk) + zlv_vv(ji,jj,jk,2) = ( ( zfv(ji ,jj+1,jk) - zfv(ji ,jj ,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zfv(ji ,jj-1,jk) - zfv(ji ,jj ,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * vmask(ji ,jj ,jk) + zlu_uv(ji,jj,jk,2) = ( zfu(ji ,jj+1,jk) - zfu(ji ,jj ,jk) ) * fmask(ji ,jj ,jk) & + & - ( zfu(ji ,jj ,jk) - zfu(ji ,jj-1,jk) ) * fmask(ji ,jj-1,jk) + zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj ,jk) - zfv(ji ,jj ,jk) ) * fmask(ji ,jj ,jk) & + & - ( zfv(ji ,jj ,jk) - zfv(ji-1,jj ,jk) ) * fmask(ji-1,jj ,jk) + END DO ; END DO + END DO + IF( nn_hls == 1 ) CALL lbc_lnk( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', -1.0_wp , zlu_uv(:,:,:,1), 'U', -1.0_wp, & + & zlu_uu(:,:,:,2), 'U', -1.0_wp , zlu_uv(:,:,:,2), 'U', -1.0_wp, & + & zlv_vv(:,:,:,1), 'V', -1.0_wp , zlv_vu(:,:,:,1), 'V', -1.0_wp, & + & zlv_vv(:,:,:,2), 'V', -1.0_wp , zlv_vu(:,:,:,2), 'V', -1.0_wp ) + ! + ! ! ====================== ! + ! ! Horizontal advection ! + DO jk = 1, jpkm1 ! ====================== ! + ! ! horizontal volume fluxes + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zfu(ji,jj,jk) = 0.25_wp * e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * puu(ji,jj,jk,Kmm) + zfv(ji,jj,jk) = 0.25_wp * e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * pvv(ji,jj,jk,Kmm) + END DO ; END DO + ! + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) ! horizontal momentum fluxes at T- and F-point + zui = ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj ,jk,Kmm) ) + zvj = ( pvv(ji,jj,jk,Kmm) + pvv(ji ,jj+1,jk,Kmm) ) + ! + IF( zui > 0 ) THEN ; zl_u = zlu_uu(ji ,jj,jk,1) + ELSE ; zl_u = zlu_uu(ji+1,jj,jk,1) + ENDIF + IF( zvj > 0 ) THEN ; zl_v = zlv_vv(ji,jj ,jk,1) + ELSE ; zl_v = zlv_vv(ji,jj+1,jk,1) + ENDIF + ! + zfu_t(ji+1,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj ,jk) & + & - gamma2 * ( zlu_uu(ji,jj,jk,2) + zlu_uu(ji+1,jj ,jk,2) ) ) & + & * ( zui - gamma1 * zl_u) + zfv_t(ji ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji ,jj+1,jk) & + & - gamma2 * ( zlv_vv(ji,jj,jk,2) + zlv_vv(ji ,jj+1,jk,2) ) ) & + & * ( zvj - gamma1 * zl_v) + ! + zfuj = ( zfu(ji,jj,jk) + zfu(ji ,jj+1,jk) ) + zfvi = ( zfv(ji,jj,jk) + zfv(ji+1,jj ,jk) ) + IF( zfuj > 0 ) THEN ; zl_v = zlv_vu( ji ,jj ,jk,1) + ELSE ; zl_v = zlv_vu( ji+1,jj,jk,1) + ENDIF + IF( zfvi > 0 ) THEN ; zl_u = zlu_uv( ji,jj ,jk,1) + ELSE ; zl_u = zlu_uv( ji,jj+1,jk,1) + ENDIF + ! + zfv_f(ji ,jj ,jk) = ( zfvi - gamma2 * ( zlv_vu(ji,jj,jk,2) + zlv_vu(ji+1,jj ,jk,2) ) ) & + & * ( puu(ji,jj,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) - gamma1 * zl_u ) + zfu_f(ji ,jj ,jk) = ( zfuj - gamma2 * ( zlu_uv(ji,jj,jk,2) + zlu_uv(ji ,jj+1,jk,2) ) ) & + & * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) - gamma1 * zl_v ) + END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! divergence of horizontal momentum fluxes + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) & + & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) & + & / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfu_f(ji,jj ,jk) - zfu_f(ji-1,jj,jk) & + & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) & + & / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + END DO ; END DO + END DO + IF( l_trddyn ) THEN ! trends: send trends to trddyn for diagnostic + zfu_uw(:,:,:) = puu(:,:,:,Krhs) - zfu_uw(:,:,:) + zfv_vw(:,:,:) = pvv(:,:,:,Krhs) - zfv_vw(:,:,:) + CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt, Kmm ) + zfu_t(:,:,:) = puu(:,:,:,Krhs) + zfv_t(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! ! ==================== ! + ! ! Vertical advection ! + ! ! ==================== ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! surface/bottom advective fluxes set to zero + zfu_uw(ji,jj,jpk) = 0._wp + zfv_vw(ji,jj,jpk) = 0._wp + zfu_uw(ji,jj, 1 ) = 0._wp + zfv_vw(ji,jj, 1 ) = 0._wp + END DO ; END DO + IF( ln_linssh ) THEN ! constant volume : advection through the surface + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji+1,jj) * ww(ji+1,jj,1) ) * puu(ji,jj,1,Kmm) + zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji,jj+1) * ww(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm) + END DO ; END DO + ENDIF + DO jk = 2, jpkm1 ! interior fluxes + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) + END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji,jj,jk-1,Kmm) ) + zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk-1,Kmm) ) + END DO ; END DO + END DO + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! divergence of vertical momentum flux divergence + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & + & / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) & + & / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + IF( l_trddyn ) THEN ! save the vertical advection trend for diagnostic + zfu_t(:,:,:) = puu(:,:,:,Krhs) - zfu_t(:,:,:) + zfv_t(:,:,:) = pvv(:,:,:,Krhs) - zfv_t(:,:,:) + CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt, Kmm ) + ENDIF + ! ! Control print + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ubs2 adv - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + END SUBROUTINE dyn_adv_ubs + + !!============================================================================== +END MODULE dynadv_ubs diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynatf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynatf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..71a20a0839fd8cbd9d4215cc571c35d9dace431e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynatf.f90 @@ -0,0 +1,90 @@ + + + + + + + + + + + + + +MODULE dynatf + !!========================================================================= + !! *** MODULE dynatf *** + !! Ocean dynamics: time filtering + !!========================================================================= + !! History : OPA ! 1987-02 (P. Andrich, D. L Hostis) Original code + !! ! 1990-10 (C. Levy, G. Madec) + !! 7.0 ! 1993-03 (M. Guyon) symetrical conditions + !! 8.0 ! 1997-02 (G. Madec & M. Imbard) opa, release 8.0 + !! 8.2 ! 1997-04 (A. Weaver) Euler forward step + !! - ! 1997-06 (G. Madec) lateral boudary cond., lbc routine + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2002-10 (C. Talandier, A-M. Treguier) Open boundary cond. + !! 2.0 ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 2.3 ! 2007-07 (D. Storkey) Calls to BDY routines. + !! 3.2 ! 2009-06 (G. Madec, R.Benshila) re-introduce the vvl option + !! 3.3 ! 2010-09 (D. Storkey, E.O'Dea) Bug fix for BDY module + !! 3.3 ! 2011-03 (P. Oddo) Bug fix for time-splitting+(BDY-OBC) and not VVL + !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes + !! 3.6 ! 2014-04 (G. Madec) add the diagnostic of the time filter trends + !! 3.7 ! 2015-11 (J. Chanut) Free surface simplification + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename dynnxt.F90 -> dynatf.F90. Now just does time filtering. + !!------------------------------------------------------------------------- + + !!---------------------------------------------------------------------------------------------- + !! dyn_atf : apply Asselin time filtering to "now" velocities and vertical scale factors + !!---------------------------------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbcrnf ! river runoffs + USE phycst ! physical constants + USE dynadv ! dynamics: vector invariant versus flux form + USE dynspg_ts ! surface pressure gradient: split-explicit scheme + USE domvvl ! variable volume + USE bdy_oce , ONLY : ln_bdy + USE bdydta ! ocean open boundary conditions + USE bdydyn ! ocean open boundary conditions + USE bdyvol ! ocean open boundary condition (bdy_vol routines) + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + USE trdken ! trend manager: kinetic energy + USE isf_oce , ONLY: ln_isf ! ice shelf + USE isfdynatf , ONLY: isf_dynatf ! ice shelf volume filter correction subroutine + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lbclnk ! lateral boundary condition (or mpp link) + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + USE zdfdrg , ONLY : ln_drgice_imp, rCdU_top + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_atf ! routine called by step.F90 + + !!---------------------------------------------------------------------- + !! 'key_qco' Quasi-Eulerian vertical coordinate + !! OR EMPTY MODULE + !! 'key_linssh' Fix in time vertical coordinate + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_atf( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v ) + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! before and after time level indices + REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered + REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: pe3t, pe3u, pe3v ! scale factors to be time filtered + + WRITE(*,*) 'dyn_atf: You should not have seen this print! error?', kt + END SUBROUTINE dyn_atf + + + !!========================================================================= +END MODULE dynatf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynatf_qco.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynatf_qco.f90 new file mode 100644 index 0000000000000000000000000000000000000000..faf6d7c59c64f988c9aa31f7b27a3adf92a00124 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynatf_qco.f90 @@ -0,0 +1,295 @@ + + + + + + + + + + + + + +MODULE dynatf_qco + !!========================================================================= + !! *** MODULE dynatf_qco *** + !! Ocean dynamics: time filtering + !!========================================================================= + !! History : OPA ! 1987-02 (P. Andrich, D. L Hostis) Original code + !! ! 1990-10 (C. Levy, G. Madec) + !! 7.0 ! 1993-03 (M. Guyon) symetrical conditions + !! 8.0 ! 1997-02 (G. Madec & M. Imbard) opa, release 8.0 + !! 8.2 ! 1997-04 (A. Weaver) Euler forward step + !! - ! 1997-06 (G. Madec) lateral boudary cond., lbc routine + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2002-10 (C. Talandier, A-M. Treguier) Open boundary cond. + !! 2.0 ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 2.3 ! 2007-07 (D. Storkey) Calls to BDY routines. + !! 3.2 ! 2009-06 (G. Madec, R.Benshila) re-introduce the vvl option + !! 3.3 ! 2010-09 D. Storkey, E.O'Dea) Bug fix for BDY module + !! 3.3 ! 2011-03 (P. Oddo) Bug fix for time-splitting+(BDY-OBC) and not VVL + !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes + !! 3.6 ! 2014-04 (G. Madec) add the diagnostic of the time filter trends + !! 3.7 ! 2015-11 (J. Chanut) Free surface simplification + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename dynnxt.F90 -> dynatfLF.F90. Now just does time filtering. + !!------------------------------------------------------------------------- + + !!---------------------------------------------------------------------------------------------- + !! dyn_atf_qco : apply Asselin time filtering to "now" velocities and vertical scale factors + !!---------------------------------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbcrnf ! river runoffs + USE phycst ! physical constants + USE dynadv ! dynamics: vector invariant versus flux form + USE dynspg_ts ! surface pressure gradient: split-explicit scheme + USE domvvl ! variable volume + USE bdy_oce , ONLY: ln_bdy + USE bdydta ! ocean open boundary conditions + USE bdydyn ! ocean open boundary conditions + USE bdyvol ! ocean open boundary condition (bdy_vol routines) + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + USE trdken ! trend manager: kinetic energy + USE isf_oce , ONLY: ln_isf ! ice shelf + USE isfdynatf , ONLY: isf_dynatf ! ice shelf volume filter correction subroutine + USE zdfdrg , ONLY: ln_drgice_imp, rCdU_top + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lbclnk ! lateral boundary condition (or mpp link) + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_atf_qco ! routine called by step.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynatf_qco.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_atf_qco( kt, Kbb, Kmm, Kaa, puu, pvv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_atf_qco *** + !! + !! ** Purpose : Finalize after horizontal velocity. Apply the boundary + !! condition on the after velocity and apply the Asselin time + !! filter to the now fields. + !! + !! ** Method : * Ensure after velocities transport matches time splitting + !! estimate (ln_dynspg_ts=T) + !! + !! * Apply lateral boundary conditions on after velocity + !! at the local domain boundaries through lbc_lnk call, + !! at the one-way open boundaries (ln_bdy=T), + !! at the AGRIF zoom boundaries (lk_agrif=T) + !! + !! * Apply the Asselin time filter to the now fields + !! arrays to start the next time step: + !! (puu(Kmm),pvv(Kmm)) = (puu(Kmm),pvv(Kmm)) + !! + atfp [ (puu(Kbb),pvv(Kbb)) + (puu(Kaa),pvv(Kaa)) - 2 (puu(Kmm),pvv(Kmm)) ] + !! Note that with flux form advection and non linear free surface, + !! the time filter is applied on thickness weighted velocity. + !! As a result, dyn_atf_lf MUST be called after tra_atf. + !! + !! ** Action : puu(Kmm),pvv(Kmm) filtered now horizontal velocity + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! before and after time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zue3a, zue3n, zue3b, zcoef ! local scalars + REAL(wp) :: zve3a, zve3n, zve3b ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zua, zva + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zutau, zvtau + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_atf_qco') + IF( ln_dynspg_ts ) ALLOCATE( zue(jpi,jpj) , zve(jpi,jpj) ) + IF( l_trddyn ) ALLOCATE( zua(jpi,jpj,jpk) , zva(jpi,jpj,jpk) ) + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_atf_qco : Asselin time filtering' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + ! + IF( l_trddyn ) THEN ! prepare the atf trend computation + some diagnostics + ! + ! ! Kinetic energy and Conversion + IF( ln_KE_trd ) CALL trd_dyn( puu(:,:,:,Kaa), pvv(:,:,:,Kaa), jpdyn_ken, kt, Kmm ) + ! + IF( ln_dyn_trd ) THEN ! 3D output: total momentum trends + zua(:,:,:) = ( puu(:,:,:,Kaa) - puu(:,:,:,Kbb) ) * r1_Dt + zva(:,:,:) = ( pvv(:,:,:,Kaa) - pvv(:,:,:,Kbb) ) * r1_Dt + CALL iom_put( "utrd_tot", zua ) ! total momentum trends, except the asselin time filter + CALL iom_put( "vtrd_tot", zva ) + ENDIF + ! + zua(:,:,:) = puu(:,:,:,Kmm) ! save the now velocity before the asselin filter + zva(:,:,:) = pvv(:,:,:,Kmm) ! (caution: there will be a shift by 1 timestep in the + ! ! computation of the asselin filter trends) + ENDIF + + ! Time filter and swap of dynamics arrays + ! ------------------------------------------ + + IF( .NOT. l_1st_euler ) THEN !* Leap-Frog : Asselin time filter + ! ! =============! + IF( ln_linssh ) THEN ! Fixed volume ! + ! ! =============! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + puu(ji,jj,jk,Kmm) = puu(ji,jj,jk,Kmm) + rn_atfp * ( puu(ji,jj,jk,Kbb) - 2._wp * puu(ji,jj,jk,Kmm) + puu(ji,jj,jk,Kaa) ) + pvv(ji,jj,jk,Kmm) = pvv(ji,jj,jk,Kmm) + rn_atfp * ( pvv(ji,jj,jk,Kbb) - 2._wp * pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Kaa) ) + END DO ; END DO ; END DO + ! ! ================! + ELSE ! Variable volume ! + ! ! ================! + ! + IF( ln_dynadv_vec ) THEN ! Asselin filter applied on velocity + ! Before filtered scale factor at (u/v)-points + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + puu(ji,jj,jk,Kmm) = puu(ji,jj,jk,Kmm) + rn_atfp * ( puu(ji,jj,jk,Kbb) - 2._wp * puu(ji,jj,jk,Kmm) + puu(ji,jj,jk,Kaa) ) + pvv(ji,jj,jk,Kmm) = pvv(ji,jj,jk,Kmm) + rn_atfp * ( pvv(ji,jj,jk,Kbb) - 2._wp * pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Kaa) ) + END DO ; END DO ; END DO + ! + ELSE ! Asselin filter applied on thickness weighted velocity + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zue3a = ( 1._wp + r3u(ji,jj,Kaa) * umask(ji,jj,jk) ) * puu(ji,jj,jk,Kaa) + zve3a = ( 1._wp + r3v(ji,jj,Kaa) * vmask(ji,jj,jk) ) * pvv(ji,jj,jk,Kaa) + zue3n = ( 1._wp + r3u(ji,jj,Kmm) * umask(ji,jj,jk) ) * puu(ji,jj,jk,Kmm) + zve3n = ( 1._wp + r3v(ji,jj,Kmm) * vmask(ji,jj,jk) ) * pvv(ji,jj,jk,Kmm) + zue3b = ( 1._wp + r3u(ji,jj,Kbb) * umask(ji,jj,jk) ) * puu(ji,jj,jk,Kbb) + zve3b = ( 1._wp + r3v(ji,jj,Kbb) * vmask(ji,jj,jk) ) * pvv(ji,jj,jk,Kbb) + ! ! filtered scale factor at U-,V-points + puu(ji,jj,jk,Kmm) = ( zue3n + rn_atfp * ( zue3b - 2._wp * zue3n + zue3a ) ) / ( 1._wp + r3u_f(ji,jj)*umask(ji,jj,jk) ) + pvv(ji,jj,jk,Kmm) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n + zve3a ) ) / ( 1._wp + r3v_f(ji,jj)*vmask(ji,jj,jk) ) + END DO ; END DO ; END DO + ! + ENDIF + ! + ENDIF + ! + IF( ln_dynspg_ts .AND. ln_bt_fw ) THEN + ! Revert filtered "now" velocities to time split estimate + ! Doing it here also means that asselin filter contribution is removed + ! zue(:,:) = pe3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1) + ! zve(:,:) = pe3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1) + ! DO jk = 2, jpkm1 + ! zue(:,:) = zue(:,:) + pe3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) + ! zve(:,:) = zve(:,:) + pe3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) + ! END DO + zue(:,:) = (e3u_0(:,:,1)*(1._wp+r3u(:,:,Kmm)*umask(:,:,1))) * puu(:,:,1,Kmm) * umask(:,:,1) + zve(:,:) = (e3v_0(:,:,1)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,1))) * pvv(:,:,1,Kmm) * vmask(:,:,1) + DO jk = 2, jpkm1 + zue(:,:) = zue(:,:) + (e3u_0(:,:,jk)*(1._wp+r3u(:,:,Kmm)*umask(:,:,jk))) * puu(:,:,jk,Kmm) * umask(:,:,jk) + zve(:,:) = zve(:,:) + (e3v_0(:,:,jk)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,jk))) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) + END DO + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = puu(:,:,jk,Kmm) - (zue(:,:) * (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm))) - uu_b(:,:,Kmm)) * umask(:,:,jk) + pvv(:,:,jk,Kmm) = pvv(:,:,jk,Kmm) - (zve(:,:) * (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm))) - vv_b(:,:,Kmm)) * vmask(:,:,jk) + END DO + ENDIF + ! + ENDIF ! .NOT. l_1st_euler + ! + ! This is needed for dyn_ldf_blp to be restartable + IF( nn_hls == 2 ) CALL lbc_lnk( 'dynatfqco', puu(:,:,:,Kmm), 'U', -1.0_dp, pvv(:,:,:,Kmm), 'V', -1.0_dp ) + + ! Set "now" and "before" barotropic velocities for next time step: + ! JC: Would be more clever to swap variables than to make a full vertical + ! integration + ! CAUTION : calculation need to be done in the same way than see GM + uu_b(:,:,Kaa) = (e3u_0(:,:,1)*(1._wp+r3u(:,:,Kaa)*umask(:,:,1))) * puu(:,:,1,Kaa) * umask(:,:,1) + uu_b(:,:,Kmm) = (e3u_0(:,:,1) * ( 1._wp + r3u_f(:,:) * umask(:,:,1) )) * puu(:,:,1,Kmm) * umask(:,:,1) + vv_b(:,:,Kaa) = (e3v_0(:,:,1)*(1._wp+r3v(:,:,Kaa)*vmask(:,:,1))) * pvv(:,:,1,Kaa) * vmask(:,:,1) + vv_b(:,:,Kmm) = (e3v_0(:,:,1) * ( 1._wp + r3v_f(:,:) * vmask(:,:,1))) * pvv(:,:,1,Kmm) * vmask(:,:,1) + DO jk = 2, jpkm1 + uu_b(:,:,Kaa) = uu_b(:,:,Kaa) + (e3u_0(:,:,jk)*(1._wp+r3u(:,:,Kaa)*umask(:,:,jk))) * puu(:,:,jk,Kaa) * umask(:,:,jk) + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + (e3u_0(:,:,jk) * ( 1._wp + r3u_f(:,:) * umask(:,:,jk) )) * puu(:,:,jk,Kmm) * umask(:,:,jk) + vv_b(:,:,Kaa) = vv_b(:,:,Kaa) + (e3v_0(:,:,jk)*(1._wp+r3v(:,:,Kaa)*vmask(:,:,jk))) * pvv(:,:,jk,Kaa) * vmask(:,:,jk) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + (e3v_0(:,:,jk) * ( 1._wp + r3v_f(:,:) * vmask(:,:,jk) )) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) + END DO + uu_b(:,:,Kaa) = uu_b(:,:,Kaa) * (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kaa))) + vv_b(:,:,Kaa) = vv_b(:,:,Kaa) * (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kaa))) + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * (r1_hu_0(:,:)/( 1._wp + r3u_f(:,:) )) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * (r1_hv_0(:,:)/( 1._wp + r3v_f(:,:) )) + ! + IF( .NOT.ln_dynspg_ts ) THEN ! output the barotropic currents + CALL iom_put( "ubar", uu_b(:,:,Kmm) ) + CALL iom_put( "vbar", vv_b(:,:,Kmm) ) + ENDIF + IF( l_trddyn ) THEN ! 3D output: asselin filter trends on momentum + zua(:,:,:) = ( puu(:,:,:,Kmm) - zua(:,:,:) ) * r1_Dt + zva(:,:,:) = ( pvv(:,:,:,Kmm) - zva(:,:,:) ) * r1_Dt + CALL trd_dyn( zua, zva, jpdyn_atf, kt, Kmm ) + ENDIF + ! + IF ( iom_use("utau") ) THEN + IF ( ln_drgice_imp.OR.ln_isfcav ) THEN + ALLOCATE(zutau(jpi,jpj)) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + jk = miku(ji,jj) + zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * puu(ji,jj,jk,Kaa) + END DO ; END DO + CALL iom_put( "utau", zutau(:,:) ) + DEALLOCATE(zutau) + ELSE + CALL iom_put( "utau", utau(:,:) ) + ENDIF + ENDIF + ! + IF ( iom_use("vtau") ) THEN + IF ( ln_drgice_imp.OR.ln_isfcav ) THEN + ALLOCATE(zvtau(jpi,jpj)) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + jk = mikv(ji,jj) + zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * pvv(ji,jj,jk,Kaa) + END DO ; END DO + CALL iom_put( "vtau", zvtau(:,:) ) + DEALLOCATE(zvtau) + ELSE + CALL iom_put( "vtau", vtau(:,:) ) + ENDIF + ENDIF + ! + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' nxt - puu(:,:,:,Kaa): ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Kaa), clinfo2=' pvv(:,:,:,Kaa): ' , mask2=vmask ) + ! + IF( ln_dynspg_ts ) DEALLOCATE( zue, zve ) + IF( l_trddyn ) DEALLOCATE( zua, zva ) + IF( ln_timing ) CALL timing_stop('dyn_atf_qco') + ! + END SUBROUTINE dyn_atf_qco + + !!========================================================================= +END MODULE dynatf_qco diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dyndmp.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dyndmp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..316253e94f5d5f44599a2c3040f8cefaa22aebbe --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dyndmp.f90 @@ -0,0 +1,246 @@ + + + + + + + + + + + + + +MODULE dyndmp + !!====================================================================== + !! *** MODULE dyndmp *** + !! Ocean dynamics: internal restoring trend on momentum (U and V current) + !! This should only be used for C1D case in current form + !!====================================================================== + !! History : 3.5 ! 2013-08 (D. Calvert) Original code + !! 3.6 ! 2014-08 (T. Graham) Modified to use netcdf file of + !! restoration coefficients supplied to tradmp + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_dmp_alloc : allocate dyndmp arrays + !! dyn_dmp_init : namelist read, parameter control and resto coeff. + !! dyn_dmp : update the momentum trend with the internal damping + !!---------------------------------------------------------------------- + USE oce ! ocean: variables + USE dom_oce ! ocean: domain variables + USE c1d ! 1D vertical configuration + USE tradmp ! ocean: internal damping + USE zdf_oce ! ocean: vertical physics + USE phycst ! physical constants + USE dtauvd ! data: U & V current + USE zdfmxl ! vertical physics: mixed layer depth + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_dmp_init ! routine called by nemogcm.F90 + PUBLIC dyn_dmp ! routine called by step_c1d.F90 + + LOGICAL, PUBLIC :: ln_dyndmp !: Flag for Newtonian damping + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: utrdmp !: damping U current trend (m/s2) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vtrdmp !: damping V current trend (m/s2) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto_uv !: restoring coeff. on U & V current + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dyndmp.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION dyn_dmp_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION dyn_dmp_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( utrdmp(jpi,jpj,jpk), vtrdmp(jpi,jpj,jpk), resto_uv(jpi,jpj,jpk), STAT= dyn_dmp_alloc ) + ! + CALL mpp_sum ( 'dyndmp', dyn_dmp_alloc ) + IF( dyn_dmp_alloc > 0 ) CALL ctl_warn('dyn_dmp_alloc: allocation of arrays failed') + ! + END FUNCTION dyn_dmp_alloc + + + SUBROUTINE dyn_dmp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_dmp_init *** + !! + !! ** Purpose : Initialization for the Newtonian damping + !! + !! ** Method : - read the ln_dyndmp parameter from the namc1d_dyndmp namelist + !! - allocate damping arrays + !! - check the parameters of the namtra_dmp namelist + !! - calculate damping coefficient + !!---------------------------------------------------------------------- + INTEGER :: ios, imask ! local integers + !! + NAMELIST/namc1d_dyndmp/ ln_dyndmp + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namc1d_dyndmp, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in reference namelist' ) + READ ( numnam_cfg, namc1d_dyndmp, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in configuration namelist' ) + IF(lwm) WRITE ( numond, namc1d_dyndmp ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dyn_dmp_init : U and V current Newtonian damping' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namc1d_dyndmp : Set damping flag' + WRITE(numout,*) ' add a damping term or not ln_dyndmp = ', ln_dyndmp + WRITE(numout,*) ' Namelist namtra_dmp : Set damping parameters' + WRITE(numout,*) ' Apply relaxation or not ln_tradmp = ', ln_tradmp + WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp + WRITE(numout,*) ' Damping file name cn_resto = ', cn_resto + WRITE(numout,*) + ENDIF + ! + IF( ln_dyndmp ) THEN + ! !== allocate the data arrays ==! + IF( dyn_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dyn_dmp_init: unable to allocate arrays' ) + ! + SELECT CASE ( nn_zdmp ) !== control print of vertical option ==! + CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' momentum damping throughout the water column' + CASE ( 1 ) ; IF(lwp) WRITE(numout,*) ' no momentum damping in the turbocline (avt > 5 cm2/s)' + CASE ( 2 ) ; IF(lwp) WRITE(numout,*) ' no momentum damping in the mixed layer' + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for nn_zdmp = ', nn_zdmp + CALL ctl_stop(ctmp1) + END SELECT + ! + IF( .NOT. ln_uvd_dyndmp ) THEN ! force the initialization of U & V current data for damping + CALL ctl_warn( 'dyn_dmp_init: U & V current read data not initialized, we force ln_uvd_dyndmp=T' ) + CALL dta_uvd_init( ld_dyndmp=ln_dyndmp ) + ENDIF + ! + utrdmp(:,:,:) = 0._wp ! internal damping trends + vtrdmp(:,:,:) = 0._wp + ! + !Read in mask from file + CALL iom_open ( cn_resto, imask) + CALL iom_get ( imask, jpdom_auto, 'resto', resto) + CALL iom_close( imask ) + ENDIF + ! + END SUBROUTINE dyn_dmp_init + + + SUBROUTINE dyn_dmp( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_dmp *** + !! + !! ** Purpose : Compute the momentum trends due to a newtonian damping + !! of the ocean velocities towards the given data and add it to the + !! general momentum trends. + !! + !! ** Method : Compute Newtonian damping towards u_dta and v_dta + !! and add to the general momentum trends: + !! puu(Krhs) = puu(Krhs) + resto_uv * (u_dta - puu(Kbb)) + !! pvv(Krhs) = pvv(Krhs) + resto_uv * (v_dta - pvv(Kbb)) + !! The trend is computed either throughout the water column + !! (nn_zdmp=0), where the vertical mixing is weak (nn_zdmp=1) or + !! below the well mixed layer (nn_zdmp=2) + !! + !! ** Action : - (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) momentum trends updated with the damping trend + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zua, zva ! local scalars + REAL(dp), DIMENSION(jpi,jpj,jpk,2) :: zuv_dta ! Read in data + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'dyn_dmp' ) + ! + ! + ! !== read and interpolate U & V current data at kt ==! + CALL dta_uvd( kt, Kmm, zuv_dta(:,:,:,1), zuv_dta(:,:,:,2)) + ! + SELECT CASE ( nn_zdmp ) !== Calculate/add Newtonian damping to the momentum trend ==! + ! + CASE( 0 ) ! Newtonian damping throughout the water column + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - puu(ji,jj,jk,Kbb) ) + zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - pvv(ji,jj,jk,Kbb) ) + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zua + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zva + utrdmp(ji,jj,jk) = zua ! save the trends + vtrdmp(ji,jj,jk) = zva + END DO ; END DO ; END DO + ! + CASE ( 1 ) ! no damping above the turbocline (avt > 5 cm2/s) + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + IF( avt(ji,jj,jk) <= avt_c ) THEN + zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - puu(ji,jj,jk,Kbb) ) + zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - pvv(ji,jj,jk,Kbb) ) + ELSE + zua = 0._wp + zva = 0._wp + ENDIF + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zua + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zva + utrdmp(ji,jj,jk) = zua ! save the trends + vtrdmp(ji,jj,jk) = zva + END DO ; END DO ; END DO + ! + CASE ( 2 ) ! no damping in the mixed layer + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + IF( (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) >= hmlp (ji,jj) ) THEN + zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - puu(ji,jj,jk,Kbb) ) + zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - pvv(ji,jj,jk,Kbb) ) + ELSE + zua = 0._wp + zva = 0._wp + ENDIF + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zua + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zva + utrdmp(ji,jj,jk) = zua ! save the trends + vtrdmp(ji,jj,jk) = zva + END DO ; END DO ; END DO + ! + END SELECT + ! + ! ! Control print + !IF( sn_cfctl%l_prtctl ) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' dmp - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + ! + IF( ln_timing ) CALL timing_stop( 'dyn_dmp') + ! + END SUBROUTINE dyn_dmp + + !!====================================================================== +END MODULE dyndmp diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynhpg.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynhpg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a7cf3516edfe9c66dfc0dda746730406fff0b70d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynhpg.f90 @@ -0,0 +1,1463 @@ + + + + + + + + + + + + + +MODULE dynhpg + !!====================================================================== + !! *** MODULE dynhpg *** + !! Ocean dynamics: hydrostatic pressure gradient trend + !!====================================================================== + !! History : OPA ! 1987-09 (P. Andrich, M.-A. Foujols) hpg_zco: Original code + !! 5.0 ! 1991-11 (G. Madec) + !! 7.0 ! 1996-01 (G. Madec) hpg_sco: Original code for s-coordinates + !! 8.0 ! 1997-05 (G. Madec) split dynber into dynkeg and dynhpg + !! 8.5 ! 2002-07 (G. Madec) F90: Free form and module + !! 8.5 ! 2002-08 (A. Bozec) hpg_zps: Original code + !! NEMO 1.0 ! 2005-10 (A. Beckmann, B.W. An) various s-coordinate options + !! ! Original code for hpg_ctl, hpg_hel hpg_wdj, hpg_djc, hpg_rot + !! - ! 2005-11 (G. Madec) style & small optimisation + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.4 ! 2011-11 (H. Liu) hpg_prj: Original code for s-coordinates + !! ! (A. Coward) suppression of hel, wdj and rot options + !! 3.6 ! 2014-11 (P. Mathiot) hpg_isf: original code for ice shelf cavity + !! 4.2 ! 2020-12 (M. Bell, A. Young) hpg_djc: revised djc scheme + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_hpg : update the momentum trend with the now horizontal + !! gradient of the hydrostatic pressure + !! dyn_hpg_init : initialisation and control of options + !! hpg_zco : z-coordinate scheme + !! hpg_zps : z-coordinate plus partial steps (interpolation) + !! hpg_sco : s-coordinate (standard jacobian formulation) + !! hpg_isf : s-coordinate (sco formulation) adapted to ice shelf + !! hpg_djc : s-coordinate (Density Jacobian with Cubic polynomial) + !! hpg_prj : s-coordinate (Pressure Jacobian with Cubic polynomial) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE isf_oce , ONLY : risfload ! ice shelf (risfload variable) + USE isfload , ONLY : isf_load ! ice shelf (isf_load routine ) + USE sbc_oce ! surface variable (only for the flag with ice shelf) + USE dom_oce ! ocean space and time domain + USE wet_dry ! wetting and drying + USE phycst ! physical constants + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + USE zpshde ! partial step: hor. derivative (zps_hde routine) + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE lbclnk ! lateral boundary condition + USE lib_mpp ! MPP library + USE eosbn2 ! compute density + USE timing ! Timing + USE iom + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_hpg ! routine called by step module + PUBLIC dyn_hpg_init ! routine called by opa module + + ! !!* Namelist namdyn_hpg : hydrostatic pressure gradient + LOGICAL, PUBLIC :: ln_hpg_zco !: z-coordinate - full steps + LOGICAL, PUBLIC :: ln_hpg_zps !: z-coordinate - partial steps (interpolation) + LOGICAL, PUBLIC :: ln_hpg_sco !: s-coordinate (standard jacobian formulation) + LOGICAL, PUBLIC :: ln_hpg_djc !: s-coordinate (Density Jacobian with Cubic polynomial) + LOGICAL, PUBLIC :: ln_hpg_prj !: s-coordinate (Pressure Jacobian scheme) + LOGICAL, PUBLIC :: ln_hpg_isf !: s-coordinate similar to sco modify for isf + + ! !! Flag to control the type of hydrostatic pressure gradient + INTEGER, PARAMETER :: np_ERROR =-10 ! error in specification of lateral diffusion + INTEGER, PARAMETER :: np_zco = 0 ! z-coordinate - full steps + INTEGER, PARAMETER :: np_zps = 1 ! z-coordinate - partial steps (interpolation) + INTEGER, PARAMETER :: np_sco = 2 ! s-coordinate (standard jacobian formulation) + INTEGER, PARAMETER :: np_djc = 3 ! s-coordinate (Density Jacobian with Cubic polynomial) + INTEGER, PARAMETER :: np_prj = 4 ! s-coordinate (Pressure Jacobian scheme) + INTEGER, PARAMETER :: np_isf = 5 ! s-coordinate similar to sco modify for isf + ! + INTEGER, PUBLIC :: nhpg !: type of pressure gradient scheme used ! (deduced from ln_hpg_... flags) (PUBLIC for TAM) + ! + LOGICAL :: ln_hpg_djc_vnh, ln_hpg_djc_vnv ! flag to specify hpg_djc boundary condition type + REAL(wp), PUBLIC :: aco_bc_hor, bco_bc_hor, aco_bc_vrt, bco_bc_vrt !: coefficients for hpg_djc hor and vert boundary conditions + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynhpg.F90 15529 2021-11-23 15:00:19Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_hpg( kt, Kmm, puu, pvv, Krhs ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_hpg *** + !! + !! ** Method : Call the hydrostatic pressure gradient routine + !! using the scheme defined in the namelist + !! + !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend + !! - send trends to trd_dyn for futher diagnostics (l_trddyn=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_hpg') + ! + IF( l_trddyn ) THEN ! Temporary saving of puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends (l_trddyn) + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! + SELECT CASE ( nhpg ) ! Hydrostatic pressure gradient computation + CASE ( np_zco ) ; CALL hpg_zco ( kt, Kmm, puu, pvv, Krhs ) ! z-coordinate + CASE ( np_zps ) ; CALL hpg_zps ( kt, Kmm, puu, pvv, Krhs ) ! z-coordinate plus partial steps (interpolation) + CASE ( np_sco ) ; CALL hpg_sco ( kt, Kmm, puu, pvv, Krhs ) ! s-coordinate (standard jacobian formulation) + CASE ( np_djc ) ; CALL hpg_djc ( kt, Kmm, puu, pvv, Krhs ) ! s-coordinate (Density Jacobian with Cubic polynomial) + CASE ( np_prj ) ; CALL hpg_prj ( kt, Kmm, puu, pvv, Krhs ) ! s-coordinate (Pressure Jacobian scheme) + CASE ( np_isf ) ; CALL hpg_isf ( kt, Kmm, puu, pvv, Krhs ) ! s-coordinate similar to sco modify for ice shelf + END SELECT + ! + IF( l_trddyn ) THEN ! save the hydrostatic pressure gradient trends for momentum trend diagnostics + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_hpg, kt, Kmm ) + DEALLOCATE( ztrdu , ztrdv ) + ENDIF + ! + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' hpg - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_hpg') + ! + END SUBROUTINE dyn_hpg + + + SUBROUTINE dyn_hpg_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_hpg_init *** + !! + !! ** Purpose : initializations for the hydrostatic pressure gradient + !! computation and consistency control + !! + !! ** Action : Read the namelist namdyn_hpg and check the consistency + !! with the type of vertical coordinate used (zco, zps, sco) + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + ! + INTEGER :: ioptio = 0 ! temporary integer + INTEGER :: ios ! Local integer output status for namelist read + !! + INTEGER :: ji, jj, jk, ikt ! dummy loop indices ISF + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zts_top, zrhd ! hypothesys on isf density + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zrhdtop_isf ! density at bottom of ISF + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ziceload ! density at bottom of ISF + !! + NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco, & + & ln_hpg_djc, ln_hpg_prj, ln_hpg_isf, & + & ln_hpg_djc_vnh, ln_hpg_djc_vnv + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namdyn_hpg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist' ) + ! + READ ( numnam_cfg, namdyn_hpg, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist' ) + IF(lwm) WRITE ( numond, namdyn_hpg ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dyn_hpg_init : hydrostatic pressure gradient initialisation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namdyn_hpg : choice of hpg scheme' + WRITE(numout,*) ' z-coord. - full steps ln_hpg_zco = ', ln_hpg_zco + WRITE(numout,*) ' z-coord. - partial steps (interpolation) ln_hpg_zps = ', ln_hpg_zps + WRITE(numout,*) ' s-coord. (standard jacobian formulation) ln_hpg_sco = ', ln_hpg_sco + WRITE(numout,*) ' s-coord. (standard jacobian formulation) for isf ln_hpg_isf = ', ln_hpg_isf + WRITE(numout,*) ' s-coord. (Density Jacobian: Cubic polynomial) ln_hpg_djc = ', ln_hpg_djc + WRITE(numout,*) ' s-coord. (Pressure Jacobian: Cubic polynomial) ln_hpg_prj = ', ln_hpg_prj + ENDIF + ! + IF( .NOT.ln_linssh .AND. (ln_hpg_zco.OR.ln_hpg_zps) ) & + & CALL ctl_stop( 'dyn_hpg_init : non-linear free surface incompatible with hpg_zco or hpg_zps' ) + ! + IF( (.NOT.ln_hpg_isf .AND. ln_isfcav) .OR. (ln_hpg_isf .AND. .NOT.ln_isfcav) ) & + & CALL ctl_stop( 'dyn_hpg_init : ln_hpg_isf=T requires ln_isfcav=T and vice versa' ) + ! + ! + ! ! Set nhpg from ln_hpg_... flags & consistency check + nhpg = np_ERROR + ioptio = 0 + IF( ln_hpg_zco ) THEN ; nhpg = np_zco ; ioptio = ioptio +1 ; ENDIF + IF( ln_hpg_zps ) THEN ; nhpg = np_zps ; ioptio = ioptio +1 ; ENDIF + IF( ln_hpg_sco ) THEN ; nhpg = np_sco ; ioptio = ioptio +1 ; ENDIF + IF( ln_hpg_djc ) THEN ; nhpg = np_djc ; ioptio = ioptio +1 ; ENDIF + IF( ln_hpg_prj ) THEN ; nhpg = np_prj ; ioptio = ioptio +1 ; ENDIF + IF( ln_hpg_isf ) THEN ; nhpg = np_isf ; ioptio = ioptio +1 ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' ) + ! + IF(lwp) THEN + WRITE(numout,*) + SELECT CASE( nhpg ) + CASE( np_zco ) ; WRITE(numout,*) ' ==>>> z-coord. - full steps ' + CASE( np_zps ) ; WRITE(numout,*) ' ==>>> z-coord. - partial steps (interpolation)' + CASE( np_sco ) ; WRITE(numout,*) ' ==>>> s-coord. (standard jacobian formulation)' + CASE( np_djc ) ; WRITE(numout,*) ' ==>>> s-coord. (Density Jacobian: Cubic polynomial)' + CASE( np_prj ) ; WRITE(numout,*) ' ==>>> s-coord. (Pressure Jacobian: Cubic polynomial)' + CASE( np_isf ) ; WRITE(numout,*) ' ==>>> s-coord. (standard jacobian formulation) for isf' + END SELECT + WRITE(numout,*) + ENDIF + ! + IF ( ln_hpg_djc ) THEN + IF (ln_hpg_djc_vnh) THEN ! Von Neumann boundary condition + IF(lwp) WRITE(numout,*) ' horizontal bc: von Neumann ' + aco_bc_hor = 6.0_wp/5.0_wp + bco_bc_hor = 7.0_wp/15.0_wp + ELSE ! Linear extrapolation + IF(lwp) WRITE(numout,*) ' horizontal bc: linear extrapolation' + aco_bc_hor = 3.0_wp/2.0_wp + bco_bc_hor = 1.0_wp/2.0_wp + END IF + IF (ln_hpg_djc_vnv) THEN ! Von Neumann boundary condition + IF(lwp) WRITE(numout,*) ' vertical bc: von Neumann ' + aco_bc_vrt = 6.0_wp/5.0_wp + bco_bc_vrt = 7.0_wp/15.0_wp + ELSE ! Linear extrapolation + IF(lwp) WRITE(numout,*) ' vertical bc: linear extrapolation' + aco_bc_vrt = 3.0_wp/2.0_wp + bco_bc_vrt = 1.0_wp/2.0_wp + END IF + END IF + ! + END SUBROUTINE dyn_hpg_init + + + SUBROUTINE hpg_zco( kt, Kmm, puu, pvv, Krhs ) + !!--------------------------------------------------------------------- + !! *** ROUTINE hpg_zco *** + !! + !! ** Method : z-coordinate case, levels are horizontal surfaces. + !! The now hydrostatic pressure gradient at a given level, jk, + !! is computed by taking the vertical integral of the in-situ + !! density gradient along the model level from the suface to that + !! level: zhpi = grav ..... + !! zhpj = grav ..... + !! add it to the general momentum trend (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)). + !! puu(:,:,:,Krhs) = puu(:,:,:,Krhs) - 1/e1u * zhpi + !! pvv(:,:,:,Krhs) = pvv(:,:,:,Krhs) - 1/e2v * zhpj + !! + !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef0, zcoef1 ! temporary scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zhpi, zhpj + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:hpg_zco : hydrostatic pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ z-coordinate case ' + ENDIF + ENDIF + ! + zcoef0 = - grav * 0.5_wp ! Local constant initialization + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! Surface value + zcoef1 = zcoef0 * (e3w_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))) + ! ! hydrostatic pressure gradient + zhpi(ji,jj) = zcoef1 * ( rhd(ji+1,jj,1) - rhd(ji,jj,1) ) * r1_e1u(ji,jj) + zhpj(ji,jj) = zcoef1 * ( rhd(ji,jj+1,1) - rhd(ji,jj,1) ) * r1_e2v(ji,jj) + ! ! add to the general momentum trend + puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj) + pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj) + END DO ; END DO + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! interior value (2= 1 ) THEN ! on i-direction (level 2 or more) + puu (ji,jj,iku,Krhs) = puu(ji,jj,iku,Krhs) - zhpi(ji,jj,iku) ! subtract old value + zhpi(ji,jj,iku) = zhpi(ji,jj,iku-1) & ! compute the new one + & + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + zgru(ji,jj) ) * r1_e1u(ji,jj) + puu (ji,jj,iku,Krhs) = puu(ji,jj,iku,Krhs) + zhpi(ji,jj,iku) ! add the new one to the general momentum trend + ENDIF + IF( ikv > 1 ) THEN ! on j-direction (level 2 or more) + pvv (ji,jj,ikv,Krhs) = pvv(ji,jj,ikv,Krhs) - zhpj(ji,jj,ikv) ! subtract old value + zhpj(ji,jj,ikv) = zhpj(ji,jj,ikv-1) & ! compute the new one + & + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + zgrv(ji,jj) ) * r1_e2v(ji,jj) + pvv (ji,jj,ikv,Krhs) = pvv(ji,jj,ikv,Krhs) + zhpj(ji,jj,ikv) ! add the new one to the general momentum trend + ENDIF + END DO ; END DO + ! + END SUBROUTINE hpg_zps + + + SUBROUTINE hpg_sco( kt, Kmm, puu, pvv, Krhs ) + !!--------------------------------------------------------------------- + !! *** ROUTINE hpg_sco *** + !! + !! ** Method : s-coordinate case. Jacobian scheme. + !! The now hydrostatic pressure gradient at a given level, jk, + !! is computed by taking the vertical integral of the in-situ + !! density gradient along the model level from the suface to that + !! level. s-coordinates (ln_sco): a corrective term is added + !! to the horizontal pressure gradient : + !! zhpi = grav ..... + 1/e1u mi(rhd) di[ grav dep3w ] + !! zhpj = grav ..... + 1/e2v mj(rhd) dj[ grav dep3w ] + !! add it to the general momentum trend (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)). + !! puu(:,:,:,Krhs) = puu(:,:,:,Krhs) - 1/e1u * zhpi + !! pvv(:,:,:,Krhs) = pvv(:,:,:,Krhs) - 1/e2v * zhpj + !! + !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + !! + INTEGER :: ji, jj, jk, jii, jjj ! dummy loop indices + REAL(wp) :: zcoef0, zuap, zvap, ztmp ! local scalars + LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zhpi, zhpj + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter + !!---------------------------------------------------------------------- + ! + IF( ln_wd_il ) ALLOCATE(zcpx(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)), zcpy(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls))) + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:hpg_sco : hydrostatic pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ s-coordinate case, OCE original scheme used' + ENDIF + ENDIF + ! + zcoef0 = - grav * 0.5_wp + ! + IF( ln_wd_il ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji+1,jj,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji+1,jj,Kmm) ) > 1.E-12 ) .AND. ( & + & MAX( ssh(ji,jj,Kmm) , ssh(ji+1,jj,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpx(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm)) ) + ELSE + zcpx(ji,jj) = 0._wp + END IF + + ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji,jj+1,Kmm) ) > 1.E-12 ) .AND. ( & + & MAX( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpy(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm)) ) + ELSE + zcpy(ji,jj) = 0._wp + END IF + END DO ; END DO + END IF + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! Surface value + ! ! hydrostatic pressure gradient along s-surfaces + zhpi(ji,jj,1) = zcoef0 * r1_e1u(ji,jj) & + & * ( (e3w_0(ji+1,jj ,1)*(1._wp+r3t(ji+1,jj ,Kmm))) * rhd(ji+1,jj ,1) & + & - (e3w_0(ji ,jj ,1)*(1._wp+r3t(ji ,jj ,Kmm))) * rhd(ji ,jj ,1) ) + zhpj(ji,jj,1) = zcoef0 * r1_e2v(ji,jj) & + & * ( (e3w_0(ji ,jj+1,1)*(1._wp+r3t(ji ,jj+1,Kmm))) * rhd(ji ,jj+1,1) & + & - (e3w_0(ji ,jj ,1)*(1._wp+r3t(ji ,jj ,Kmm))) * rhd(ji ,jj ,1) ) + ! ! s-coordinate pressure gradient correction + zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) ) & + & * ( ((gdept_0(ji+1,jj,1)*(1._wp+r3t(ji+1,jj,Kmm)))-ssh(ji+1,jj,Kmm)) - ((gdept_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) ) * r1_e1u(ji,jj) + zvap = -zcoef0 * ( rhd (ji,jj+1,1) + rhd (ji,jj,1) ) & + & * ( ((gdept_0(ji,jj+1,1)*(1._wp+r3t(ji,jj+1,Kmm)))-ssh(ji,jj+1,Kmm)) - ((gdept_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) ) * r1_e2v(ji,jj) + ! + IF( ln_wd_il ) THEN + zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) + zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) + zuap = zuap * zcpx(ji,jj) + zvap = zvap * zcpy(ji,jj) + ENDIF + ! ! add to the general momentum trend + puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) + zuap + pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) + zvap + END DO ; END DO + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! interior value (2= & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji+1,jj,Kmm) ) > 1.E-12 ) .AND. ( & + & MAX( ssh(ji,jj,Kmm) , ssh(ji+1,jj,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) + IF(ll_tmp1) THEN + zcpx(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm)) ) + ELSE + zcpx(ji,jj) = 0._wp + END IF + + ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji,jj+1,Kmm) ) > 1.E-12 ) .AND. ( & + & MAX( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpy(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm)) ) + ELSE + zcpy(ji,jj) = 0._wp + END IF + END DO ; END DO + END IF + + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:hpg_djc : hydrostatic pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ s-coordinate case, density Jacobian with cubic polynomial scheme' + ENDIF + ENDIF + + ! Local constant initialization + zcoef0 = - grav * 0.5_wp + z_grav_10 = grav / 10._wp + z1_12 = 1.0_wp / 12._wp + + !---------------------------------------------------------------------------------------- + ! 1. compute and store elementary vertical differences in provisional arrays + !---------------------------------------------------------------------------------------- + +!!bug gm Not a true bug, but... zdzz=e3w for zdzx, zdzy verify what it is really + + DO jk = 2, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + zdrhoz(ji,jj,jk) = rhd (ji ,jj ,jk) - rhd (ji,jj,jk-1) + zdzz (ji,jj,jk) = - ((gdept_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kmm)))-ssh(ji ,jj ,Kmm)) + ((gdept_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) + END DO ; END DO ; END DO + + !------------------------------------------------------------------------- + ! 2. compute harmonic averages for vertical differences using eq. 5.18 + !------------------------------------------------------------------------- + zep = 1.e-15 + +!! mb zdrho_k, zdz_k, zdrho_i, zdz_i, zdrho_j, zdz_j re-centred about the point (ji,jj,jk) + zdrho_k(:,:,:) = 0._wp + zdz_k (:,:,:) = 0._wp + + DO jk = 2, jpk-2 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + cffw = MAX( 2._wp * zdrhoz(ji,jj,jk) * zdrhoz(ji,jj,jk+1), 0._wp ) + z1_cff = zdrhoz(ji,jj,jk) + zdrhoz(ji,jj,jk+1) + zdrho_k(ji,jj,jk) = cffw / SIGN( MAX( ABS(z1_cff), zep ), z1_cff ) + zdz_k(ji,jj,jk) = 2._wp * zdzz(ji,jj,jk) * zdzz(ji,jj,jk+1) & + & / ( zdzz(ji,jj,jk) + zdzz(ji,jj,jk+1) ) + END DO ; END DO ; END DO + + !---------------------------------------------------------------------------------- + ! 3. apply boundary conditions at top and bottom using 5.36-5.37 + !---------------------------------------------------------------------------------- + +! mb for sea-ice shelves we will need to re-write this upper boundary condition in the same form as the lower boundary condition + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zdrho_k(ji,jj,1) = aco_bc_vrt * ( rhd (ji,jj,2) - rhd (ji,jj,1) ) - bco_bc_vrt * zdrho_k(ji,jj,2) + zdz_k (ji,jj,1) = aco_bc_vrt * (-((gdept_0(ji,jj,2)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) + ((gdept_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) ) - bco_bc_vrt * zdz_k (ji,jj,2) + END DO ; END DO + + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + IF ( mbkt(ji,jj)>1 ) THEN + iktb = mbkt(ji,jj) + zdrho_k(ji,jj,iktb) = aco_bc_vrt * ( rhd(ji,jj,iktb) - rhd(ji,jj,iktb-1) ) - bco_bc_vrt * zdrho_k(ji,jj,iktb-1) + zdz_k (ji,jj,iktb) = aco_bc_vrt * (-((gdept_0(ji,jj,iktb)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) + ((gdept_0(ji,jj,iktb-1)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) ) - bco_bc_vrt * zdz_k (ji,jj,iktb-1) + END IF + END DO ; END DO + + !-------------------------------------------------------------- + ! 4. Compute side face integrals + !------------------------------------------------------------- + +!! ssh replaces e3w_n ; gde3w is a depth; the formulae involve heights +!! rho_k stores grav * FX / rho_0 + + !-------------------------------------------------------------- + ! 4. a) Upper half of top-most grid box, compute and store + !------------------------------------------------------------- +! *** AY note: ssh(ji,jj,Kmm) + ((gdept_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) = (e3w_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))) + DO jj = ntsj-( 0), ntej+( 1) ; DO ji = ntsi-( 0), ntei+( 1) + z_rho_k(ji,jj,1) = grav * (gdept_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))) & + & * ( rhd(ji,jj,1) & + & -0.5_wp * ( rhd(ji,jj,2) - rhd(ji,jj,1) ) & + & * (gdept_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))) / (e3w_0(ji,jj,2)*(1._wp+r3t(ji,jj,Kmm))) & + & ) + END DO ; END DO + + !-------------------------------------------------------------- + ! 4. b) Interior faces, compute and store + !------------------------------------------------------------- + + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 1) ; DO ji = ntsi-( 0), ntei+( 1) + z_rho_k(ji,jj,jk) = zcoef0 * ( rhd (ji,jj,jk) + rhd (ji,jj,jk-1) ) & + & * ( - ((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) + ((gdept_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) ) & + & + z_grav_10 * ( & + & ( zdrho_k (ji,jj,jk) - zdrho_k (ji,jj,jk-1) ) & + & * ( - ((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) + ((gdept_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) - z1_12 * ( zdz_k (ji,jj,jk) + zdz_k (ji,jj,jk-1) ) ) & + & - ( zdz_k (ji,jj,jk) - zdz_k (ji,jj,jk-1) ) & + & * ( rhd (ji,jj,jk) - rhd (ji,jj,jk-1) - z1_12 * ( zdrho_k(ji,jj,jk) + zdrho_k(ji,jj,jk-1) ) ) & + & ) + END DO ; END DO ; END DO + + !---------------------------------------------------------------------------------------- + ! 5. compute and store elementary horizontal differences in provisional arrays + !---------------------------------------------------------------------------------------- + zdrhox(:,:,:) = 0._wp + zdzx (:,:,:) = 0._wp + zdrhoy(:,:,:) = 0._wp + zdzy (:,:,:) = 0._wp + + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zdrhox(ji,jj,jk) = rhd (ji+1,jj ,jk) - rhd (ji ,jj ,jk) + zdzx (ji,jj,jk) = ((gdept_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kmm)))-ssh(ji ,jj ,Kmm)) - ((gdept_0(ji+1,jj ,jk)*(1._wp+r3t(ji+1,jj ,Kmm)))-ssh(ji+1,jj ,Kmm)) + zdrhoy(ji,jj,jk) = rhd (ji ,jj+1,jk) - rhd (ji ,jj ,jk) + zdzy (ji,jj,jk) = ((gdept_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kmm)))-ssh(ji ,jj ,Kmm)) - ((gdept_0(ji ,jj+1,jk)*(1._wp+r3t(ji ,jj+1,Kmm)))-ssh(ji ,jj+1,Kmm)) + END DO ; END DO ; END DO + + IF( nn_hls == 1 ) CALL lbc_lnk( 'dynhpg', zdrhox, 'U', -1._wp, zdzx, 'U', -1._wp, zdrhoy, 'V', -1._wp, zdzy, 'V', -1._wp ) + + !------------------------------------------------------------------------- + ! 6. compute harmonic averages using eq. 5.18 + !------------------------------------------------------------------------- + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 1) ; DO ji = ntsi-( 0), ntei+( 1) + cffu = MAX( 2._wp * zdrhox(ji-1,jj,jk) * zdrhox(ji,jj,jk), 0._wp ) + z1_cff = zdrhox(ji-1,jj,jk) + zdrhox(ji,jj,jk) + zdrho_i(ji,jj,jk) = cffu / SIGN( MAX( ABS(z1_cff), zep ), z1_cff ) + + cffx = MAX( 2._wp * zdzx(ji-1,jj,jk) * zdzx(ji,jj,jk), 0._wp ) + z1_cff = zdzx(ji-1,jj,jk) + zdzx(ji,jj,jk) + zdz_i(ji,jj,jk) = cffx / SIGN( MAX( ABS(z1_cff), zep ), z1_cff ) + + cffv = MAX( 2._wp * zdrhoy(ji,jj-1,jk) * zdrhoy(ji,jj,jk), 0._wp ) + z1_cff = zdrhoy(ji,jj-1,jk) + zdrhoy(ji,jj,jk) + zdrho_j(ji,jj,jk) = cffv / SIGN( MAX( ABS(z1_cff), zep ), z1_cff ) + + cffy = MAX( 2._wp * zdzy(ji,jj-1,jk) * zdzy(ji,jj,jk), 0._wp ) + z1_cff = zdzy(ji,jj-1,jk) + zdzy(ji,jj,jk) + zdz_j(ji,jj,jk) = cffy / SIGN( MAX( ABS(z1_cff), zep ), z1_cff ) + END DO ; END DO ; END DO + +!!! Note that zdzx, zdzy, zdzz, zdrhox, zdrhoy and zdrhoz should NOT be used beyond this point + + !---------------------------------------------------------------------------------- + ! 6B. apply boundary conditions at side boundaries using 5.36-5.37 + !---------------------------------------------------------------------------------- + + DO jk = 1, jpkm1 + zz_drho_i(:,:) = zdrho_i(:,:,jk) + zz_dz_i (:,:) = zdz_i (:,:,jk) + zz_drho_j(:,:) = zdrho_j(:,:,jk) + zz_dz_j (:,:) = zdz_j (:,:,jk) + ! Walls coming from left: should check from 2 to jpi-1 (and jpj=2-jpj) + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 0) + IF ( umask(ji,jj,jk) > 0.5_wp .AND. umask(ji-1,jj,jk) < 0.5_wp .AND. umask(ji+1,jj,jk) > 0.5_wp) THEN + zz_drho_i(ji,jj) = aco_bc_hor * ( rhd (ji+1,jj,jk) - rhd (ji,jj,jk) ) - bco_bc_hor * zdrho_i(ji+1,jj,jk) + zz_dz_i (ji,jj) = aco_bc_hor * (-((gdept_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kmm)))-ssh(ji+1,jj,Kmm)) + ((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) ) - bco_bc_hor * zdz_i (ji+1,jj,jk) + END IF + END DO ; END DO + ! Walls coming from right: should check from 3 to jpi (and jpj=2-jpj) + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( -1), ntei+( 1) + IF ( umask(ji,jj,jk) < 0.5_wp .AND. umask(ji-1,jj,jk) > 0.5_wp .AND. umask(ji-2,jj,jk) > 0.5_wp) THEN + zz_drho_i(ji,jj) = aco_bc_hor * ( rhd (ji,jj,jk) - rhd (ji-1,jj,jk) ) - bco_bc_hor * zdrho_i(ji-1,jj,jk) + zz_dz_i (ji,jj) = aco_bc_hor * (-((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) + ((gdept_0(ji-1,jj,jk)*(1._wp+r3t(ji-1,jj,Kmm)))-ssh(ji-1,jj,Kmm)) ) - bco_bc_hor * zdz_i (ji-1,jj,jk) + END IF + END DO ; END DO + ! Walls coming from left: should check from 2 to jpj-1 (and jpi=2-jpi) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 1) + IF ( vmask(ji,jj,jk) > 0.5_wp .AND. vmask(ji,jj-1,jk) < 0.5_wp .AND. vmask(ji,jj+1,jk) > 0.5_wp) THEN + zz_drho_j(ji,jj) = aco_bc_hor * ( rhd (ji,jj+1,jk) - rhd (ji,jj,jk) ) - bco_bc_hor * zdrho_j(ji,jj+1,jk) + zz_dz_j (ji,jj) = aco_bc_hor * (-((gdept_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kmm)))-ssh(ji,jj+1,Kmm)) + ((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) ) - bco_bc_hor * zdz_j (ji,jj+1,jk) + END IF + END DO ; END DO + ! Walls coming from right: should check from 3 to jpj (and jpi=2-jpi) + DO jj = ntsj-( -1), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + IF ( vmask(ji,jj,jk) < 0.5_wp .AND. vmask(ji,jj-1,jk) > 0.5_wp .AND. vmask(ji,jj-2,jk) > 0.5_wp) THEN + zz_drho_j(ji,jj) = aco_bc_hor * ( rhd (ji,jj,jk) - rhd (ji,jj-1,jk) ) - bco_bc_hor * zdrho_j(ji,jj-1,jk) + zz_dz_j (ji,jj) = aco_bc_hor * (-((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) + ((gdept_0(ji,jj-1,jk)*(1._wp+r3t(ji,jj-1,Kmm)))-ssh(ji,jj-1,Kmm)) ) - bco_bc_hor * zdz_j (ji,jj-1,jk) + END IF + END DO ; END DO + zdrho_i(:,:,jk) = zz_drho_i(:,:) + zdz_i (:,:,jk) = zz_dz_i (:,:) + zdrho_j(:,:,jk) = zz_drho_j(:,:) + zdz_j (:,:,jk) = zz_dz_j (:,:) + END DO + + !-------------------------------------------------------------- + ! 7. Calculate integrals on side faces + !------------------------------------------------------------- + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) +! two -ve signs cancel in next two lines (within zcoef0 and because gde3w is a depth not a height) + z_rho_i(ji,jj,jk) = zcoef0 * ( rhd (ji+1,jj,jk) + rhd (ji,jj,jk) ) & + & * ( ((gdept_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kmm)))-ssh(ji+1,jj,Kmm)) - ((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) ) + IF ( umask(ji-1, jj, jk) > 0.5 .OR. umask(ji+1, jj, jk) > 0.5 ) THEN + z_rho_i(ji,jj,jk) = z_rho_i(ji,jj,jk) - z_grav_10 * ( & + & ( zdrho_i (ji+1,jj,jk) - zdrho_i (ji,jj,jk) ) & + & * ( - ((gdept_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kmm)))-ssh(ji+1,jj,Kmm)) + ((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) - z1_12 * ( zdz_i (ji+1,jj,jk) + zdz_i (ji,jj,jk) ) ) & + & - ( zdz_i (ji+1,jj,jk) - zdz_i (ji,jj,jk) ) & + & * ( rhd (ji+1,jj,jk) - rhd (ji,jj,jk) - z1_12 * ( zdrho_i(ji+1,jj,jk) + zdrho_i(ji,jj,jk) ) ) & + & ) + END IF + + z_rho_j(ji,jj,jk) = zcoef0 * ( rhd (ji,jj+1,jk) + rhd (ji,jj,jk) ) & + & * ( ((gdept_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kmm)))-ssh(ji,jj+1,Kmm)) - ((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) ) + IF ( vmask(ji, jj-1, jk) > 0.5 .OR. vmask(ji, jj+1, jk) > 0.5 ) THEN + z_rho_j(ji,jj,jk) = z_rho_j(ji,jj,jk) - z_grav_10 * ( & + & ( zdrho_j (ji,jj+1,jk) - zdrho_j (ji,jj,jk) ) & + & * ( - ((gdept_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kmm)))-ssh(ji,jj+1,Kmm)) + ((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)) - z1_12 * ( zdz_j (ji,jj+1,jk) + zdz_j (ji,jj,jk) ) ) & + & - ( zdz_j (ji,jj+1,jk) - zdz_j (ji,jj,jk) ) & + & * ( rhd (ji,jj+1,jk) - rhd (ji,jj,jk) - z1_12 * ( zdrho_j(ji,jj+1,jk) + zdrho_j(ji,jj,jk) ) ) & + & ) + END IF + END DO ; END DO ; END DO + + !-------------------------------------------------------------- + ! 8. Integrate in the vertical + !------------------------------------------------------------- + ! + ! --------------- + ! Surface value + ! --------------- + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zhpi(ji,jj,1) = ( z_rho_k(ji,jj,1) - z_rho_k(ji+1,jj ,1) - z_rho_i(ji,jj,1) ) * r1_e1u(ji,jj) + zhpj(ji,jj,1) = ( z_rho_k(ji,jj,1) - z_rho_k(ji ,jj+1,1) - z_rho_j(ji,jj,1) ) * r1_e2v(ji,jj) + IF( ln_wd_il ) THEN + zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) + zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) + ENDIF + ! add to the general momentum trend + puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) + pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) + END DO ; END DO + + ! ---------------- + ! interior value (2= & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) ) > & + & rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji+1,jj,Kmm) ) > 1.E-12 ) .AND. & + & ( MAX( ssh(ji,jj,Kmm) , ssh(ji+1,jj,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpx(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm)) ) + zcpx(ji,jj) = MAX(MIN( zcpx(ji,jj) , 1.0_wp),0.0_wp) + ELSE + zcpx(ji,jj) = 0._wp + END IF + + ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) ) > & + & rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji,jj+1,Kmm) ) > 1.E-12 ) .AND. & + & ( MAX( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpy(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm)) ) + zcpy(ji,jj) = MAX(MIN( zcpy(ji,jj) , 1.0_wp),0.0_wp) + ELSE + zcpy(ji,jj) = 0._wp + ENDIF + END DO ; END DO + ENDIF + + ! Clean 3-D work arrays + zhpi(:,:,:) = 0._wp + zrhh(:,:,:) = rhd(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),:) + + ! Preparing vertical density profile "zrhh(:,:,:)" for hybrid-sco coordinate + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + jk = mbkt(ji,jj) + IF( jk <= 1 ) THEN ; zrhh(ji,jj, : ) = 0._wp + ELSEIF( jk == 2 ) THEN ; zrhh(ji,jj,jk+1:jpk) = rhd(ji,jj,jk) + ELSEIF( jk < jpkm1 ) THEN + DO jkk = jk+1, jpk + zrhh(ji,jj,jkk) = interp1(((gdept_0(ji,jj,jkk )*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)), ((gdept_0(ji,jj,jkk-1)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)), & + & ((gdept_0(ji,jj,jkk-2)*(1._wp+r3t(ji,jj,Kmm)))-ssh(ji,jj,Kmm)), zrhh (ji,jj,jkk-1), zrhh(ji,jj,jkk-2)) + END DO + ENDIF + END DO ; END DO + + ! Transfer the depth of "T(:,:,:)" to vertical coordinate "zdept(:,:,:)" + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zdept(ji,jj,1) = 0.5_wp * (e3w_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))) - ssh(ji,jj,Kmm) + END DO ; END DO + + DO jk = 2, jpk ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + zdept(ji,jj,jk) = zdept(ji,jj,jk-1) + (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO ; END DO + + fsp(:,:,:) = zrhh (:,:,:) + xsp(:,:,:) = zdept(:,:,:) + + ! Construct the vertical density profile with the + ! constrained cubic spline interpolation + ! rho(z) = asp + bsp*z + csp*z^2 + dsp*z^3 + CALL cspline( fsp, xsp, asp, bsp, csp, dsp, polynomial_type ) + + ! Integrate the hydrostatic pressure "zhpi(:,:,:)" at "T(ji,jj,1)" + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + zrhdt1 = zrhh(ji,jj,1) - interp3( zdept(ji,jj,1), asp(ji,jj,1), bsp(ji,jj,1), & + & csp(ji,jj,1), dsp(ji,jj,1) ) * 0.25_wp * (e3w_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))) + + ! assuming linear profile across the top half surface layer + zhpi(ji,jj,1) = 0.5_wp * (e3w_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))) * zrhdt1 + END DO ; END DO + + ! Calculate the pressure "zhpi(:,:,:)" at "T(ji,jj,2:jpkm1)" + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 1) ; DO ji = ntsi-( 0), ntei+( 1) + zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + & + & integ_spline( zdept(ji,jj,jk-1), zdept(ji,jj,jk), & + & asp (ji,jj,jk-1), bsp (ji,jj,jk-1), & + & csp (ji,jj,jk-1), dsp (ji,jj,jk-1) ) + END DO ; END DO ; END DO + + ! Z coordinate of U(ji,jj,1:jpkm1) and V(ji,jj,1:jpkm1) + + ! Prepare zsshu_n and zsshv_n + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) +!!gm BUG ? if it is ssh at u- & v-point then it should be: +! zsshu_n(ji,jj) = (e1e2t(ji,jj) * ssh(ji,jj,Kmm) + e1e2t(ji+1,jj) * ssh(ji+1,jj,Kmm)) * & +! & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp +! zsshv_n(ji,jj) = (e1e2t(ji,jj) * ssh(ji,jj,Kmm) + e1e2t(ji,jj+1) * ssh(ji,jj+1,Kmm)) * & +! & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp +!!gm not this: + zsshu_n(ji,jj) = (e1e2u(ji,jj) * ssh(ji,jj,Kmm) + e1e2u(ji+1, jj) * ssh(ji+1,jj,Kmm)) * & + & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp + zsshv_n(ji,jj) = (e1e2v(ji,jj) * ssh(ji,jj,Kmm) + e1e2v(ji+1, jj) * ssh(ji,jj+1,Kmm)) * & + & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp + END DO ; END DO + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu(ji,jj,1) = - ( (e3u_0(ji,jj,1)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,1))) - zsshu_n(ji,jj) ) + zv(ji,jj,1) = - ( (e3v_0(ji,jj,1)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,1))) - zsshv_n(ji,jj) ) + END DO ; END DO + + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zu(ji,jj,jk) = zu(ji,jj,jk-1) - (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + zv(ji,jj,jk) = zv(ji,jj,jk-1) - (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + END DO ; END DO ; END DO + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zu(ji,jj,jk) = zu(ji,jj,jk) + 0.5_wp * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + zv(ji,jj,jk) = zv(ji,jj,jk) + 0.5_wp * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + END DO ; END DO ; END DO + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zu(ji,jj,jk) = MIN( zu(ji,jj,jk) , MAX( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) ) ) + zu(ji,jj,jk) = MAX( zu(ji,jj,jk) , MIN( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) ) ) + zv(ji,jj,jk) = MIN( zv(ji,jj,jk) , MAX( -zdept(ji,jj,jk) , -zdept(ji,jj+1,jk) ) ) + zv(ji,jj,jk) = MAX( zv(ji,jj,jk) , MIN( -zdept(ji,jj,jk) , -zdept(ji,jj+1,jk) ) ) + END DO ; END DO ; END DO + + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zpwes = 0._wp; zpwed = 0._wp + zpnss = 0._wp; zpnsd = 0._wp + zuijk = zu(ji,jj,jk) + zvijk = zv(ji,jj,jk) + + !!!!! for u equation + IF( jk <= mbku(ji,jj) ) THEN + IF( -zdept(ji+1,jj,jk) >= -zdept(ji,jj,jk) ) THEN + jis = ji + 1; jid = ji + ELSE + jis = ji; jid = ji +1 + ENDIF + + ! integrate the pressure on the shallow side + jk1 = jk + DO WHILE ( -zdept(jis,jj,jk1) > zuijk ) + IF( jk1 == mbku(ji,jj) ) THEN + zuijk = -zdept(jis,jj,jk1) + EXIT + ENDIF + zdeps = MIN(zdept(jis,jj,jk1+1), -zuijk) + zpwes = zpwes + & + integ_spline(zdept(jis,jj,jk1), zdeps, & + asp(jis,jj,jk1), bsp(jis,jj,jk1), & + csp(jis,jj,jk1), dsp(jis,jj,jk1)) + jk1 = jk1 + 1 + END DO + + ! integrate the pressure on the deep side + jk1 = jk + DO WHILE ( -zdept(jid,jj,jk1) < zuijk ) + IF( jk1 == 1 ) THEN + zdeps = zdept(jid,jj,1) + MIN(zuijk, ssh(jid,jj,Kmm)*znad) + zrhdt1 = zrhh(jid,jj,1) - interp3(zdept(jid,jj,1), asp(jid,jj,1), & + bsp(jid,jj,1) , csp(jid,jj,1), & + dsp(jid,jj,1)) * zdeps + zpwed = zpwed + 0.5_wp * (zrhh(jid,jj,1) + zrhdt1) * zdeps + EXIT + ENDIF + zdeps = MAX(zdept(jid,jj,jk1-1), -zuijk) + zpwed = zpwed + & + integ_spline(zdeps, zdept(jid,jj,jk1), & + asp(jid,jj,jk1-1), bsp(jid,jj,jk1-1), & + csp(jid,jj,jk1-1), dsp(jid,jj,jk1-1) ) + jk1 = jk1 - 1 + END DO + + ! update the momentum trends in u direction + zdpdx1 = zcoef0 * r1_e1u(ji,jj) * ( zhpi(ji+1,jj,jk) - zhpi(ji,jj,jk) ) + IF( .NOT.ln_linssh ) THEN + zdpdx2 = zcoef0 * r1_e1u(ji,jj) * & + & ( REAL(jis-jid, wp) * (zpwes + zpwed) + (ssh(ji+1,jj,Kmm)-ssh(ji,jj,Kmm)) ) + ELSE + zdpdx2 = zcoef0 * r1_e1u(ji,jj) * REAL(jis-jid, wp) * (zpwes + zpwed) + ENDIF + IF( ln_wd_il ) THEN + zdpdx1 = zdpdx1 * zcpx(ji,jj) * wdrampu(ji,jj) + zdpdx2 = zdpdx2 * zcpx(ji,jj) * wdrampu(ji,jj) + ENDIF + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (zdpdx1 + zdpdx2 - zpgu(ji,jj)) * umask(ji,jj,jk) + ENDIF + + !!!!! for v equation + IF( jk <= mbkv(ji,jj) ) THEN + IF( -zdept(ji,jj+1,jk) >= -zdept(ji,jj,jk) ) THEN + jjs = jj + 1; jjd = jj + ELSE + jjs = jj ; jjd = jj + 1 + ENDIF + + ! integrate the pressure on the shallow side + jk1 = jk + DO WHILE ( -zdept(ji,jjs,jk1) > zvijk ) + IF( jk1 == mbkv(ji,jj) ) THEN + zvijk = -zdept(ji,jjs,jk1) + EXIT + ENDIF + zdeps = MIN(zdept(ji,jjs,jk1+1), -zvijk) + zpnss = zpnss + & + integ_spline(zdept(ji,jjs,jk1), zdeps, & + asp(ji,jjs,jk1), bsp(ji,jjs,jk1), & + csp(ji,jjs,jk1), dsp(ji,jjs,jk1) ) + jk1 = jk1 + 1 + END DO + + ! integrate the pressure on the deep side + jk1 = jk + DO WHILE ( -zdept(ji,jjd,jk1) < zvijk ) + IF( jk1 == 1 ) THEN + zdeps = zdept(ji,jjd,1) + MIN(zvijk, ssh(ji,jjd,Kmm)*znad) + zrhdt1 = zrhh(ji,jjd,1) - interp3(zdept(ji,jjd,1), asp(ji,jjd,1), & + bsp(ji,jjd,1) , csp(ji,jjd,1), & + dsp(ji,jjd,1) ) * zdeps + zpnsd = zpnsd + 0.5_wp * (zrhh(ji,jjd,1) + zrhdt1) * zdeps + EXIT + ENDIF + zdeps = MAX(zdept(ji,jjd,jk1-1), -zvijk) + zpnsd = zpnsd + & + integ_spline(zdeps, zdept(ji,jjd,jk1), & + asp(ji,jjd,jk1-1), bsp(ji,jjd,jk1-1), & + csp(ji,jjd,jk1-1), dsp(ji,jjd,jk1-1) ) + jk1 = jk1 - 1 + END DO + + ! update the momentum trends in v direction + zdpdy1 = zcoef0 * r1_e2v(ji,jj) * ( zhpi(ji,jj+1,jk) - zhpi(ji,jj,jk) ) + IF( .NOT.ln_linssh ) THEN + zdpdy2 = zcoef0 * r1_e2v(ji,jj) * & + ( REAL(jjs-jjd, wp) * (zpnss + zpnsd) + (ssh(ji,jj+1,Kmm)-ssh(ji,jj,Kmm)) ) + ELSE + zdpdy2 = zcoef0 * r1_e2v(ji,jj) * REAL(jjs-jjd, wp) * (zpnss + zpnsd ) + ENDIF + IF( ln_wd_il ) THEN + zdpdy1 = zdpdy1 * zcpy(ji,jj) * wdrampv(ji,jj) + zdpdy2 = zdpdy2 * zcpy(ji,jj) * wdrampv(ji,jj) + ENDIF + + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + (zdpdy1 + zdpdy2 - zpgv(ji,jj)) * vmask(ji,jj,jk) + ENDIF + ! + END DO ; END DO ; END DO + ! + IF( ln_wd_il ) DEALLOCATE( zcpx, zcpy ) + ! + END SUBROUTINE hpg_prj + + + SUBROUTINE cspline( fsp, xsp, asp, bsp, csp, dsp, polynomial_type ) + !!---------------------------------------------------------------------- + !! *** ROUTINE cspline *** + !! + !! ** Purpose : constrained cubic spline interpolation + !! + !! ** Method : f(x) = asp + bsp*x + csp*x^2 + dsp*x^3 + !! + !! Reference: CJC Kruger, Constrained Cubic Spline Interpoltation + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in ) :: fsp, xsp ! value and coordinate + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT( out) :: asp, bsp, csp, dsp ! coefficients of the interpoated function + INTEGER , INTENT(in ) :: polynomial_type ! 1: cubic spline ; 2: Linear + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zdf1, zdf2, zddf1, zddf2, ztmp1, ztmp2, zdxtmp + REAL(wp) :: zdxtmp1, zdxtmp2, zalpha + REAL(wp), DIMENSION(jpk) :: zdf + !!---------------------------------------------------------------------- + ! + IF (polynomial_type == 1) THEN ! Constrained Cubic Spline + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + !!Fritsch&Butland's method, 1984 (preferred, but more computation) + ! DO jk = 2, jpkm1-1 + ! zdxtmp1 = xsp(ji,jj,jk) - xsp(ji,jj,jk-1) + ! zdxtmp2 = xsp(ji,jj,jk+1) - xsp(ji,jj,jk) + ! zdf1 = ( fsp(ji,jj,jk) - fsp(ji,jj,jk-1) ) / zdxtmp1 + ! zdf2 = ( fsp(ji,jj,jk+1) - fsp(ji,jj,jk) ) / zdxtmp2 + ! + ! zalpha = ( zdxtmp1 + 2._wp * zdxtmp2 ) / ( zdxtmp1 + zdxtmp2 ) / 3._wp + ! + ! IF(zdf1 * zdf2 <= 0._wp) THEN + ! zdf(jk) = 0._wp + ! ELSE + ! zdf(jk) = zdf1 * zdf2 / ( ( 1._wp - zalpha ) * zdf1 + zalpha * zdf2 ) + ! ENDIF + ! END DO + + !!Simply geometric average + DO jk = 2, jpk-2 + zdf1 = (fsp(ji,jj,jk ) - fsp(ji,jj,jk-1)) / (xsp(ji,jj,jk ) - xsp(ji,jj,jk-1)) + zdf2 = (fsp(ji,jj,jk+1) - fsp(ji,jj,jk )) / (xsp(ji,jj,jk+1) - xsp(ji,jj,jk )) + + IF(zdf1 * zdf2 <= 0._wp) THEN + zdf(jk) = 0._wp + ELSE + zdf(jk) = 2._wp * zdf1 * zdf2 / (zdf1 + zdf2) + ENDIF + END DO + + zdf(1) = 1.5_wp * ( fsp(ji,jj,2) - fsp(ji,jj,1) ) / & + & ( xsp(ji,jj,2) - xsp(ji,jj,1) ) - 0.5_wp * zdf(2) + zdf(jpkm1) = 1.5_wp * ( fsp(ji,jj,jpkm1) - fsp(ji,jj,jpkm1-1) ) / & + & ( xsp(ji,jj,jpkm1) - xsp(ji,jj,jpkm1-1) ) - 0.5_wp * zdf(jpk - 2) + + DO jk = 1, jpk-2 + zdxtmp = xsp(ji,jj,jk+1) - xsp(ji,jj,jk) + ztmp1 = (zdf(jk+1) + 2._wp * zdf(jk)) / zdxtmp + ztmp2 = 6._wp * (fsp(ji,jj,jk+1) - fsp(ji,jj,jk)) / zdxtmp / zdxtmp + zddf1 = -2._wp * ztmp1 + ztmp2 + ztmp1 = (2._wp * zdf(jk+1) + zdf(jk)) / zdxtmp + zddf2 = 2._wp * ztmp1 - ztmp2 + + dsp(ji,jj,jk) = (zddf2 - zddf1) / 6._wp / zdxtmp + csp(ji,jj,jk) = ( xsp(ji,jj,jk+1) * zddf1 - xsp(ji,jj,jk)*zddf2 ) / 2._wp / zdxtmp + bsp(ji,jj,jk) = ( fsp(ji,jj,jk+1) - fsp(ji,jj,jk) ) / zdxtmp - & + & csp(ji,jj,jk) * ( xsp(ji,jj,jk+1) + xsp(ji,jj,jk) ) - & + & dsp(ji,jj,jk) * ((xsp(ji,jj,jk+1) + xsp(ji,jj,jk))**2 - & + & xsp(ji,jj,jk+1) * xsp(ji,jj,jk)) + asp(ji,jj,jk) = fsp(ji,jj,jk) - xsp(ji,jj,jk) * (bsp(ji,jj,jk) + & + & (xsp(ji,jj,jk) * (csp(ji,jj,jk) + & + & dsp(ji,jj,jk) * xsp(ji,jj,jk)))) + END DO + END DO ; END DO + + ELSEIF ( polynomial_type == 2 ) THEN ! Linear + DO jk = 1, jpk-2 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + zdxtmp =xsp(ji,jj,jk+1) - xsp(ji,jj,jk) + ztmp1 = fsp(ji,jj,jk+1) - fsp(ji,jj,jk) + + dsp(ji,jj,jk) = 0._wp + csp(ji,jj,jk) = 0._wp + bsp(ji,jj,jk) = ztmp1 / zdxtmp + asp(ji,jj,jk) = fsp(ji,jj,jk) - bsp(ji,jj,jk) * xsp(ji,jj,jk) + END DO ; END DO ; END DO + ! + ELSE + CALL ctl_stop( 'invalid polynomial type in cspline' ) + ENDIF + ! + END SUBROUTINE cspline + + + FUNCTION interp1(x, xl, xr, fl, fr) RESULT(f) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp1 *** + !! + !! ** Purpose : 1-d linear interpolation + !! + !! ** Method : interpolation is straight forward + !! extrapolation is also permitted (no value limit) + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: fl, fr + REAL(dp), INTENT(in) :: x, xl, xr + REAL(wp) :: f ! result of the interpolation (extrapolation) + REAL(wp) :: zdeltx + !!---------------------------------------------------------------------- + ! + zdeltx = xr - xl + IF( abs(zdeltx) <= 10._wp * EPSILON(x) ) THEN + f = 0.5_wp * (fl + fr) + ELSE + f = ( (x - xl ) * fr - ( x - xr ) * fl ) / zdeltx + ENDIF + ! + END FUNCTION interp1 + + + FUNCTION interp2( x, a, b, c, d ) RESULT(f) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp1 *** + !! + !! ** Purpose : 1-d constrained cubic spline interpolation + !! + !! ** Method : cubic spline interpolation + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: x, a, b, c, d + REAL(wp) :: f ! value from the interpolation + !!---------------------------------------------------------------------- + ! + f = a + x* ( b + x * ( c + d * x ) ) + ! + END FUNCTION interp2 + + + FUNCTION interp3( x, a, b, c, d ) RESULT(f) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp1 *** + !! + !! ** Purpose : Calculate the first order of derivative of + !! a cubic spline function y=a+b*x+c*x^2+d*x^3 + !! + !! ** Method : f=dy/dx=b+2*c*x+3*d*x^2 + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: x, a, b, c, d + REAL(wp) :: f ! value from the interpolation + !!---------------------------------------------------------------------- + ! + f = b + x * ( 2._wp * c + 3._wp * d * x) + ! + END FUNCTION interp3 + + + FUNCTION integ_spline( xl, xr, a, b, c, d ) RESULT(f) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp1 *** + !! + !! ** Purpose : 1-d constrained cubic spline integration + !! + !! ** Method : integrate polynomial a+bx+cx^2+dx^3 from xl to xr + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: xl, xr, a, b, c, d + REAL(wp) :: za1, za2, za3 + REAL(wp) :: f ! integration result + !!---------------------------------------------------------------------- + ! + za1 = 0.5_wp * b + za2 = c / 3.0_wp + za3 = 0.25_wp * d + ! + f = xr * ( a + xr * ( za1 + xr * ( za2 + za3 * xr ) ) ) - & + & xl * ( a + xl * ( za1 + xl * ( za2 + za3 * xl ) ) ) + ! + END FUNCTION integ_spline + + !!====================================================================== +END MODULE dynhpg diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynkeg.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynkeg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..94035ba6bda7fde1f3041e2cad7df5dd1041f7e8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynkeg.f90 @@ -0,0 +1,169 @@ + + + + + + + + + + + + + +MODULE dynkeg + !!====================================================================== + !! *** MODULE dynkeg *** + !! Ocean dynamics: kinetic energy gradient trend + !!====================================================================== + !! History : 1.0 ! 1987-09 (P. Andrich, M.-A. Foujols) Original code + !! 7.0 ! 1997-05 (G. Madec) Split dynber into dynkeg and dynhpg + !! NEMO 1.0 ! 2002-07 (G. Madec) F90: Free form and module + !! 3.6 ! 2015-05 (N. Ducousso, G. Madec) add Hollingsworth scheme as an option + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_keg : update the momentum trend with the horizontal tke + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + USE bdy_oce ! ocean open boundary conditions + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_keg ! routine called by step module + + INTEGER, PARAMETER, PUBLIC :: nkeg_C2 = 0 !: 2nd order centered scheme (standard scheme) + INTEGER, PARAMETER, PUBLIC :: nkeg_HW = 1 !: Hollingsworth et al., QJRMS, 1983 + ! + REAL(wp) :: r1_48 = 1._wp / 48._wp !: =1/(4*2*6) + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynkeg.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_keg( kt, kscheme, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_keg *** + !! + !! ** Purpose : Compute the now momentum trend due to the horizontal + !! gradient of the horizontal kinetic energy and add it to the + !! general momentum trend. + !! + !! ** Method : * kscheme = nkeg_C2 : 2nd order centered scheme that + !! conserve kinetic energy. Compute the now horizontal kinetic energy + !! zhke = 1/2 [ mi-1( un^2 ) + mj-1( vn^2 ) ] + !! * kscheme = nkeg_HW : Hollingsworth correction following + !! Arakawa (2001). The now horizontal kinetic energy is given by: + !! zhke = 1/6 [ mi-1( 2 * un^2 + ((u(j+1)+u(j-1))/2)^2 ) + !! + mj-1( 2 * vn^2 + ((v(i+1)+v(i-1))/2)^2 ) ] + !! + !! Take its horizontal gradient and add it to the general momentum + !! trend. + !! u(rhs) = u(rhs) - 1/e1u di[ zhke ] + !! v(rhs) = v(rhs) - 1/e2v dj[ zhke ] + !! + !! ** Action : - Update the (puu(:,:,:,Krhs), pvv(:,:,:,Krhs)) with the hor. ke gradient trend + !! - send this trends to trd_dyn (l_trddyn=T) for post-processing + !! + !! ** References : Arakawa, A., International Geophysics 2001. + !! Hollingsworth et al., Quart. J. Roy. Meteor. Soc., 1983. + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: kscheme ! =0/1 type of KEG scheme + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zu, zv ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zhke + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_keg') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_keg : kinetic energy gradient trend, scheme number=', kscheme + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + ENDIF + + IF( l_trddyn ) THEN ! Save the input trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + + zhke(:,:,jpk) = 0._wp + + SELECT CASE ( kscheme ) !== Horizontal kinetic energy at T-point ==! + ! + CASE ( nkeg_C2 ) !-- Standard scheme --! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 1) ; DO ji = ntsi-( 0), ntei+( 1) + zu = puu(ji-1,jj ,jk,Kmm) * puu(ji-1,jj ,jk,Kmm) & + & + puu(ji ,jj ,jk,Kmm) * puu(ji ,jj ,jk,Kmm) + zv = pvv(ji ,jj-1,jk,Kmm) * pvv(ji ,jj-1,jk,Kmm) & + & + pvv(ji ,jj ,jk,Kmm) * pvv(ji ,jj ,jk,Kmm) + zhke(ji,jj,jk) = 0.25_wp * ( zv + zu ) + END DO ; END DO ; END DO + CASE ( nkeg_HW ) !-- Hollingsworth scheme --! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( nn_hls-1) ; DO ji = ntsi-( 0), ntei+( nn_hls-1) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zu = 8._wp * ( puu(ji-1,jj ,jk,Kmm) * puu(ji-1,jj ,jk,Kmm) & + & + puu(ji ,jj ,jk,Kmm) * puu(ji ,jj ,jk,Kmm) ) & + & + ( ( puu(ji-1,jj-1,jk,Kmm) + puu(ji-1,jj+1,jk,Kmm) ) * ( puu(ji-1,jj-1,jk,Kmm) + puu(ji-1,jj+1,jk,Kmm) ) & + & + ( puu(ji ,jj-1,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) * ( puu(ji ,jj-1,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) & + & ) ! bracket for halo 1 - halo 2 compatibility + ! + zv = 8._wp * ( pvv(ji ,jj-1,jk,Kmm) * pvv(ji ,jj-1,jk,Kmm) & + & + pvv(ji ,jj ,jk,Kmm) * pvv(ji ,jj ,jk,Kmm) ) & + & + ( ( pvv(ji-1,jj-1,jk,Kmm) + pvv(ji+1,jj-1,jk,Kmm) ) * ( pvv(ji-1,jj-1,jk,Kmm) + pvv(ji+1,jj-1,jk,Kmm) ) & + & + ( pvv(ji-1,jj ,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) ) * ( pvv(ji-1,jj ,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) ) & + & ) ! bracket for halo 1 - halo 2 compatibility + zhke(ji,jj,jk) = r1_48 * ( zv + zu ) + END DO ; END DO ; END DO + IF (nn_hls==1) CALL lbc_lnk( 'dynkeg', zhke, 'T', 1.0_wp ) + ! + END SELECT + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !== grad( KE ) added to the general momentum trends ==! + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zhke(ji+1,jj ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zhke(ji ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj) + END DO ; END DO ; END DO + ! + IF( l_trddyn ) THEN ! save the Kinetic Energy trends for diagnostic + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt, Kmm ) + DEALLOCATE( ztrdu , ztrdv ) + ENDIF + ! + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' keg - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_keg') + ! + END SUBROUTINE dyn_keg + + !!====================================================================== +END MODULE dynkeg diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynldf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynldf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f11cb3457bfb18815b216fcc25872659569c3801 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynldf.f90 @@ -0,0 +1,129 @@ + + + + + + + + + + + + + +MODULE dynldf + !!====================================================================== + !! *** MODULE dynldf *** + !! Ocean physics: lateral diffusivity trends + !!===================================================================== + !! History : 2.0 ! 2005-11 (G. Madec) Original code (new step architecture) + !! 3.7 ! 2014-01 (F. Lemarie, G. Madec) restructuration/simplification of ahm specification, + !! ! add velocity dependent coefficient and optional read in file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_ldf : update the dynamics trend with the lateral diffusion + !! dyn_ldf_init : initialization, namelist read, and parameters control + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ldfdyn ! lateral diffusion: eddy viscosity coef. + USE dynldf_lap_blp ! lateral mixing (dyn_ldf_lap & dyn_ldf_blp routines) + USE dynldf_iso ! lateral mixing (dyn_ldf_iso routine ) + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics (trd_dyn routine) + ! + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_ldf ! called by step module + PUBLIC dyn_ldf_init ! called by opa module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynldf.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_ldf( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf *** + !! + !! ** Purpose : compute the lateral ocean dynamics physics. + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_ldf') + ! + IF( l_trddyn ) THEN ! temporary save of momentum trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + + SELECT CASE ( nldf_dyn ) ! compute lateral mixing trend and add it to the general trend + ! + CASE ( np_lap ) + CALL dyn_ldf_lap( kt, Kbb, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs), 1 ) ! iso-level laplacian + CASE ( np_lap_i ) + CALL dyn_ldf_iso( kt, Kbb, Kmm, puu, pvv, Krhs ) ! rotated laplacian + CASE ( np_blp ) + CALL dyn_ldf_blp( kt, Kbb, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! iso-level bi-laplacian + ! + END SELECT + + IF( l_trddyn ) THEN ! save the horizontal diffusive trends for further diagnostics + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_ldf, kt, Kmm ) + DEALLOCATE ( ztrdu , ztrdv ) + ENDIF + ! ! print sum trends (used for debugging) + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ldf - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_ldf') + ! + END SUBROUTINE dyn_ldf + + + SUBROUTINE dyn_ldf_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_init *** + !! + !! ** Purpose : initializations of the horizontal ocean dynamics physics + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN !== Namelist print ==! + WRITE(numout,*) + WRITE(numout,*) 'dyn_ldf_init : Choice of the lateral diffusive operator on dynamics' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namdyn_ldf: already read in ldfdyn module' + WRITE(numout,*) ' see ldf_dyn_init report for lateral mixing parameters' + WRITE(numout,*) + ! + SELECT CASE( nldf_dyn ) ! print the choice of operator + CASE( np_no_ldf ) ; WRITE(numout,*) ' ==>>> NO lateral viscosity' + CASE( np_lap ) ; WRITE(numout,*) ' ==>>> iso-level laplacian operator' + CASE( np_lap_i ) ; WRITE(numout,*) ' ==>>> rotated laplacian operator with iso-level background' + CASE( np_blp ) ; WRITE(numout,*) ' ==>>> iso-level bi-laplacian operator' + END SELECT + ENDIF + ! + END SUBROUTINE dyn_ldf_init + + !!====================================================================== +END MODULE dynldf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynldf_iso.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynldf_iso.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f9a9955bd9e57a87b2ef2c236040ab5c1b0e53de --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynldf_iso.f90 @@ -0,0 +1,444 @@ + + + + + + + + + + + + + +MODULE dynldf_iso + !!====================================================================== + !! *** MODULE dynldf_iso *** + !! Ocean dynamics: lateral viscosity trend (rotated laplacian operator) + !!====================================================================== + !! History : OPA ! 97-07 (G. Madec) Original code + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2004-08 (C. Talandier) New trends organization + !! 2.0 ! 2005-11 (G. Madec) s-coordinate: horizontal diffusion + !! 3.7 ! 2014-01 (F. Lemarie, G. Madec) restructuration/simplification of ahm specification, + !! ! add velocity dependent coefficient and optional read in file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_ldf_iso : update the momentum trend with the horizontal part + !! of the lateral diffusion using isopycnal or horizon- + !! tal s-coordinate laplacian operator. + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE ldfdyn ! lateral diffusion: eddy viscosity coef. + USE ldftra ! lateral physics: eddy diffusivity + USE zdf_oce ! ocean vertical physics + USE ldfslp ! iso-neutral slopes + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_ldf_iso ! called by step.F90 + PUBLIC dyn_ldf_iso_alloc ! called by nemogcm.F90 + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akzu, akzv !: vertical component of rotated lateral viscosity + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynldf_iso.F90 15094 2021-07-06 16:24:19Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION dyn_ldf_iso_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_iso_alloc *** + !!---------------------------------------------------------------------- + dyn_ldf_iso_alloc = 0 + IF( .NOT. ALLOCATED( akzu ) ) THEN + ALLOCATE( akzu(jpi,jpj,jpk), akzv(jpi,jpj,jpk), STAT=dyn_ldf_iso_alloc ) + ! + IF( dyn_ldf_iso_alloc /= 0 ) CALL ctl_warn('dyn_ldf_iso_alloc: array allocate failed.') + ENDIF + END FUNCTION dyn_ldf_iso_alloc + + + SUBROUTINE dyn_ldf_iso( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_iso *** + !! + !! ** Purpose : Compute the before trend of the rotated laplacian + !! operator of lateral momentum diffusion except the diagonal + !! vertical term that will be computed in dynzdf module. Add it + !! to the general trend of momentum equation. + !! + !! ** Method : + !! The momentum lateral diffusive trend is provided by a 2nd + !! order operator rotated along neutral or geopotential surfaces + !! (in s-coordinates). + !! It is computed using before fields (forward in time) and isopyc- + !! nal or geopotential slopes computed in routine ldfslp. + !! Here, u and v components are considered as 2 independent scalar + !! fields. Therefore, the property of splitting divergent and rota- + !! tional part of the flow of the standard, z-coordinate laplacian + !! momentum diffusion is lost. + !! horizontal fluxes associated with the rotated lateral mixing: + !! u-component: + !! ziut = ( ahmt + rn_ahm_b ) e2t * e3t / e1t di[ uu ] + !! - ahmt e2t * mi-1(uslp) dk[ mi(mk(uu)) ] + !! zjuf = ( ahmf + rn_ahm_b ) e1f * e3f / e2f dj[ uu ] + !! - ahmf e1f * mi(vslp) dk[ mj(mk(uu)) ] + !! v-component: + !! zivf = ( ahmf + rn_ahm_b ) e2t * e3t / e1t di[ vv ] + !! - ahmf e2t * mj(uslp) dk[ mi(mk(vv)) ] + !! zjvt = ( ahmt + rn_ahm_b ) e1f * e3f / e2f dj[ vv ] + !! - ahmt e1f * mj-1(vslp) dk[ mj(mk(vv)) ] + !! take the horizontal divergence of the fluxes: + !! diffu = 1/(e1u*e2u*e3u) { di [ ziut ] + dj-1[ zjuf ] } + !! diffv = 1/(e1v*e2v*e3v) { di-1[ zivf ] + dj [ zjvt ] } + !! Add this trend to the general trend (uu(rhs),vv(rhs)): + !! uu(rhs) = uu(rhs) + diffu + !! CAUTION: here the isopycnal part is with a coeff. of aht. This + !! should be modified for applications others than orca_r2 (!!bug) + !! + !! ** Action : + !! -(puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) updated with the before geopotential harmonic mixing trend + !! -(akzu,akzv) to accompt for the diagonal vertical component + !! of the rotated operator in dynzdf module + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zabe1, zmskt, zmkt, zuav, zuwslpi, zuwslpj ! local scalars + REAL(wp) :: zabe2, zmskf, zmkf, zvav, zvwslpi, zvwslpj ! - - + REAL(wp) :: zcof0, zcof1, zcof2, zcof3, zcof4, zaht_0 ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: ziut, zivf, zdku, zdk1u ! 2D workspace + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zjuf, zjvt, zdkv, zdk1v ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),jpk) :: zfuw, zdiu, zdju, zdj1u ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),jpk) :: zfvw, zdiv, zdjv, zdj1v ! - - + !!---------------------------------------------------------------------- + ! + + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_ldf_iso : iso-neutral laplacian diffusive operator or ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ s-coordinate horizontal diffusive operator' + ! ! allocate dyn_ldf_iso arrays + IF( dyn_ldf_iso_alloc() /= 0 ) CALL ctl_stop('STOP', 'dyn_ldf_iso: failed to allocate arrays') + ! + DO jj = ntsj-( 0-( 0+ 0 )*nthb), ntej+( 0 -( 0 + 0)*ntht) ; DO ji = ntsi-( 0-( 0+ 0)*nthl), ntei+( 0-( 0+ 0)*nthr) + akzu(ji,jj,1) = 0._wp + akzu(ji,jj,jpk) = 0._wp + akzv(ji,jj,1) = 0._wp + akzv(ji,jj,jpk) = 0._wp + END DO ; END DO + ! + ENDIF + ENDIF + +!!gm bug is dyn_ldf_iso called before tra_ldf_iso .... <<<<<===== TO BE CHECKED + ! s-coordinate: Iso-level diffusion on momentum but not on tracer + IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN + ! + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! set the slopes of iso-level + uslp (ji,jj,jk) = - ( (gdept_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kbb))) - (gdept_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kbb))) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) + vslp (ji,jj,jk) = - ( (gdept_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kbb))) - (gdept_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kbb))) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) + wslpi(ji,jj,jk) = - ( (gdepw_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kbb))) - (gdepw_0(ji-1,jj,jk)*(1._wp+r3t(ji-1,jj,Kbb))) ) * r1_e1t(ji,jj) * tmask(ji,jj,jk) * 0.5 + wslpj(ji,jj,jk) = - ( (gdepw_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kbb))) - (gdepw_0(ji,jj-1,jk)*(1._wp+r3t(ji,jj-1,Kbb))) ) * r1_e2t(ji,jj) * tmask(ji,jj,jk) * 0.5 + END DO ; END DO ; END DO + ! Lateral boundary conditions on the slopes + IF (nn_hls == 1) CALL lbc_lnk( 'dynldf_iso', uslp , 'U', -1.0_wp, vslp , 'V', -1.0_wp, wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) + ! + ENDIF + + zaht_0 = 0.5_wp * rn_Ud * rn_Ld ! aht_0 from namtra_ldf = zaht_max + + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + + ! Vertical u- and v-shears at level jk and jk+1 + ! --------------------------------------------- + ! surface boundary condition: zdku(jk=1)=zdku(jk=2) + ! zdkv(jk=1)=zdkv(jk=2) + + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zdk1u(ji,jj) = ( puu(ji,jj,jk,Kbb) -puu(ji,jj,jk+1,Kbb) ) * umask(ji,jj,jk+1) + zdk1v(ji,jj) = ( pvv(ji,jj,jk,Kbb) -pvv(ji,jj,jk+1,Kbb) ) * vmask(ji,jj,jk+1) + END DO ; END DO + + IF( jk == 1 ) THEN + zdku(:,:) = zdk1u(:,:) + zdkv(:,:) = zdk1v(:,:) + ELSE + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zdku(ji,jj) = ( puu(ji,jj,jk-1,Kbb) - puu(ji,jj,jk,Kbb) ) * umask(ji,jj,jk) + zdkv(ji,jj) = ( pvv(ji,jj,jk-1,Kbb) - pvv(ji,jj,jk,Kbb) ) * vmask(ji,jj,jk) + END DO ; END DO + ENDIF + + ! -----f----- + ! Horizontal fluxes on U | + ! --------------------=== t u t + ! | + ! i-flux at t-point -----f----- + + IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 1) + zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) & + & * MIN( (e3u_0(ji ,jj,jk)*(1._wp+r3u(ji ,jj,Kmm)*umask(ji ,jj,jk))), & + & (e3u_0(ji-1,jj,jk)*(1._wp+r3u(ji-1,jj,Kmm)*umask(ji-1,jj,jk))) ) * r1_e1t(ji,jj) + + zmskt = 1._wp / MAX( umask(ji-1,jj,jk )+umask(ji,jj,jk+1) & + & + umask(ji-1,jj,jk+1)+umask(ji,jj,jk ) , 1._wp ) + + zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5 * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) ) + + ziut(ji,jj) = ( zabe1 * ( puu(ji,jj,jk,Kbb) - puu(ji-1,jj,jk,Kbb) ) & + & + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj) & + & +zdk1u(ji,jj) + zdku (ji-1,jj) ) ) * tmask(ji,jj,jk) + END DO ; END DO + ELSE ! other coordinate system (zco or sco) : e3t + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 1) + zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) & + & * e2t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * r1_e1t(ji,jj) + + zmskt = 1._wp / MAX( umask(ji-1,jj,jk ) + umask(ji,jj,jk+1) & + & + umask(ji-1,jj,jk+1) + umask(ji,jj,jk ) , 1._wp ) + + zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5 * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) ) + + ziut(ji,jj) = ( zabe1 * ( puu(ji,jj,jk,Kbb) - puu(ji-1,jj,jk,Kbb) ) & + & + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj) & + & +zdk1u(ji,jj) + zdku (ji-1,jj) ) ) * tmask(ji,jj,jk) + END DO ; END DO + ENDIF + + ! j-flux at f-point + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b ) & + & * e1f(ji,jj) * (e3f_0(ji,jj,jk)*(1._wp+r3f(ji,jj)*fe3mask(ji,jj,jk))) * r1_e2f(ji,jj) + + zmskf = 1._wp / MAX( umask(ji,jj+1,jk )+umask(ji,jj,jk+1) & + & + umask(ji,jj+1,jk+1)+umask(ji,jj,jk ) , 1._wp ) + + zcof2 = - zaht_0 * e1f(ji,jj) * zmskf * 0.5 * ( vslp(ji+1,jj,jk) + vslp(ji,jj,jk) ) + + zjuf(ji,jj) = ( zabe2 * ( puu(ji,jj+1,jk,Kbb) - puu(ji,jj,jk,Kbb) ) & + & + zcof2 * ( zdku (ji,jj+1) + zdk1u(ji,jj) & + & +zdk1u(ji,jj+1) + zdku (ji,jj) ) ) * fmask(ji,jj,jk) + END DO ; END DO + + ! | t | + ! Horizontal fluxes on V | | + ! --------------------=== f---v---f + ! | | + ! i-flux at f-point | t | + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b ) & + & * e2f(ji,jj) * (e3f_0(ji,jj,jk)*(1._wp+r3f(ji,jj)*fe3mask(ji,jj,jk))) * r1_e1f(ji,jj) + + zmskf = 1._wp / MAX( vmask(ji+1,jj,jk )+vmask(ji,jj,jk+1) & + & + vmask(ji+1,jj,jk+1)+vmask(ji,jj,jk ) , 1._wp ) + + zcof1 = - zaht_0 * e2f(ji,jj) * zmskf * 0.5 * ( uslp(ji,jj+1,jk) + uslp(ji,jj,jk) ) + + zivf(ji,jj) = ( zabe1 * ( pvv(ji+1,jj,jk,Kbb) - pvv(ji,jj,jk,Kbb) ) & + & + zcof1 * ( zdkv (ji,jj) + zdk1v(ji+1,jj) & + & + zdk1v(ji,jj) + zdkv (ji+1,jj) ) ) * fmask(ji,jj,jk) + END DO ; END DO + + ! j-flux at t-point + IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u) + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 0) + zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) & + & * MIN( (e3v_0(ji,jj ,jk)*(1._wp+r3v(ji,jj ,Kmm)*vmask(ji,jj ,jk))), & + & (e3v_0(ji,jj-1,jk)*(1._wp+r3v(ji,jj-1,Kmm)*vmask(ji,jj-1,jk))) ) * r1_e2t(ji,jj) + + zmskt = 1._wp / MAX( vmask(ji,jj-1,jk )+vmask(ji,jj,jk+1) & + & + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk ) , 1._wp ) + + zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) ) + + zjvt(ji,jj) = ( zabe2 * ( pvv(ji,jj,jk,Kbb) - pvv(ji,jj-1,jk,Kbb) ) & + & + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj) & + & +zdk1v(ji,jj-1) + zdkv (ji,jj) ) ) * tmask(ji,jj,jk) + END DO ; END DO + ELSE ! other coordinate system (zco or sco) : e3t + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 0) + zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) & + & * e1t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * r1_e2t(ji,jj) + + zmskt = 1./MAX( vmask(ji,jj-1,jk )+vmask(ji,jj,jk+1) & + & + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk ), 1. ) + + zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) ) + + zjvt(ji,jj) = ( zabe2 * ( pvv(ji,jj,jk,Kbb) - pvv(ji,jj-1,jk,Kbb) ) & + & + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj) & + & +zdk1v(ji,jj-1) + zdkv (ji,jj) ) ) * tmask(ji,jj,jk) + END DO ; END DO + ENDIF + + + ! Second derivative (divergence) and add to the general trend + ! ----------------------------------------------------------- + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !!gm Question vectop possible??? !!bug + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( ziut(ji+1,jj) - ziut(ji,jj ) & + & + zjuf(ji ,jj) - zjuf(ji,jj-1) ) * r1_e1e2u(ji,jj) & + & / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zivf(ji,jj ) - zivf(ji-1,jj) & + & + zjvt(ji,jj+1) - zjvt(ji,jj ) ) * r1_e1e2v(ji,jj) & + & / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + END DO ; END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + + ! print sum trends (used for debugging) + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ldfh - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + + + ! ! =============== + DO jj = ntsj, ntej ! Vertical slab + ! ! =============== + + + ! I. vertical trends associated with the lateral mixing + ! ===================================================== + ! (excluding the vertical flux proportional to dk[t] + + + ! I.1 horizontal momentum gradient + ! -------------------------------- + + DO jk = 1, jpk + DO ji = ntsi, ntei + nn_hls + ! i-gradient of u at jj + zdiu (ji,jk) = tmask(ji,jj ,jk) * ( puu(ji,jj ,jk,Kbb) - puu(ji-1,jj ,jk,Kbb) ) + ! j-gradient of u and v at jj + zdju (ji,jk) = fmask(ji,jj ,jk) * ( puu(ji,jj+1,jk,Kbb) - puu(ji ,jj ,jk,Kbb) ) + zdjv (ji,jk) = tmask(ji,jj ,jk) * ( pvv(ji,jj ,jk,Kbb) - pvv(ji ,jj-1,jk,Kbb) ) + ! j-gradient of u and v at jj+1 + zdj1u(ji,jk) = fmask(ji,jj-1,jk) * ( puu(ji,jj ,jk,Kbb) - puu(ji ,jj-1,jk,Kbb) ) + zdj1v(ji,jk) = tmask(ji,jj+1,jk) * ( pvv(ji,jj+1,jk,Kbb) - pvv(ji ,jj ,jk,Kbb) ) + END DO + END DO + DO jk = 1, jpk + DO ji = ntsi - nn_hls, ntei + ! i-gradient of v at jj + zdiv (ji,jk) = fmask(ji,jj ,jk) * ( pvv(ji+1,jj,jk,Kbb) - pvv(ji ,jj ,jk,Kbb) ) + END DO + END DO + + + ! I.2 Vertical fluxes + ! ------------------- + + ! Surface and bottom vertical fluxes set to zero + DO ji = ntsi - nn_hls, ntei + nn_hls + zfuw(ji, 1 ) = 0.e0 + zfvw(ji, 1 ) = 0.e0 + zfuw(ji,jpk) = 0.e0 + zfvw(ji,jpk) = 0.e0 + END DO + + ! interior (2=0) + ENDIF + ! + SELECT CASE( nn_dynldf_typ ) + ! + CASE ( np_typ_rot ) !== Vorticity-Divergence operator ==! + ! + ALLOCATE( zcur(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) , zdiv(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) ) + ! + DO jk = 1, jpkm1 ! Horizontal slab + ! + DO jj = ntsj-( iij-1), ntej+( iij ) ; DO ji = ntsi-( iij-1), ntei+( iij) + ! ! ahm * e3 * curl (warning: computed for ji-1,jj-1) + zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * (e3f_0(ji-1,jj-1,jk)*(1._wp+r3f(ji-1,jj-1)*fe3mask(ji-1,jj-1,jk))) * r1_e1e2f(ji-1,jj-1) & ! ahmf already * by fmask + & * ( e2v(ji ,jj-1) * pv(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk) & + & - e1u(ji-1,jj ) * pu(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk) ) + ! ! ahm * div (warning: computed for ji,jj) + zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kbb)*tmask(ji,jj,jk))) & ! ahmt already * by tmask + & * ( e2u(ji,jj)*(e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kbb)*umask(ji,jj,jk))) * pu(ji,jj,jk) - e2u(ji-1,jj)*(e3u_0(ji-1,jj,jk)*(1._wp+r3u(ji-1,jj,Kbb)*umask(ji-1,jj,jk))) * pu(ji-1,jj,jk) & + & + e1v(ji,jj)*(e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kbb)*vmask(ji,jj,jk))) * pv(ji,jj,jk) - e1v(ji,jj-1)*(e3v_0(ji,jj-1,jk)*(1._wp+r3v(ji,jj-1,Kbb)*vmask(ji,jj-1,jk))) * pv(ji,jj-1,jk) ) + END DO ; END DO + ! + DO jj = ntsj-( iij-1), ntej+( iij-1 ) ; DO ji = ntsi-( iij-1), ntei+( iij-1) ! - curl( curl) + grad( div ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use + & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) & + & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) ) + ! + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * vmask(ji,jj,jk) * ( & ! * by vmask is mandatory for dyn_ldf_blp use + & ( zcur(ji,jj ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) & + & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) ) + END DO ; END DO + ! + END DO ! End of slab + ! + DEALLOCATE( zcur , zdiv ) + ! + CASE ( np_typ_sym ) !== Symmetric operator ==! + ! + ALLOCATE( zten(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) , zshe(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) ) + ! + DO jk = 1, jpkm1 ! Horizontal slab + ! + DO jj = ntsj-( iij-1), ntej+( iij ) ; DO ji = ntsi-( iij-1), ntei+( iij) + ! ! shearing stress component (F-point) NB : ahmf has already been multiplied by fmask + zshe(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) & + & * ( e1f(ji-1,jj-1) * r1_e2f(ji-1,jj-1) & + & * ( pu(ji-1,jj ,jk) * r1_e1u(ji-1,jj ) - pu(ji-1,jj-1,jk) * r1_e1u(ji-1,jj-1) ) & + & + e2f(ji-1,jj-1) * r1_e1f(ji-1,jj-1) & + & * ( pv(ji ,jj-1,jk) * r1_e2v(ji ,jj-1) - pv(ji-1,jj-1,jk) * r1_e2v(ji-1,jj-1) ) ) + ! ! tension stress component (T-point) NB : ahmt has already been multiplied by tmask + zten(ji,jj) = ahmt(ji,jj,jk) & + & * ( e2t(ji,jj) * r1_e1t(ji,jj) & + & * ( pu(ji,jj,jk) * r1_e2u(ji,jj) - pu(ji-1,jj,jk) * r1_e2u(ji-1,jj) ) & + & - e1t(ji,jj) * r1_e2t(ji,jj) & + & * ( pv(ji,jj,jk) * r1_e1v(ji,jj) - pv(ji,jj-1,jk) * r1_e1v(ji,jj-1) ) ) + END DO ; END DO + ! + DO jj = ntsj-( iij-1), ntej+( iij-1 ) ; DO ji = ntsi-( iij-1), ntei+( iij-1) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * r1_e1e2u(ji,jj) / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) & + & * ( ( zten(ji+1,jj ) * e2t(ji+1,jj )*e2t(ji+1,jj ) * (e3t_0(ji+1,jj ,jk)*(1._wp+r3t(ji+1,jj ,Kmm)*tmask(ji+1,jj ,jk))) & + & - zten(ji ,jj ) * e2t(ji ,jj )*e2t(ji ,jj ) * (e3t_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kmm)*tmask(ji ,jj ,jk))) ) * r1_e2u(ji,jj) & + & + ( zshe(ji ,jj ) * e1f(ji ,jj )*e1f(ji ,jj ) * (e3f_0(ji ,jj ,jk)*(1._wp+r3f(ji ,jj )*fe3mask(ji ,jj ,jk))) & + & - zshe(ji ,jj-1) * e1f(ji ,jj-1)*e1f(ji ,jj-1) * (e3f_0(ji ,jj-1,jk)*(1._wp+r3f(ji ,jj-1)*fe3mask(ji ,jj-1,jk))) ) * r1_e1u(ji,jj) ) + ! + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * r1_e1e2v(ji,jj) / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) & + & * ( ( zshe(ji ,jj ) * e2f(ji ,jj )*e2f(ji ,jj ) * (e3f_0(ji ,jj ,jk)*(1._wp+r3f(ji ,jj )*fe3mask(ji ,jj ,jk))) & + & - zshe(ji-1,jj ) * e2f(ji-1,jj )*e2f(ji-1,jj ) * (e3f_0(ji-1,jj ,jk)*(1._wp+r3f(ji-1,jj )*fe3mask(ji-1,jj ,jk))) ) * r1_e2v(ji,jj) & + & - ( zten(ji ,jj+1) * e1t(ji ,jj+1)*e1t(ji ,jj+1) * (e3t_0(ji ,jj+1,jk)*(1._wp+r3t(ji ,jj+1,Kmm)*tmask(ji ,jj+1,jk))) & + & - zten(ji ,jj ) * e1t(ji ,jj )*e1t(ji ,jj ) * (e3t_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kmm)*tmask(ji ,jj ,jk))) ) * r1_e1v(ji,jj) ) + ! + END DO ; END DO + ! + END DO + ! + DEALLOCATE( zten , zshe ) + ! + END SELECT + ! + END SUBROUTINE dyn_ldf_lap_t + + + SUBROUTINE dyn_ldf_blp( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_blp *** + !! + !! ** Purpose : Compute the before lateral momentum viscous trend + !! and add it to the general trend of momentum equation. + !! + !! ** Method : The lateral viscous trends is provided by a bilaplacian + !! operator applied to before field (forward in time). + !! It is computed by two successive calls to dyn_ldf_lap routine + !! + !! ** Action : pt(:,:,:,:,Krhs) updated with the before rotated bilaplacian diffusion + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu, pv ! before velocity fields + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! momentum trend + ! + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zulap, zvlap ! laplacian at u- and v-point + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_ldf_blp : bilaplacian operator momentum ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + zulap(:,:,:) = 0._wp + zvlap(:,:,:) = 0._wp + ! + CALL dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 ) ! rotated laplacian applied to pt (output in zlap,Kbb) + ! + IF (nn_hls==1) CALL lbc_lnk( 'dynldf_lap_blp', zulap, 'U', -1.0_dp, zvlap, 'V', -1.0_dp ) ! Lateral boundary conditions + ! + CALL dyn_ldf_lap( kt, Kbb, Kmm, zulap, zvlap, pu_rhs, pv_rhs, 2 ) ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs)) + ! + END SUBROUTINE dyn_ldf_blp + + !!====================================================================== +END MODULE dynldf_lap_blp diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynldf_lap_blp_lf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynldf_lap_blp_lf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d1981633a0f71b28b463286f2b7326e1b470cc19 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynldf_lap_blp_lf.f90 @@ -0,0 +1,253 @@ + + + + + + + + + + + + + +MODULE dynldf_lap_blp_lf + !!====================================================================== + !! *** MODULE dynldf_lap_blp *** + !! Ocean dynamics: lateral viscosity trend (laplacian and bilaplacian) + !!====================================================================== + !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian + !! 4.0 ! 2020-04 (A. Nasser, G. Madec) Add symmetric mixing tensor + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_ldf_lap : update the momentum trend with the lateral viscosity using an iso-level laplacian operator + !! dyn_ldf_blp : update the momentum trend with the lateral viscosity using an iso-level bilaplacian operator + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE domutl, ONLY : is_tile + USE ldfdyn ! lateral diffusion: eddy viscosity coef. + USE ldfslp ! iso-neutral slopes + USE zdf_oce ! ocean vertical physics + ! + USE in_out_manager ! I/O manager + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_ldf_lap_lf ! called by dynldf.F90 + PUBLIC dyn_ldf_blp_lf ! called by dynldf.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynldf_lap_blp.F90 14757 2021-04-27 15:33:44Z francesca $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_ldf_lap_lf( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs, kpass ) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pu, pv ! before velocity [m/s] + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2] + !! + CALL dyn_ldf_lap_lf_t( kt, Kbb, Kmm, pu, pv, is_tile(pu), pu_rhs, pv_rhs, is_tile(pu_rhs), kpass ) + + END SUBROUTINE dyn_ldf_lap_lf + + SUBROUTINE dyn_ldf_lap_lf_t( kt, Kbb, Kmm, pu, pv, ktuv, pu_rhs, pv_rhs, ktuv_rhs, kpass ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_lap *** + !! + !! ** Purpose : Compute the before horizontal momentum diffusive + !! trend and add it to the general trend of momentum equation. + !! + !! ** Method : The Laplacian operator apply on horizontal velocity is + !! writen as : grad_h( ahmt div_h(U )) - curl_h( ahmf curl_z(U) ) + !! + !! ** Action : - pu_rhs, pv_rhs increased by the harmonic operator applied on pu, pv. + !! + !! Reference : S.Griffies, R.Hallberg 2000 Mon.Wea.Rev., DOI:/ + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + INTEGER , INTENT(in ) :: ktuv, ktuv_rhs + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktuv+1:,(ntsj-nn_hls-1)*ktuv+1: ,:), INTENT(in ) :: pu, pv ! before velocity [m/s] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktuv_rhs+1:,(ntsj-nn_hls-1)*ktuv_rhs+1:,:), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iij + REAL(wp) :: zsign ! local scalars + REAL(wp) :: zcur, zcur_im1, zcur_jm1 ! local scalars + REAL(wp) :: zdiv, zdiv_ip1, zdiv_jp1 ! local scalars + REAL(wp) :: zten, zten_ip1, zten_jp1, zshe, zshe_im1, zshe_jm1 ! tension (diagonal) and shearing (anti-diagonal) terms + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_ldf_lf : iso-level harmonic (laplacian) operator, pass=', kpass + WRITE(numout,*) '~~~~~~~ ' + ENDIF + ENDIF + ! + ! Define pu_rhs/pv_rhs halo points for multi-point haloes in bilaplacian case + IF( nldf_dyn == np_blp .AND. kpass == 1 ) THEN ; iij = nn_hls + ELSE ; iij = 1 + ENDIF + ! + IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign + ELSE ; zsign = -1._wp ! (eddy viscosity coef. >0) + ENDIF + ! + SELECT CASE( nn_dynldf_typ ) + ! + CASE ( np_typ_rot ) !== Vorticity-Divergence operator ==! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( iij-1), ntej+( iij-1) ; DO ji = ntsi-( iij-1), ntei+( iij-1) ! Horizontal slab + ! ! ahm * e3 * curl (warning: computed for ji-1,jj-1) + zcur = ahmf(ji ,jj ,jk) * (e3f_0(ji ,jj ,jk)*(1._wp+r3f(ji ,jj )*fe3mask(ji ,jj ,jk))) * r1_e1e2f(ji ,jj ) & ! ahmf already * by fmask + & * ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) + zcur_jm1 = ahmf(ji ,jj-1,jk) * (e3f_0(ji ,jj-1,jk)*(1._wp+r3f(ji ,jj-1)*fe3mask(ji ,jj-1,jk))) * r1_e1e2f(ji ,jj-1) & ! ahmf already * by fmask + & * ( e2v(ji+1,jj-1) * pv(ji+1,jj-1,jk) - e2v(ji,jj-1) * pv(ji,jj-1,jk) & + & - e1u(ji ,jj ) * pu(ji ,jj ,jk) + e1u(ji,jj-1) * pu(ji,jj-1,jk) ) + zcur_im1 = ahmf(ji-1,jj ,jk) * (e3f_0(ji-1,jj ,jk)*(1._wp+r3f(ji-1,jj )*fe3mask(ji-1,jj ,jk))) * r1_e1e2f(ji-1,jj ) & ! ahmf already * by fmask + & * ( e2v(ji ,jj ) * pv(ji ,jj ,jk) - e2v(ji-1,jj) * pv(ji-1,jj,jk) & + & - e1u(ji-1,jj+1) * pu(ji-1,jj+1,jk) + e1u(ji-1,jj) * pu(ji-1,jj,jk) ) + ! ! ahm * div (warning: computed for ji,jj) + zdiv = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kbb)*tmask(ji,jj,jk))) & ! ahmt already * by tmask + & * ( e2u(ji,jj)*(e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kbb)*umask(ji,jj,jk))) * pu(ji,jj,jk) - e2u(ji-1,jj)*(e3u_0(ji-1,jj,jk)*(1._wp+r3u(ji-1,jj,Kbb)*umask(ji-1,jj,jk))) * pu(ji-1,jj,jk) & + & + e1v(ji,jj)*(e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kbb)*vmask(ji,jj,jk))) * pv(ji,jj,jk) - e1v(ji,jj-1)*(e3v_0(ji,jj-1,jk)*(1._wp+r3v(ji,jj-1,Kbb)*vmask(ji,jj-1,jk))) * pv(ji,jj-1,jk) ) + zdiv_ip1 = ahmt(ji+1,jj,jk) * r1_e1e2t(ji+1,jj) / (e3t_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kbb)*tmask(ji+1,jj,jk))) & ! ahmt already * by tmask + & * ( e2u(ji+1,jj)*(e3u_0(ji+1,jj,jk)*(1._wp+r3u(ji+1,jj,Kbb)*umask(ji+1,jj,jk))) * pu(ji+1,jj,jk) - e2u(ji,jj)*(e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kbb)*umask(ji,jj,jk))) * pu(ji,jj,jk) & + & + e1v(ji+1,jj)*(e3v_0(ji+1,jj,jk)*(1._wp+r3v(ji+1,jj,Kbb)*vmask(ji+1,jj,jk))) * pv(ji+1,jj,jk) - e1v(ji+1,jj-1)*(e3v_0(ji+1,jj-1,jk)*(1._wp+r3v(ji+1,jj-1,Kbb)*vmask(ji+1,jj-1,jk))) * pv(ji+1,jj-1,jk) ) + zdiv_jp1 = ahmt(ji,jj+1,jk) * r1_e1e2t(ji,jj+1) / (e3t_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kbb)*tmask(ji,jj+1,jk))) & ! ahmt already * by tmask + & * ( e2u(ji,jj+1)*(e3u_0(ji,jj+1,jk)*(1._wp+r3u(ji,jj+1,Kbb)*umask(ji,jj+1,jk))) * pu(ji,jj+1,jk) - e2u(ji-1,jj+1)*(e3u_0(ji-1,jj+1,jk)*(1._wp+r3u(ji-1,jj+1,Kbb)*umask(ji-1,jj+1,jk))) * pu(ji-1,jj+1,jk) & + & + e1v(ji,jj+1)*(e3v_0(ji,jj+1,jk)*(1._wp+r3v(ji,jj+1,Kbb)*vmask(ji,jj+1,jk))) * pv(ji,jj+1,jk) - e1v(ji,jj)*(e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kbb)*vmask(ji,jj,jk))) * pv(ji,jj,jk) ) + ! ! - curl( curl) + grad( div ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use + & - ( zcur - zcur_jm1 ) * r1_e2u(ji,jj) / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) & + & + ( zdiv_ip1 - zdiv ) * r1_e1u(ji,jj) ) + ! + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * vmask(ji,jj,jk) * ( & ! * by vmask is mandatory for dyn_ldf_blp use + & ( zcur - zcur_im1 ) * r1_e1v(ji,jj) / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) & + & + ( zdiv_jp1 - zdiv ) * r1_e2v(ji,jj) ) + END DO ; END DO ; END DO ! End of slab + ! + CASE ( np_typ_sym ) !== Symmetric operator ==! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( iij-1), ntej+( iij-1) ; DO ji = ntsi-( iij-1), ntei+( iij-1) ! Horizontal slab + ! ! shearing stress component (F-point) NB : ahmf has already been multiplied by fmask + zshe = ahmf(ji,jj,jk) & + & * ( e1f(ji,jj) * r1_e2f(ji,jj) & + & * ( pu(ji,jj+1,jk) * r1_e1u(ji,jj+1) - pu(ji,jj,jk) * r1_e1u(ji,jj) ) & + & + e2f(ji,jj) * r1_e1f(ji,jj) & + & * ( pv(ji+1,jj,jk) * r1_e2v(ji+1,jj) - pv(ji,jj,jk) * r1_e2v(ji,jj) ) ) + zshe_im1 = ahmf(ji-1,jj,jk) & + & * ( e1f(ji-1,jj) * r1_e2f(ji-1,jj) & + & * ( pu(ji-1,jj+1,jk) * r1_e1u(ji-1,jj+1) - pu(ji-1,jj,jk) * r1_e1u(ji-1,jj) ) & + & + e2f(ji-1,jj) * r1_e1f(ji-1,jj) & + & * ( pv(ji ,jj,jk) * r1_e2v(ji ,jj) - pv(ji-1,jj,jk) * r1_e2v(ji-1,jj) ) ) + zshe_jm1 = ahmf(ji,jj-1,jk) & + & * ( e1f(ji,jj-1) * r1_e2f(ji,jj-1) & + & * ( pu(ji,jj,jk) * r1_e1u(ji,jj) - pu(ji,jj-1,jk) * r1_e1u(ji,jj-1) ) & + & + e2f(ji,jj-1) * r1_e1f(ji,jj-1) & + & * ( pv(ji+1,jj-1,jk) * r1_e2v(ji+1,jj-1) - pv(ji,jj-1,jk) * r1_e2v(ji,jj-1) ) ) + ! ! tension stress component (T-point) NB : ahmt has already been multiplied by tmask + zten = ahmt(ji,jj,jk) & + & * ( e2t(ji,jj) * r1_e1t(ji,jj) & + & * ( pu(ji,jj,jk) * r1_e2u(ji,jj) - pu(ji-1,jj,jk) * r1_e2u(ji-1,jj) ) & + & - e1t(ji,jj) * r1_e2t(ji,jj) & + & * ( pv(ji,jj,jk) * r1_e1v(ji,jj) - pv(ji,jj-1,jk) * r1_e1v(ji,jj-1) ) ) + zten_ip1 = ahmt(ji+1,jj,jk) & + & * ( e2t(ji+1,jj) * r1_e1t(ji+1,jj) & + & * ( pu(ji+1,jj,jk) * r1_e2u(ji+1,jj) - pu(ji,jj,jk) * r1_e2u(ji,jj) ) & + & - e1t(ji+1,jj) * r1_e2t(ji+1,jj) & + & * ( pv(ji+1,jj,jk) * r1_e1v(ji+1,jj) - pv(ji+1,jj-1,jk) * r1_e1v(ji+1,jj-1) ) ) + zten_jp1 = ahmt(ji,jj+1,jk) & + & * ( e2t(ji,jj+1) * r1_e1t(ji,jj+1) & + & * ( pu(ji,jj+1,jk) * r1_e2u(ji,jj+1) - pu(ji-1,jj+1,jk) * r1_e2u(ji-1,jj+1) ) & + & - e1t(ji,jj+1) * r1_e2t(ji,jj+1) & + & * ( pv(ji,jj+1,jk) * r1_e1v(ji,jj+1) - pv(ji,jj,jk) * r1_e1v(ji,jj) ) ) + ! + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * r1_e1e2u(ji,jj) / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) & + & * ( ( zten_ip1 * e2t(ji+1,jj )*e2t(ji+1,jj ) * (e3t_0(ji+1,jj ,jk)*(1._wp+r3t(ji+1,jj ,Kmm)*tmask(ji+1,jj ,jk))) & + & - zten * e2t(ji ,jj )*e2t(ji ,jj ) * (e3t_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kmm)*tmask(ji ,jj ,jk))) ) * r1_e2u(ji,jj) & + & + ( zshe * e1f(ji ,jj )*e1f(ji ,jj ) * (e3f_0(ji ,jj ,jk)*(1._wp+r3f(ji ,jj )*fe3mask(ji ,jj ,jk))) & + & - zshe_jm1 * e1f(ji ,jj-1)*e1f(ji ,jj-1) * (e3f_0(ji ,jj-1,jk)*(1._wp+r3f(ji ,jj-1)*fe3mask(ji ,jj-1,jk))) ) * r1_e1u(ji,jj) ) + ! + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * r1_e1e2v(ji,jj) / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) & + & * ( ( zshe * e2f(ji ,jj )*e2f(ji ,jj ) * (e3f_0(ji ,jj ,jk)*(1._wp+r3f(ji ,jj )*fe3mask(ji ,jj ,jk))) & + & - zshe_im1 * e2f(ji-1,jj )*e2f(ji-1,jj ) * (e3f_0(ji-1,jj ,jk)*(1._wp+r3f(ji-1,jj )*fe3mask(ji-1,jj ,jk))) ) * r1_e2v(ji,jj) & + & - ( zten_jp1 * e1t(ji ,jj+1)*e1t(ji ,jj+1) * (e3t_0(ji ,jj+1,jk)*(1._wp+r3t(ji ,jj+1,Kmm)*tmask(ji ,jj+1,jk))) & + & - zten * e1t(ji ,jj )*e1t(ji ,jj ) * (e3t_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kmm)*tmask(ji ,jj ,jk))) ) * r1_e1v(ji,jj) ) + ! + END DO ; END DO ; END DO + ! + END SELECT + ! + END SUBROUTINE dyn_ldf_lap_lf_t + + + SUBROUTINE dyn_ldf_blp_lf( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_blp *** + !! + !! ** Purpose : Compute the before lateral momentum viscous trend + !! and add it to the general trend of momentum equation. + !! + !! ** Method : The lateral viscous trends is provided by a bilaplacian + !! operator applied to before field (forward in time). + !! It is computed by two successive calls to dyn_ldf_lap routine + !! + !! ** Action : pt(:,:,:,:,Krhs) updated with the before rotated bilaplacian diffusion + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu, pv ! before velocity fields + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! momentum trend + ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zulap, zvlap ! laplacian at u- and v-point + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_ldf_blp_lf : bilaplacian operator momentum ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + zulap(:,:,:) = 0._wp + zvlap(:,:,:) = 0._wp + ! + CALL dyn_ldf_lap_lf( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 ) ! rotated laplacian applied to pt (output in zlap,Kbb) + ! + CALL dyn_ldf_lap_lf( kt, Kbb, Kmm, zulap, zvlap, pu_rhs, pv_rhs, 2 ) ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs)) + ! + END SUBROUTINE dyn_ldf_blp_lf + + !!====================================================================== +END MODULE dynldf_lap_blp_lf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynspg.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynspg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..bb14ed7651a85465acb9c1971cdd5b1a3d11a4b6 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynspg.f90 @@ -0,0 +1,260 @@ + + + + + + + + + + + + + +MODULE dynspg + !!====================================================================== + !! *** MODULE dynspg *** + !! Ocean dynamics: surface pressure gradient control + !!====================================================================== + !! History : 1.0 ! 2005-12 (C. Talandier, G. Madec, V. Garnier) Original code + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) add Bernoulli Head for + !! wave coupling + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_spg : update the dynamics trend with surface pressure gradient + !! dyn_spg_init: initialization, namelist read, and parameters control + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE c1d ! 1D vertical configuration + USE phycst ! physical constants + USE sbc_oce ! surface boundary condition: ocean + USE sbc_ice , ONLY : snwice_mass, snwice_mass_b + USE sbcapr ! surface boundary condition: atmospheric pressure + USE sbcwave, ONLY : bhd_wave + USE dynspg_exp ! surface pressure gradient (dyn_spg_exp routine) + USE dynspg_ts ! surface pressure gradient (dyn_spg_ts routine) + USE tide_mod ! + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE prtctl ! Print control (prt_ctl routine) + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_spg ! routine called by step module + PUBLIC dyn_spg_init ! routine called by opa module + + INTEGER :: nspg = 0 ! type of surface pressure gradient scheme defined from lk_dynspg_... + + ! ! Parameter to control the surface pressure gradient scheme + INTEGER, PARAMETER :: np_TS = 1 ! split-explicit time stepping (Time-Splitting) + INTEGER, PARAMETER :: np_EXP = 0 ! explicit time stepping + INTEGER, PARAMETER :: np_NO =-1 ! no surface pressure gradient, no scheme + ! + REAL(wp) :: zt0step ! Time of day at the beginning of the time step + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynspg.F90 14225 2020-12-19 14:58:39Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_spg( kt, Kbb, Kmm, Krhs, puu, pvv, pssh, puu_b, pvv_b, Kaa, k_only_ADV ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_spg *** + !! + !! ** Purpose : compute surface pressure gradient including the + !! atmospheric pressure forcing (ln_apr_dyn=T). + !! + !! ** Method : Two schemes: + !! - explicit : the spg is evaluated at now + !! - split-explicit : a time splitting technique is used + !! + !! ln_apr_dyn=T : the atmospheric pressure forcing is applied + !! as the gradient of the inverse barometer ssh: + !! apgu = - 1/rho0 di[apr] = 0.5*grav di[ssh_ib+ssh_ibb] + !! apgv = - 1/rho0 dj[apr] = 0.5*grav dj[ssh_ib+ssh_ibb] + !! Note that as all external forcing a time averaging over a two rn_Dt + !! period is used to prevent the divergence of odd and even time step. + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + REAL(wp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: puu_b, pvv_b! SSH and barotropic velocities at main time levels + REAL(dp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: pssh! SSH and barotropic velocities at main time levels + INTEGER , OPTIONAL , INTENT( in ) :: k_only_ADV ! only Advection in the RHS + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: z2dt, zg_2, zintp, zgrho0r, zld ! local scalars + REAL(wp) , DIMENSION(jpi,jpj) :: zpgu, zpgv ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zpice + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_spg') + ! + IF( l_trddyn ) THEN ! temporary save of ta and sa trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! + IF( ln_apr_dyn & ! atmos. pressure + .OR. ( .NOT.ln_dynspg_ts .AND. (ln_tide_pot .AND. ln_tide) ) & ! tide potential (no time slitting) + .OR. ln_ice_embd & ! embedded sea-ice + .OR. ( ln_wave .and. ln_bern_srfc ) ) THEN ! depth-independent Bernoulli head + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zpgu(ji,jj) = 0._wp + zpgv(ji,jj) = 0._wp + END DO ; END DO + ! + IF( ln_apr_dyn .AND. .NOT.ln_dynspg_ts ) THEN !== Atmospheric pressure gradient (added later in time-split case) ==! + zg_2 = grav * 0.5 + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! gradient of Patm using inverse barometer ssh + zpgu(ji,jj) = zpgu(ji,jj) + zg_2 * ( ssh_ib (ji+1,jj) - ssh_ib (ji,jj) & + & + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) + zpgv(ji,jj) = zpgv(ji,jj) + zg_2 * ( ssh_ib (ji,jj+1) - ssh_ib (ji,jj) & + & + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj) + END DO ; END DO + ENDIF + ! + ! !== tide potential forcing term ==! + IF( .NOT.ln_dynspg_ts .AND. ( ln_tide_pot .AND. ln_tide ) ) THEN ! N.B. added directly at sub-time-step in ts-case + ! + ! Update tide potential at the beginning of current time step + zt0step = REAL(nsec_day, wp)-0.5_wp*rn_Dt + CALL upd_tide(zt0step, Kmm) + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! add tide potential forcing + zpgu(ji,jj) = zpgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) + zpgv(ji,jj) = zpgv(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) + END DO ; END DO + ! + IF (ln_scal_load) THEN + zld = rn_scal_load * grav + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! add scalar approximation for load potential + zpgu(ji,jj) = zpgu(ji,jj) + zld * ( pssh(ji+1,jj,Kmm) - pssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) + zpgv(ji,jj) = zpgv(ji,jj) + zld * ( pssh(ji,jj+1,Kmm) - pssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) + END DO ; END DO + ENDIF + ENDIF + ! + IF( ln_ice_embd ) THEN !== embedded sea ice: Pressure gradient due to snow-ice mass ==! + ALLOCATE( zpice(jpi,jpj) ) + zintp = REAL( MOD( kt-1, nn_fsbc ) ) / REAL( nn_fsbc ) + zgrho0r = - grav * r1_rho0 + zpice(:,:) = ( zintp * snwice_mass(:,:) + ( 1.- zintp ) * snwice_mass_b(:,:) ) * zgrho0r + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zpgu(ji,jj) = zpgu(ji,jj) + ( zpice(ji+1,jj) - zpice(ji,jj) ) * r1_e1u(ji,jj) + zpgv(ji,jj) = zpgv(ji,jj) + ( zpice(ji,jj+1) - zpice(ji,jj) ) * r1_e2v(ji,jj) + END DO ; END DO + DEALLOCATE( zpice ) + ENDIF + ! + IF( ln_wave .and. ln_bern_srfc ) THEN !== Add J terms: depth-independent Bernoulli head + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zpgu(ji,jj) = zpgu(ji,jj) + ( bhd_wave(ji+1,jj) - bhd_wave(ji,jj) ) / e1u(ji,jj) !++ bhd_wave from wave model in m2/s2 [BHD parameters in WW3] + zpgv(ji,jj) = zpgv(ji,jj) + ( bhd_wave(ji,jj+1) - bhd_wave(ji,jj) ) / e2v(ji,jj) + END DO ; END DO + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !== Add all terms to the general trend + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zpgu(ji,jj) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zpgv(ji,jj) + END DO ; END DO ; END DO + ! +!!gm add here a call to dyn_trd for ice pressure gradient, the surf pressure trends ???? + ! + ENDIF + ! + SELECT CASE ( nspg ) !== surface pressure gradient computed and add to the general trend ==! + CASE ( np_EXP ) ; CALL dyn_spg_exp( kt, Kmm, puu, pvv, Krhs ) ! explicit + CASE ( np_TS ) ; CALL dyn_spg_ts ( kt, Kbb, Kmm, Krhs, puu, pvv, pssh, puu_b, pvv_b, Kaa, k_only_ADV ) ! time-splitting + END SELECT + ! + IF( l_trddyn ) THEN ! save the surface pressure gradient trends for further diagnostics + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_spg, kt, Kmm ) + DEALLOCATE( ztrdu , ztrdv ) + ENDIF + ! ! print mean trends (used for debugging) + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' spg - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_spg') + ! + END SUBROUTINE dyn_spg + + + SUBROUTINE dyn_spg_init + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_spg_init *** + !! + !! ** Purpose : Control the consistency between namelist options for + !! surface pressure gradient schemes + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ios ! local integers + ! + NAMELIST/namdyn_spg/ ln_dynspg_exp , ln_dynspg_ts, & + & ln_bt_fw, ln_bt_av , ln_bt_auto , & + & nn_e , rn_bt_cmax, nn_bt_flt, rn_bt_alpha + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_spg_init : choice of the surface pressure gradient scheme' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + READ ( numnam_ref, namdyn_spg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_spg in reference namelist' ) + ! + READ ( numnam_cfg, namdyn_spg, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist' ) + IF(lwm) WRITE ( numond, namdyn_spg ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) ' Namelist : namdyn_spg ' + WRITE(numout,*) ' Explicit free surface ln_dynspg_exp = ', ln_dynspg_exp + WRITE(numout,*) ' Free surface with time splitting ln_dynspg_ts = ', ln_dynspg_ts + ENDIF + ! ! Control of surface pressure gradient scheme options + nspg = np_NO ; ioptio = 0 + IF( ln_dynspg_exp ) THEN ; nspg = np_EXP ; ioptio = ioptio + 1 ; ENDIF + IF( ln_dynspg_ts ) THEN ; nspg = np_TS ; ioptio = ioptio + 1 ; ENDIF + ! + IF( ioptio > 1 ) CALL ctl_stop( 'Choose only one surface pressure gradient scheme' ) + IF( ioptio == 0 ) CALL ctl_warn( 'NO surface pressure gradient trend in momentum Eqs.' ) + IF( ln_dynspg_exp .AND. ln_isfcav ) & + & CALL ctl_stop( ' dynspg_exp not tested with ice shelf cavity ' ) + ! + IF(lwp) THEN + WRITE(numout,*) + IF( nspg == np_EXP ) WRITE(numout,*) ' ==>>> explicit free surface' + IF( nspg == np_TS ) WRITE(numout,*) ' ==>>> free surface with time splitting scheme' + IF( nspg == np_NO ) WRITE(numout,*) ' ==>>> No surface surface pressure gradient trend in momentum Eqs.' + ENDIF + ! + IF( nspg == np_TS ) THEN ! split-explicit scheme initialisation + CALL dyn_spg_ts_init ! do it first: set nn_e used to allocate some arrays later on + ENDIF + ! + END SUBROUTINE dyn_spg_init + + !!====================================================================== +END MODULE dynspg diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynspg_exp.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynspg_exp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3deed06a86c7f45dabeb6a3c54ea6ea23f05f925 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynspg_exp.f90 @@ -0,0 +1,104 @@ + + + + + + + + + + + + + +MODULE dynspg_exp + !!====================================================================== + !! *** MODULE dynspg_exp *** + !! Ocean dynamics: surface pressure gradient trend, explicit scheme + !!====================================================================== + !! History : 2.0 ! 2005-11 (V. Garnier, G. Madec, L. Bessieres) Original code + !! 3.2 ! 2009-06 (G. Madec, M. Leclair, R. Benshila) introduce sshwzv module + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_spg_exp : update the momentum trend with the surface + !! pressure gradient in the free surface constant + !! volume case with vector optimization + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition: ocean + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distributed memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE iom ! I/O library + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_spg_exp ! called in dynspg.F90 + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynspg_exp.F90 14064 2020-12-03 17:01:12Z ayoung $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_spg_exp( kt, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** routine dyn_spg_exp *** + !! + !! ** Purpose : Compute the now trend due to the surface pressure + !! gradient in case of explicit free surface formulation and + !! add it to the general trend of momentum equation. + !! + !! ** Method : Explicit free surface formulation. Add to the general + !! momentum trend the surface pressure gradient : + !! (uu(rhs),vv(rhs)) = (uu(rhs),vv(rhs)) + (spgu,spgv) + !! where spgu = -1/rho0 d/dx(ps) = -g/e1u di( ssh(now) ) + !! spgv = -1/rho0 d/dy(ps) = -g/e2v dj( ssh(now) ) + !! + !! ** Action : (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) trend of horizontal velocity increased by + !! the surf. pressure gradient trend + !!--------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zpgu, zpgv ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_spg_exp : surface pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ (explicit free surface)' + ! + zpgu(:,:) = 0._wp ; zpgv(:,:) = 0._wp + ! + IF( .NOT.ln_linssh .AND. lwp ) WRITE(numout,*) ' non linear free surface: spg is included in dynhpg' + ENDIF + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zpgu(ji,jj) = - grav * ( ssh(ji+1,jj,Kmm) - ssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) + zpgv(ji,jj) = - grav * ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) + END DO ; END DO + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zpgu(ji,jj) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zpgv(ji,jj) + END DO ; END DO ; END DO + ! + END SUBROUTINE dyn_spg_exp + + !!====================================================================== +END MODULE dynspg_exp diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynspg_ts.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynspg_ts.f90 new file mode 100644 index 0000000000000000000000000000000000000000..12cc7aa5ef58ad41b3a65b24728e224884f85b08 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynspg_ts.f90 @@ -0,0 +1,1429 @@ + + + + + + + + + + + + + +MODULE dynspg_ts + + !! Includes ROMS wd scheme with diagnostic outputs ; puu(:,:,:,Kmm) and puu(:,:,:,Krhs) updates are commented out ! + + !!====================================================================== + !! *** MODULE dynspg_ts *** + !! Ocean dynamics: surface pressure gradient trend, split-explicit scheme + !!====================================================================== + !! History : 1.0 ! 2004-12 (L. Bessieres, G. Madec) Original code + !! - ! 2005-11 (V. Garnier, G. Madec) optimization + !! - ! 2006-08 (S. Masson) distributed restart using iom + !! 2.0 ! 2007-07 (D. Storkey) calls to BDY routines + !! - ! 2008-01 (R. Benshila) change averaging method + !! 3.2 ! 2009-07 (R. Benshila, G. Madec) Complete revisit associated to vvl reactivation + !! 3.3 ! 2010-09 (D. Storkey, E. O'Dea) update for BDY for Shelf configurations + !! 3.3 ! 2011-03 (R. Benshila, R. Hordoir, P. Oddo) update calculation of ub_b + !! 3.5 ! 2013-07 (J. Chanut) Switch to Forward-backward time stepping + !! 3.6 ! 2013-11 (A. Coward) Update for z-tilde compatibility + !! 3.7 ! 2015-11 (J. Chanut) free surface simplification + !! - ! 2016-12 (G. Madec, E. Clementi) update for Stoke-Drift divergence + !! 4.0 ! 2017-05 (G. Madec) drag coef. defined at t-point (zdfdrg.F90) + !!--------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_spg_ts : compute surface pressure gradient trend using a time-splitting scheme + !! dyn_spg_ts_init: initialisation of the time-splitting scheme + !! ts_wgt : set time-splitting weights for temporal averaging (or not) + !! ts_rst : read/write time-splitting fields in restart file + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition: ocean + USE isf_oce ! ice shelf variable (fwfisf) + USE zdf_oce ! vertical physics: variables + USE zdfdrg ! vertical physics: top/bottom drag coef. + USE sbcapr ! surface boundary condition: atmospheric pressure + USE dynadv , ONLY: ln_dynadv_vec + USE dynvor ! vortivity scheme indicators + USE phycst ! physical constants + USE dynvor ! vorticity term + USE wet_dry ! wetting/drying flux limter + USE bdy_oce ! open boundary + USE bdyvol ! open boundary volume conservation + USE bdytides ! open boundary condition data + USE bdydyn2d ! open boundary conditions on barotropic variables + USE tide_mod ! + USE sbcwave ! surface wave + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distributed memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE iom ! IOM library + USE restart ! only for lrst_oce + + USE iom ! to remove + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_spg_ts ! called by dyn_spg + PUBLIC dyn_spg_ts_init ! - - dyn_spg_init + + !! Time filtered arrays at baroclinic time step: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_adv , vn_adv !: Advection vel. at "now" barocl. step + ! + INTEGER, SAVE :: icycle ! Number of barotropic sub-steps for each internal step nn_e <= 2.5 nn_e + REAL(dp),SAVE :: rDt_e ! Barotropic time step + ! + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: wgtbtp2! 1st & 2nd weights used in time filtering of barotropic fields + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:) :: wgtbtp1! 1st & 2nd weights used in time filtering of barotropic fields + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zwz ! ff_f/h at F points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftnw, ftne ! triad of coriolis parameter + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftsw, ftse ! (only used with een vorticity scheme) + + REAL(wp) :: r1_12 = 1._wp / 12._wp ! local ratios + REAL(wp) :: r1_8 = 0.125_wp ! + REAL(wp) :: r1_4 = 0.25_wp ! + REAL(wp) :: r1_2 = 0.5_wp ! + + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynspg_ts.F90 15489 2021-11-10 09:18:39Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION dyn_spg_ts_alloc() + !!---------------------------------------------------------------------- + !! *** routine dyn_spg_ts_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(3) + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( wgtbtp1(3*nn_e), wgtbtp2(3*nn_e), zwz(jpi,jpj), STAT=ierr(1) ) + IF( ln_dynvor_een .OR. ln_dynvor_eeT ) & + & ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , ftsw(jpi,jpj) , ftse(jpi,jpj), STAT=ierr(2) ) + ! + ALLOCATE( un_adv(jpi,jpj), vn_adv(jpi,jpj) , STAT=ierr(3) ) + ! + dyn_spg_ts_alloc = MAXVAL( ierr(:) ) + ! + CALL mpp_sum( 'dynspg_ts', dyn_spg_ts_alloc ) + IF( dyn_spg_ts_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dyn_spg_ts_alloc: failed to allocate arrays' ) + ! + END FUNCTION dyn_spg_ts_alloc + + + SUBROUTINE dyn_spg_ts( kt, Kbb, Kmm, Krhs, puu, pvv, pssh, puu_b, pvv_b, Kaa, k_only_ADV ) + !!---------------------------------------------------------------------- + !! + !! ** Purpose : - Compute the now trend due to the explicit time stepping + !! of the quasi-linear barotropic system, and add it to the + !! general momentum trend. + !! + !! ** Method : - split-explicit schem (time splitting) : + !! Barotropic variables are advanced from internal time steps + !! "n" to "n+1" if ln_bt_fw=T + !! or from + !! "n-1" to "n+1" if ln_bt_fw=F + !! thanks to a generalized forward-backward time stepping (see ref. below). + !! + !! ** Action : + !! -Update the filtered free surface at step "n+1" : pssh(:,:,Kaa) + !! -Update filtered barotropic velocities at step "n+1" : puu_b(:,:,:,Kaa), vv_b(:,:,:,Kaa) + !! -Compute barotropic advective fluxes at step "n" : un_adv, vn_adv + !! These are used to advect tracers and are compliant with discrete + !! continuity equation taken at the baroclinic time steps. This + !! ensures tracers conservation. + !! - (puu(:,:,:,Krhs), pvv(:,:,:,Krhs)) momentum trend updated with barotropic component. + !! + !! References : Shchepetkin and McWilliams, Ocean Modelling, 2005. + !!--------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + REAL(wp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: puu_b, pvv_b! SSH and barotropic velocities at main time levels + REAL(dp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: pssh! SSH and barotropic velocities at main time levels + INTEGER , OPTIONAL , INTENT( in ) :: k_only_ADV ! only Advection in the RHS + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + LOGICAL :: ll_fw_start ! =T : forward integration + LOGICAL :: ll_init ! =T : special startup of 2d equations + INTEGER :: noffset ! local integers : time offset for bdy update + REAL(wp) :: r1_Dt_b, z1_hu, z1_hv ! local scalars + REAL(wp) :: za0, za2, za3! - - + REAL(dp) :: za1! - - + REAL(wp) :: zztmp, zldg ! - - + REAL(wp) :: zhu_bck, zhv_bck! - - + REAL(dp) :: zhdiv! - - + REAL(wp) :: zun_save, zvn_save ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zu_trd, zu_frc, zu_spg + REAL(wp), DIMENSION(jpi,jpj) :: zv_trd, zv_frc, zv_spg + REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhtp2_e + REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zsshp2_e + REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v ! top/bottom stress at u- & v-points + REAL(wp), DIMENSION(jpi,jpj) :: zhV! fluxes + REAL(dp), DIMENSION(jpi,jpj) :: zhU! fluxes +!!st#if defined 1 +!!st REAL(wp), DIMENSION(jpi, jpj, jpk) :: ze3u, ze3v +!!st#endif + ! + REAL(wp) :: zwdramp ! local scalar - only used if ln_wd_dl = .True. + + INTEGER :: iwdg, jwdg, kwdg ! short-hand values for the indices of the output point + + REAL(wp) :: zepsilon, zgamma ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zcpx, zcpy ! Wetting/Dying gravity filter coef. + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztwdmask, zuwdmask, zvwdmask ! ROMS wetting and drying masks at t,u,v points + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zuwdav2, zvwdav2 ! averages over the sub-steps of zuwdmask and zvwdmask + REAL(wp) :: zt0substep ! Time of day at the beginning of the time substep + !!---------------------------------------------------------------------- + ! + IF( ln_wd_il ) ALLOCATE( zcpx(jpi,jpj), zcpy(jpi,jpj) ) + ! !* Allocate temporary arrays + IF( ln_wd_dl ) ALLOCATE( ztwdmask(jpi,jpj), zuwdmask(jpi,jpj), zvwdmask(jpi,jpj), zuwdav2(jpi,jpj), zvwdav2(jpi,jpj)) + ! + zwdramp = r_rn_wdmin1 ! simplest ramp +! zwdramp = 1._wp / (rn_wdmin2 - rn_wdmin1) ! more general ramp + ! ! inverse of baroclinic time step + r1_Dt_b = 1._wp / rDt + ! + ll_init = ln_bt_av ! if no time averaging, then no specific restart + ll_fw_start = .FALSE. + ! ! time offset in steps for bdy data update + IF( .NOT.ln_bt_fw ) THEN ; noffset = - nn_e + ELSE ; noffset = 0 + ENDIF + ! + IF( kt == nit000 ) THEN !* initialisation + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_spg_ts : surface pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~ free surface with time splitting' + IF(lwp) WRITE(numout,*) + ! + IF( l_1st_euler ) ll_init=.TRUE. + ! + IF( ln_bt_fw .OR. l_1st_euler ) THEN + ll_fw_start =.TRUE. + noffset = 0 + ELSE + ll_fw_start =.FALSE. + ENDIF + ! ! Set averaging weights and cycle length: + CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) + ! + ELSEIF( kt == nit000 + 1 ) THEN !* initialisation 2nd time-step + ! + IF( .NOT.ln_bt_fw ) THEN + ! If we did an Euler timestep on the first timestep we need to reset ll_fw_start + ! and the averaging weights. We don't have an easy way of telling whether we did + ! an Euler timestep on the first timestep (because l_1st_euler is reset to .false. + ! at the end of the first timestep) so just do this in all cases. + ll_fw_start = .FALSE. + CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) + ENDIF + ! + ENDIF + ! + ! ----------------------------------------------------------------------------- + ! Phase 1 : Coupling between general trend and barotropic estimates (1st step) + ! ----------------------------------------------------------------------------- + ! + ! + ! != zu_frc = 1/H e3*d/dt(Ua) =! (Vertical mean of Ua, the 3D trends) + ! ! --------------------------- ! + zu_frc(:,:) = SUM( e3u_0(:,:,: ) * puu(:,:,:,Krhs) * umask(:,:,:), DIM=3 ) * r1_hu_0(:,:) + zv_frc(:,:) = SUM( e3v_0(:,:,: ) * pvv(:,:,:,Krhs) * vmask(:,:,:), DIM=3 ) * r1_hv_0(:,:) + ! + ! + ! != U(Krhs) => baroclinic trend =! (remove its vertical mean) + DO jk = 1, jpkm1 ! ----------------------------- ! + puu(:,:,jk,Krhs) = ( puu(:,:,jk,Krhs) - zu_frc(:,:) ) * umask(:,:,jk) + pvv(:,:,jk,Krhs) = ( pvv(:,:,jk,Krhs) - zv_frc(:,:) ) * vmask(:,:,jk) + END DO + +!!gm Question here when removing the Vertically integrated trends, we remove the vertically integrated NL trends on momentum.... +!!gm Is it correct to do so ? I think so... + + ! != remove 2D Coriolis trend =! + ! ! -------------------------- ! + ! + IF( kt == nit000 .OR. .NOT. ln_linssh ) CALL dyn_cor_2D_init( Kmm ) ! Set zwz, the barotropic Coriolis force coefficient + ! ! recompute zwz = f/depth at every time step for (.NOT.ln_linssh) as the water colomn height changes + ! + IF( .NOT. PRESENT(k_only_ADV) ) THEN !* remove the 2D Coriolis trend + zhU(:,:) = puu_b(:,:,Kmm) * (hu_0(:,:)*(1._wp+r3u(:,:,Kmm))) * e2u(:,:) ! now fluxes + zhV(:,:) = pvv_b(:,:,Kmm) * (hv_0(:,:)*(1._wp+r3v(:,:,Kmm))) * e1v(:,:) ! NB: FULL domain : put a value in last row and column + ! + CALL dyn_cor_2d( REAL((ht_0(:,:)*(1._wp+r3t(:,:,Kmm))),sp), (hu_0(:,:)*(1._wp+r3u(:,:,Kmm))), (hv_0(:,:)*(1._wp+r3v(:,:,Kmm))), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in + & zu_trd, zv_trd ) ! ==>> out + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! Remove coriolis term (and possibly spg) from barotropic trend + zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) + zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) + END DO ; END DO + ENDIF + ! + ! != Add bottom stress contribution from baroclinic velocities =! + ! ! ----------------------------------------------------------- ! + IF( PRESENT(k_only_ADV) ) THEN !* only Advection in the RHS : provide the barotropic bottom drag coefficients + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) + zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) + END DO ; END DO + ELSE !* remove baroclinic drag AND provide the barotropic drag coefficients + CALL dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b, pvv_b, zu_frc, zv_frc, zCdU_u, zCdU_v ) + ENDIF + ! + ! != Add atmospheric pressure forcing =! + ! ! ---------------------------------- ! + IF( ln_apr_dyn ) THEN + IF( ln_bt_fw ) THEN ! FORWARD integration: use kt+1/2 pressure (NOW+1/2) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu_frc(ji,jj) = zu_frc(ji,jj) + grav * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) + zv_frc(ji,jj) = zv_frc(ji,jj) + grav * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) + END DO ; END DO + ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW) + zztmp = grav * r1_2 + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) & + & + ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) + zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) & + & + ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj) + END DO ; END DO + ENDIF + ENDIF + ! + ! != Add wind forcing =! + ! ! ------------------ ! + IF( ln_bt_fw ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu_frc(ji,jj) = zu_frc(ji,jj) + r1_rho0 * utau(ji,jj) * (r1_hu_0(ji,jj)/(1._wp+r3u(ji,jj,Kmm))) + zv_frc(ji,jj) = zv_frc(ji,jj) + r1_rho0 * vtau(ji,jj) * (r1_hv_0(ji,jj)/(1._wp+r3v(ji,jj,Kmm))) + END DO ; END DO + ELSE + zztmp = r1_rho0 * r1_2 + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * (r1_hu_0(ji,jj)/(1._wp+r3u(ji,jj,Kmm))) + zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * (r1_hv_0(ji,jj)/(1._wp+r3v(ji,jj,Kmm))) + END DO ; END DO + ENDIF + ! + ! !----------------! + ! !== sssh_frc ==! Right-Hand-Side of the barotropic ssh equation (over the FULL domain) + ! !----------------! + ! != Net water flux forcing applied to a water column =! + ! ! --------------------------------------------------- ! + IF (ln_bt_fw) THEN ! FORWARD integration: use kt+1/2 fluxes (NOW+1/2) + ssh_frc(:,:) = r1_rho0 * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) ) + ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 fluxes (NOW) + zztmp = r1_rho0 * r1_2 + ssh_frc(:,:) = zztmp * ( emp(:,:) + emp_b(:,:) & + & - rnf(:,:) - rnf_b(:,:) & + & - fwfisf_cav(:,:) - fwfisf_cav_b(:,:) & + & - fwfisf_par(:,:) - fwfisf_par_b(:,:) ) + ENDIF + ! != Add Stokes drift divergence =! (if exist) + IF( ln_sdw ) THEN ! ----------------------------- ! + ssh_frc(:,:) = ssh_frc(:,:) + div_sd(:,:) + ENDIF + ! + ! ! ice sheet coupling + IF ( ln_isf .AND. ln_isfcpl ) THEN + ! + ! ice sheet coupling + IF( ln_rstart .AND. kt == nit000 ) THEN + ssh_frc(:,:) = ssh_frc(:,:) + risfcpl_ssh(:,:) + END IF + ! + ! conservation option + IF( ln_isfcpl_cons ) THEN + ssh_frc(:,:) = ssh_frc(:,:) + risfcpl_cons_ssh(:,:) + END IF + ! + END IF + ! + ! != Fill boundary data arrays for AGRIF + ! ! ------------------------------------ + ! + ! ----------------------------------------------------------------------- + ! Phase 2 : Integration of the barotropic equations + ! ----------------------------------------------------------------------- + ! + ! ! ==================== ! + ! ! Initialisations ! + ! ! ==================== ! + ! Initialize barotropic variables: + IF( ll_init )THEN + sshbb_e(:,:) = 0._wp + ubb_e (:,:) = 0._wp + vbb_e (:,:) = 0._wp + sshb_e (:,:) = 0._wp + ub_e (:,:) = 0._wp + vb_e (:,:) = 0._wp + ENDIF + ! + IF( ln_linssh ) THEN ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) + zhup2_e(:,:) = hu_0(:,:) + zhvp2_e(:,:) = hv_0(:,:) + zhtp2_e(:,:) = ht_0(:,:) + ENDIF + ! + IF( ln_bt_fw ) THEN ! FORWARD integration: start from NOW fields + sshn_e(:,:) = pssh (:,:,Kmm) + un_e (:,:) = puu_b(:,:,Kmm) + vn_e (:,:) = pvv_b(:,:,Kmm) + ! + hu_e (:,:) = (hu_0(:,:)*(1._wp+r3u(:,:,Kmm))) + hv_e (:,:) = (hv_0(:,:)*(1._wp+r3v(:,:,Kmm))) + hur_e (:,:) = (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm))) + hvr_e (:,:) = (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm))) + ELSE ! CENTRED integration: start from BEFORE fields + sshn_e(:,:) = pssh (:,:,Kbb) + un_e (:,:) = puu_b(:,:,Kbb) + vn_e (:,:) = pvv_b(:,:,Kbb) + ! + hu_e (:,:) = (hu_0(:,:)*(1._wp+r3u(:,:,Kbb))) + hv_e (:,:) = (hv_0(:,:)*(1._wp+r3v(:,:,Kbb))) + hur_e (:,:) = (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kbb))) + hvr_e (:,:) = (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kbb))) + ENDIF + ! + ! Initialize sums: + puu_b (:,:,Kaa) = 0._wp ! After barotropic velocities (or transport if flux form) + pvv_b (:,:,Kaa) = 0._wp + pssh (:,:,Kaa) = 0._wp ! Sum for after averaged sea level + un_adv(:,:) = 0._wp ! Sum for now transport issued from ts loop + vn_adv(:,:) = 0._wp + ! + IF( ln_wd_dl ) THEN + zuwdmask(:,:) = 0._wp ! set to zero for definiteness (not sure this is necessary) + zvwdmask(:,:) = 0._wp ! + zuwdav2 (:,:) = 0._wp + zvwdav2 (:,:) = 0._wp + END IF + + ! ! ==================== ! + DO jn = 1, icycle ! sub-time-step loop ! + ! ! ==================== ! + ! + l_full_nf_update = jn == icycle ! false: disable full North fold update (performances) for jn = 1 to icycle-1 + ! + ! !== Update the forcing ==! (BDY and tides) + ! + IF( ln_bdy .AND. ln_tide ) CALL bdy_dta_tides( kt, kit=jn, pt_offset= REAL(noffset+1,wp) ) + ! Update tide potential at the beginning of current time substep + IF( ln_tide_pot .AND. ln_tide ) THEN + zt0substep = REAL(nsec_day, wp) - 0.5_wp*rn_Dt + (jn + noffset - 1) * rn_Dt / REAL(nn_e, wp) + CALL upd_tide(zt0substep, Kmm) + END IF + ! + ! !== extrapolation at mid-step ==! (jn+1/2) + ! + ! !* Set extrapolation coefficients for predictor step: + IF ((jn<3).AND.ll_init) THEN ! Forward + za1 = 1._wp + za2 = 0._wp + za3 = 0._wp + ELSE ! AB3-AM4 Coefficients: bet=0.281105 + za1 = 1.781105_wp ! za1 = 3/2 + bet + za2 = -1.06221_wp ! za2 = -(1/2 + 2*bet) + za3 = 0.281105_wp ! za3 = bet + ENDIF + ! + ! !* Extrapolate barotropic velocities at mid-step (jn+1/2) + !-- m+1/2 m m-1 m-2 --! + !-- u = (3/2+beta) u -(1/2+2beta) u + beta u --! + !-------------------------------------------------------------------------! + ua_e(:,:) = za1 * un_e(:,:) + za2 * ub_e(:,:) + za3 * ubb_e(:,:) + va_e(:,:) = za1 * vn_e(:,:) + za2 * vb_e(:,:) + za3 * vbb_e(:,:) + + IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) + ! ! ------------------ + ! Extrapolate Sea Level at step jit+0.5: + !-- m+1/2 m m-1 m-2 --! + !-- ssh = (3/2+beta) ssh -(1/2+2beta) ssh + beta ssh --! + !--------------------------------------------------------------------------------! + zsshp2_e(:,:) = za1 * sshn_e(:,:) + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) + + ! set wetting & drying mask at tracer points for this barotropic mid-step + IF( ln_wd_dl ) CALL wad_tmsk( zsshp2_e, ztwdmask ) + ! + ! ! ocean t-depth at mid-step + zhtp2_e(:,:) = ht_0(:,:) + zsshp2_e(:,:) + ! + ! ! ocean u- and v-depth at mid-step (separate DO-loops remove the need of a lbc_lnk) + ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 0) ! not jpi-column + zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & + & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & + & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) + END DO ; END DO + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 1) ! not jpj-row + zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) & + & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & + & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) + END DO ; END DO + ! + ENDIF + ! + ! !== after SSH ==! (jn+1) + ! + ! ! update (ua_e,va_e) to enforce volume conservation at open boundaries + ! ! values of zhup2_e and zhvp2_e on the halo are not needed in bdy_vol2d + IF( ln_bdy .AND. ln_vol ) CALL bdy_vol2d( kt, jn, ua_e, va_e, zhup2_e, zhvp2_e ) + ! + ! ! resulting flux at mid-step (not over the full domain) + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 0) ! not jpi-column + zhU(ji,jj) = e2u(ji,jj) * ua_e(ji,jj) * zhup2_e(ji,jj) + END DO ; END DO + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 1) ! not jpj-row + zhV(ji,jj) = e1v(ji,jj) * va_e(ji,jj) * zhvp2_e(ji,jj) + END DO ; END DO + ! + IF( ln_wd_il ) CALL wad_lmt_bt(zhU, zhV, sshn_e, ssh_frc, rDt_e) !!gm wad_lmt_bt use of lbc_lnk on zhU, zhV + + IF( ln_wd_dl ) THEN ! un_e and vn_e are set to zero at faces where + ! ! the direction of the flow is from dry cells + CALL wad_Umsk( ztwdmask, zhU, zhV, un_e, vn_e, zuwdmask, zvwdmask ) ! not jpi colomn for U, not jpj row for V + ! + ENDIF + ! + ! + ! Compute Sea Level at step jit+1 + !-- m+1 m m+1/2 --! + !-- ssh = ssh - delta_t' * [ frc + div( flux ) ] --! + !-------------------------------------------------------------------------! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zhdiv = ( zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1) ) * r1_e1e2t(ji,jj) + ssha_e(ji,jj) = ( sshn_e(ji,jj) - rDt_e * ( ssh_frc(ji,jj) + zhdiv ) ) * ssmask(ji,jj) + END DO ; END DO + ! + CALL lbc_lnk( 'dynspg_ts', ssha_e, 'T', 1._dp, zhU, 'U', -1._dp) + CALL lbc_lnk( 'dynspg_ts', zhV, 'V', -1._wp ) + ! + ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) + IF( ln_bdy ) CALL bdy_ssh( ssha_e ) + ! + ! ! Sum over sub-time-steps to compute advective velocities + za2 = wgtbtp2(jn) ! zhU, zhV hold fluxes extrapolated at jn+0.5 + un_adv(:,:) = un_adv(:,:) + za2 * zhU(:,:) * r1_e2u(:,:) + vn_adv(:,:) = vn_adv(:,:) + za2 * zhV(:,:) * r1_e1v(:,:) + ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc=True) + IF ( ln_wd_dl_bc ) THEN + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 0) ! not jpi-column + zuwdav2(ji,jj) = zuwdav2(ji,jj) + za2 * zuwdmask(ji,jj) + END DO ; END DO + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 1) ! not jpj-row + zvwdav2(ji,jj) = zvwdav2(ji,jj) + za2 * zvwdmask(ji,jj) + END DO ; END DO + END IF + ! + ! + ! Sea Surface Height at u-,v-points (vvl case only) + IF( .NOT.ln_linssh ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zsshu_a(ji,jj) = r1_2 * r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & + & + e1e2t(ji+1,jj ) * ssha_e(ji+1,jj ) ) * ssumask(ji,jj) + zsshv_a(ji,jj) = r1_2 * r1_e1e2v(ji,jj) * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & + & + e1e2t(ji ,jj+1) * ssha_e(ji ,jj+1) ) * ssvmask(ji,jj) + END DO ; END DO + ENDIF + ! + ! Half-step back interpolation of SSH for surface pressure computation at step jit+1/2 + !-- m+1/2 m+1 m m-1 m-2 --! + !-- ssh' = za0 * ssh + za1 * ssh + za2 * ssh + za3 * ssh --! + !------------------------------------------------------------------------------------------! + CALL ts_bck_interp( jn, ll_init, za0, za1, za2, za3 ) ! coeficients of the interpolation + zsshp2_e(:,:) = za0 * ssha_e(:,:) + za1 * sshn_e (:,:) & + & + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) + ! + ! ! Surface pressure gradient + zldg = ( 1._wp - rn_scal_load ) * grav ! local factor + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) + zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) + END DO ; END DO + IF( ln_wd_il ) THEN ! W/D : gravity filters applied on pressure gradient + CALL wad_spg( zsshp2_e, zcpx, zcpy ) ! Calculating W/D gravity filters + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu_spg(ji,jj) = zu_spg(ji,jj) * zcpx(ji,jj) + zv_spg(ji,jj) = zv_spg(ji,jj) * zcpy(ji,jj) + END DO ; END DO + ENDIF + ! + ! Add Coriolis trend: + ! zwz array below or triads normally depend on sea level with ln_linssh=F and should be updated + ! at each time step. We however keep them constant here for optimization. + ! Recall that zhU and zhV hold fluxes at jn+0.5 (extrapolated not backward interpolated) + CALL dyn_cor_2d( zhtp2_e, zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV, zu_trd, zv_trd ) + ! + ! Add tidal astronomical forcing if defined + IF ( ln_tide .AND. ln_tide_pot ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) + zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) + END DO ; END DO + ENDIF + ! + ! Add bottom stresses: +!jth do implicitly instead + IF ( .NOT. ll_wd ) THEN ! Revert to explicit for bit comparison tests in non wad runs + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj) + zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj) + END DO ; END DO + ENDIF + ! + ! Set next velocities: + ! Compute barotropic speeds at step jit+1 (h : total height of the water colomn) + !-- VECTOR FORM + !-- m+1 m / m+1/2 \ --! + !-- u = u + delta_t' * \ (1-r)*g * grad_x( ssh') - f * k vect u + frc / --! + !-- --! + !-- FLUX FORM --! + !-- m+1 __1__ / m m / m+1/2 m+1/2 m+1/2 n \ \ --! + !-- u = m+1 | h * u + delta_t' * \ h * (1-r)*g * grad_x( ssh') - h * f * k vect u + h * frc / | --! + !-- h \ / --! + !------------------------------------------------------------------------------------------------------------------------! + IF( ln_dynadv_vec .OR. ln_linssh ) THEN !* Vector form + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ua_e(ji,jj) = ( un_e(ji,jj) & + & + rDt_e * ( zu_spg(ji,jj) & + & + zu_trd(ji,jj) & + & + zu_frc(ji,jj) ) & + & ) * ssumask(ji,jj) + + va_e(ji,jj) = ( vn_e(ji,jj) & + & + rDt_e * ( zv_spg(ji,jj) & + & + zv_trd(ji,jj) & + & + zv_frc(ji,jj) ) & + & ) * ssvmask(ji,jj) + END DO ; END DO + ! + ELSE !* Flux form + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ! ! hu_e, hv_e hold depth at jn, zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 + ! ! backward interpolated depth used in spg terms at jn+1/2 + zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & + & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) + zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & + & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) + ! ! inverse depth at jn+1 + z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) + z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) + ! + ua_e(ji,jj) = ( hu_e (ji,jj) * un_e (ji,jj) & + & + rDt_e * ( zhu_bck * zu_spg (ji,jj) & ! + & + zhup2_e(ji,jj) * zu_trd (ji,jj) & ! + & + (hu_0(ji,jj)*(1._wp+r3u(ji,jj,Kmm))) * zu_frc (ji,jj) ) ) * z1_hu + ! + va_e(ji,jj) = ( hv_e (ji,jj) * vn_e (ji,jj) & + & + rDt_e * ( zhv_bck * zv_spg (ji,jj) & ! + & + zhvp2_e(ji,jj) * zv_trd (ji,jj) & ! + & + (hv_0(ji,jj)*(1._wp+r3v(ji,jj,Kmm))) * zv_frc (ji,jj) ) ) * z1_hv + END DO ; END DO + ENDIF +!jth implicit bottom friction: + IF ( ll_wd ) THEN ! revert to explicit for bit comparison tests in non wad runs + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ua_e(ji,jj) = ua_e(ji,jj) / ( 1._wp - rDt_e * zCdU_u(ji,jj) * hur_e(ji,jj) ) + va_e(ji,jj) = va_e(ji,jj) / ( 1._wp - rDt_e * zCdU_v(ji,jj) * hvr_e(ji,jj) ) + END DO ; END DO + ENDIF + + IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + hu_e (ji,jj) = hu_0(ji,jj) + zsshu_a(ji,jj) + hur_e(ji,jj) = ssumask(ji,jj) / ( hu_e(ji,jj) + 1._wp - ssumask(ji,jj) ) + hv_e (ji,jj) = hv_0(ji,jj) + zsshv_a(ji,jj) + hvr_e(ji,jj) = ssvmask(ji,jj) / ( hv_e(ji,jj) + 1._wp - ssvmask(ji,jj) ) + END DO ; END DO + ENDIF + ! + IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) + CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp & + & , hu_e , 'U', 1._wp, hv_e , 'V', 1._wp & + & , hur_e, 'U', 1._wp, hvr_e, 'V', 1._wp ) + ELSE + CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp ) + ENDIF + ! ! open boundaries + IF( ln_bdy ) CALL bdy_dyn2d( jn, ua_e, va_e, un_e, vn_e, hur_e, hvr_e, ssha_e ) + ! !* Swap + ! ! ---- + ubb_e (:,:) = ub_e (:,:) + ub_e (:,:) = un_e (:,:) + un_e (:,:) = ua_e (:,:) + ! + vbb_e (:,:) = vb_e (:,:) + vb_e (:,:) = vn_e (:,:) + vn_e (:,:) = va_e (:,:) + ! + sshbb_e(:,:) = sshb_e(:,:) + sshb_e (:,:) = sshn_e(:,:) + sshn_e (:,:) = ssha_e(:,:) + + ! !* Sum over whole bt loop + ! ! ---------------------- + za1 = wgtbtp1(jn) + IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! Sum velocities + puu_b (:,:,Kaa) = puu_b (:,:,Kaa) + za1 * ua_e (:,:) + pvv_b (:,:,Kaa) = pvv_b (:,:,Kaa) + za1 * va_e (:,:) + ELSE ! Sum transports + IF ( .NOT.ln_wd_dl ) THEN + puu_b (:,:,Kaa) = puu_b (:,:,Kaa) + za1 * ua_e (:,:) * hu_e (:,:) + pvv_b (:,:,Kaa) = pvv_b (:,:,Kaa) + za1 * va_e (:,:) * hv_e (:,:) + ELSE + puu_b (:,:,Kaa) = puu_b (:,:,Kaa) + za1 * ua_e (:,:) * hu_e (:,:) * zuwdmask(:,:) + pvv_b (:,:,Kaa) = pvv_b (:,:,Kaa) + za1 * va_e (:,:) * hv_e (:,:) * zvwdmask(:,:) + END IF + ENDIF + ! ! Sum sea level + pssh(:,:,Kaa) = pssh(:,:,Kaa) + za1 * ssha_e(:,:) + + ! ! ==================== ! + END DO ! end loop ! + ! ! ==================== ! + ! ----------------------------------------------------------------------------- + ! Phase 3. update the general trend with the barotropic trend + ! ----------------------------------------------------------------------------- + ! + ! Set advection velocity correction: + IF (ln_bt_fw) THEN + IF( .NOT.( kt == nit000 .AND. l_1st_euler ) ) THEN + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zun_save = un_adv(ji,jj) + zvn_save = vn_adv(ji,jj) + ! ! apply the previously computed correction + un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - rn_atfp * un_bf(ji,jj) ) + vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - rn_atfp * vn_bf(ji,jj) ) + ! ! Update corrective fluxes for next time step + un_bf(ji,jj) = rn_atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) + vn_bf(ji,jj) = rn_atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) + ! ! Save integrated transport for next computation + ub2_b(ji,jj) = zun_save + vb2_b(ji,jj) = zvn_save + END DO ; END DO + ELSE + un_bf(:,:) = 0._wp ! corrective fluxes for next time step set to zero + vn_bf(:,:) = 0._wp + ub2_b(:,:) = un_adv(:,:) ! Save integrated transport for next computation + vb2_b(:,:) = vn_adv(:,:) + END IF + ENDIF + + + ! + ! Update barotropic trend: + IF( ln_dynadv_vec .OR. ln_linssh ) THEN + DO jk=1,jpkm1 + puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) ) * r1_Dt_b + pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) ) * r1_Dt_b + END DO + ELSE + ! At this stage, pssh(:,:,:,Krhs) has been corrected: compute new depths at velocity points + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zsshu_a(ji,jj) = r1_2 * r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * pssh(ji ,jj,Kaa) & + & + e1e2t(ji+1,jj) * pssh(ji+1,jj,Kaa) ) * ssumask(ji,jj) + zsshv_a(ji,jj) = r1_2 * r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * pssh(ji,jj ,Kaa) & + & + e1e2t(ji,jj+1) * pssh(ji,jj+1,Kaa) ) * ssvmask(ji,jj) + END DO ; END DO + CALL lbc_lnk( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions + ! + DO jk=1,jpkm1 + puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm))) & + & * ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) * (hu_0(:,:)*(1._wp+r3u(:,:,Kbb))) ) * r1_Dt_b + pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm))) & + & * ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) * (hv_0(:,:)*(1._wp+r3v(:,:,Kbb))) ) * r1_Dt_b + END DO + ! Save barotropic velocities not transport: + puu_b(:,:,Kaa) = puu_b(:,:,Kaa) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - ssumask(:,:) ) + pvv_b(:,:,Kaa) = pvv_b(:,:,Kaa) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - ssvmask(:,:) ) + ENDIF + + + ! Correct velocities so that the barotropic velocity equals (un_adv, vn_adv) (in all cases) + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = ( puu(:,:,jk,Kmm) + un_adv(:,:)*(r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm))) - puu_b(:,:,Kmm) ) * umask(:,:,jk) + pvv(:,:,jk,Kmm) = ( pvv(:,:,jk,Kmm) + vn_adv(:,:)*(r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm))) - pvv_b(:,:,Kmm) ) * vmask(:,:,jk) + END DO + + IF ( ln_wd_dl .and. ln_wd_dl_bc) THEN + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = ( un_adv(:,:)*(r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm))) & + & + zuwdav2(:,:)*(puu(:,:,jk,Kmm) - un_adv(:,:)*(r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm)))) ) * umask(:,:,jk) + pvv(:,:,jk,Kmm) = ( vn_adv(:,:)*(r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm))) & + & + zvwdav2(:,:)*(pvv(:,:,jk,Kmm) - vn_adv(:,:)*(r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm)))) ) * vmask(:,:,jk) + END DO + END IF + + + CALL iom_put( "ubar", un_adv(:,:)*(r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm))) ) ! barotropic i-current + CALL iom_put( "vbar", vn_adv(:,:)*(r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm))) ) ! barotropic i-current + ! + ! !* write time-spliting arrays in the restart + IF( lrst_oce .AND.ln_bt_fw ) CALL ts_rst( kt, 'WRITE' ) + ! + IF( ln_wd_il ) DEALLOCATE( zcpx, zcpy ) + IF( ln_wd_dl ) DEALLOCATE( ztwdmask, zuwdmask, zvwdmask, zuwdav2, zvwdav2 ) + ! + CALL iom_put( "baro_u" , puu_b(:,:,Kmm) ) ! Barotropic U Velocity + CALL iom_put( "baro_v" , pvv_b(:,:,Kmm) ) ! Barotropic V Velocity + ! + END SUBROUTINE dyn_spg_ts + + + SUBROUTINE ts_wgt( ll_av, ll_fw, jpit, zwgt1, zwgt2) + !!--------------------------------------------------------------------- + !! *** ROUTINE ts_wgt *** + !! + !! ** Purpose : Set time-splitting weights for temporal averaging (or not) + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in) :: ll_av ! temporal averaging=.true. + LOGICAL, INTENT(in) :: ll_fw ! forward time splitting =.true. + INTEGER, INTENT(inout) :: jpit ! cycle length + REAL(wp), DIMENSION(3*nn_e), INTENT(inout) :: zwgt2 + REAL(dp), DIMENSION(3*nn_e), INTENT(inout) :: zwgt1 + + + INTEGER :: jic, jn, ji ! temporary integers + REAL(wp) :: za2 + REAL(dp) :: za1 + !!---------------------------------------------------------------------- + + zwgt1(:) = 0._wp + zwgt2(:) = 0._wp + + ! Set time index when averaged value is requested + IF (ll_fw) THEN + jic = nn_e + ELSE + jic = 2 * nn_e + ENDIF + + ! Set primary weights: + IF (ll_av) THEN + ! Define simple boxcar window for primary weights + ! (width = nn_e, centered around jic) + SELECT CASE ( nn_bt_flt ) + CASE( 0 ) ! No averaging + zwgt1(jic) = 1._wp + jpit = jic + + CASE( 1 ) ! Boxcar, width = nn_e + DO jn = 1, 3*nn_e + za1 = ABS(float(jn-jic))/float(nn_e) + IF (za1 < 0.5_wp) THEN + zwgt1(jn) = 1._wp + jpit = jn + ENDIF + ENDDO + + CASE( 2 ) ! Boxcar, width = 2 * nn_e + DO jn = 1, 3*nn_e + za1 = ABS(float(jn-jic))/float(nn_e) + IF (za1 < 1._wp) THEN + zwgt1(jn) = 1._wp + jpit = jn + ENDIF + ENDDO + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_bt_flt' ) + END SELECT + + ELSE ! No time averaging + zwgt1(jic) = 1._wp + jpit = jic + ENDIF + + ! Set secondary weights + DO jn = 1, jpit + DO ji = jn, jpit + zwgt2(jn) = zwgt2(jn) + zwgt1(ji) + END DO + END DO + + ! Normalize weigths: + za1 = 1._wp / SUM(zwgt1(1:jpit)) + za2 = 1._wp / SUM(zwgt2(1:jpit)) + DO jn = 1, jpit + zwgt1(jn) = zwgt1(jn) * za1 + zwgt2(jn) = zwgt2(jn) * za2 + END DO + ! + END SUBROUTINE ts_wgt + + + SUBROUTINE ts_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE ts_rst *** + !! + !! ** Purpose : Read or write time-splitting arrays in restart file + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + ! ! --------------- + IF( ln_rstart .AND. ln_bt_fw .AND. .NOT.l_1st_euler ) THEN !* Read the restart file + CALL iom_get( numror, jpdom_auto, 'ub2_b' , ub2_b (:,:), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vb2_b' , vb2_b (:,:), cd_type = 'V', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'un_bf' , un_bf (:,:), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vn_bf' , vn_bf (:,:), cd_type = 'V', psgn = -1._dp ) + IF( .NOT.ln_bt_av ) THEN + CALL iom_get( numror, jpdom_auto, 'sshbb_e' , sshbb_e(:,:), cd_type = 'T', psgn = 1._dp ) + CALL iom_get( numror, jpdom_auto, 'ubb_e' , ubb_e(:,:), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vbb_e' , vbb_e(:,:), cd_type = 'V', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'sshb_e' , sshb_e(:,:), cd_type = 'T', psgn = 1._dp ) + CALL iom_get( numror, jpdom_auto, 'ub_e' , ub_e(:,:), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vb_e' , vb_e(:,:), cd_type = 'V', psgn = -1._dp ) + ENDIF + ELSE !* Start from rest + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> start from rest: set barotropic values to 0' + ub2_b (:,:) = 0._wp ; vb2_b (:,:) = 0._wp ! used in the 1st interpol of agrif + un_adv (:,:) = 0._wp ; vn_adv (:,:) = 0._wp ! used in the 1st interpol of agrif + un_bf (:,:) = 0._wp ; vn_bf (:,:) = 0._wp ! used in the 1st update of agrif + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) '---- ts_rst ----' + CALL iom_rstput( kt, nitrst, numrow, 'ub2_b' , ub2_b (:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'vb2_b' , vb2_b (:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'un_bf' , un_bf (:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'vn_bf' , vn_bf (:,:) ) + ! + IF (.NOT.ln_bt_av) THEN + CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e' , sshbb_e(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'ubb_e' , ubb_e(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'vbb_e' , vbb_e(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'sshb_e' , sshb_e(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'ub_e' , ub_e(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'vb_e' , vb_e(:,:) ) + ENDIF + ENDIF + ! + END SUBROUTINE ts_rst + + + SUBROUTINE dyn_spg_ts_init + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_spg_ts_init *** + !! + !! ** Purpose : Set time splitting options + !!---------------------------------------------------------------------- + INTEGER :: ji ,jj ! dummy loop indices + REAL(wp) :: zxr2, zyr2, zcmax ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zcu + !!---------------------------------------------------------------------- + ! + ! Max courant number for ext. grav. waves + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zxr2 = r1_e1t(ji,jj) * r1_e1t(ji,jj) + zyr2 = r1_e2t(ji,jj) * r1_e2t(ji,jj) + zcu(ji,jj) = SQRT( grav * MAX(ht_0(ji,jj),0._wp) * (zxr2 + zyr2) ) + END DO ; END DO + ! + zcmax = MAXVAL( zcu(Nis0:Nie0,Njs0:Nje0) ) + CALL mpp_max( 'dynspg_ts', zcmax ) + + ! Estimate number of iterations to satisfy a max courant number= rn_bt_cmax + IF( ln_bt_auto ) nn_e = CEILING( rn_Dt / rn_bt_cmax * zcmax) + + rDt_e = rn_Dt / REAL( nn_e , dp ) + zcmax = zcmax * rDt_e + ! Print results + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_spg_ts_init : split-explicit free surface' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~' + IF( ln_bt_auto ) THEN + IF(lwp) WRITE(numout,*) ' ln_ts_auto =.true. Automatically set nn_e ' + IF(lwp) WRITE(numout,*) ' Max. courant number allowed: ', rn_bt_cmax + ELSE + IF(lwp) WRITE(numout,*) ' ln_ts_auto=.false.: Use nn_e in namelist nn_e = ', nn_e + ENDIF + + IF(ln_bt_av) THEN + IF(lwp) WRITE(numout,*) ' ln_bt_av =.true. ==> Time averaging over nn_e time steps is on ' + ELSE + IF(lwp) WRITE(numout,*) ' ln_bt_av =.false. => No time averaging of barotropic variables ' + ENDIF + ! + ! + IF(ln_bt_fw) THEN + IF(lwp) WRITE(numout,*) ' ln_bt_fw=.true. => Forward integration of barotropic variables ' + ELSE + IF(lwp) WRITE(numout,*) ' ln_bt_fw =.false.=> Centred integration of barotropic variables ' + ENDIF + ! + ! + IF(lwp) WRITE(numout,*) ' Time filter choice, nn_bt_flt: ', nn_bt_flt + SELECT CASE ( nn_bt_flt ) + CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' Dirac' + CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Boxcar: width = nn_e' + CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' Boxcar: width = 2*nn_e' + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_bt_flt: should 0,1, or 2' ) + END SELECT + ! + IF(lwp) WRITE(numout,*) ' ' + IF(lwp) WRITE(numout,*) ' nn_e = ', nn_e + IF(lwp) WRITE(numout,*) ' Barotropic time step [s] is :', rDt_e + IF(lwp) WRITE(numout,*) ' Maximum Courant number is :', zcmax + ! + IF(lwp) WRITE(numout,*) ' Time diffusion parameter rn_bt_alpha: ', rn_bt_alpha + IF ((ln_bt_av.AND.nn_bt_flt/=0).AND.(rn_bt_alpha>0._wp)) THEN + CALL ctl_stop( 'dynspg_ts ERROR: if rn_bt_alpha > 0, remove temporal averaging' ) + ENDIF + ! + IF( .NOT.ln_bt_av .AND. .NOT.ln_bt_fw ) THEN + CALL ctl_stop( 'dynspg_ts ERROR: No time averaging => only forward integration is possible' ) + ENDIF + IF( zcmax>0.9_wp ) THEN + CALL ctl_stop( 'dynspg_ts ERROR: Maximum Courant number is greater than 0.9: Inc. nn_e !' ) + ENDIF + ! + ! ! Allocate time-splitting arrays + IF( dyn_spg_ts_alloc() /= 0 ) CALL ctl_stop('STOP', 'dyn_spg_init: failed to allocate dynspg_ts arrays' ) + ! + ! ! read restart when needed + CALL ts_rst( nit000, 'READ' ) + ! + END SUBROUTINE dyn_spg_ts_init + + + SUBROUTINE dyn_cor_2D_init( Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_cor_2D_init *** + !! + !! ** Purpose : Set time splitting options + !! Set arrays to remove/compute coriolis trend. + !! Do it once during initialization if volume is fixed, else at each long time step. + !! Note that these arrays are also used during barotropic loop. These are however frozen + !! although they should be updated in the variable volume case. Not a big approximation. + !! To remove this approximation, copy lines below inside barotropic loop + !! and update depths at T- points (ht) at each barotropic time step + !! + !! Compute zwz = f / ( height of the water colomn ) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! Time index + INTEGER :: ji ,jj, jk ! dummy loop indices + REAL(wp) :: z1_ht + !!---------------------------------------------------------------------- + ! + SELECT CASE( nvor_scheme ) + CASE( np_EEN, np_ENE, np_ENS , np_MIX ) != schemes using the same e3f definition + SELECT CASE( nn_e3f_typ ) !* ff_f/e3 at F-point + CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zwz(ji,jj) = ( (ht_0(ji,jj+1)*(1._wp+r3t(ji,jj+1,Kmm))) + (ht_0(ji+1,jj+1)*(1._wp+r3t(ji+1,jj+1,Kmm))) & + & + (ht_0(ji,jj )*(1._wp+r3t(ji,jj ,Kmm))) + (ht_0(ji+1,jj )*(1._wp+r3t(ji+1,jj ,Kmm))) ) * 0.25_wp + IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) + END DO ; END DO + CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zwz(ji,jj) = ( (ht_0(ji,jj+1)*(1._wp+r3t(ji,jj+1,Kmm))) + (ht_0(ji+1,jj+1)*(1._wp+r3t(ji+1,jj+1,Kmm))) & + & + (ht_0(ji,jj )*(1._wp+r3t(ji,jj ,Kmm))) + (ht_0(ji+1,jj )*(1._wp+r3t(ji+1,jj ,Kmm))) ) & + & / ( MAX(ssmask(ji,jj+1) + ssmask(ji+1,jj+1) & + & + ssmask(ji,jj ) + ssmask(ji+1,jj ) , 1._wp ) ) + IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) + END DO ; END DO + END SELECT + CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) + END SELECT + ! + SELECT CASE( nvor_scheme ) + CASE( np_EEN ) + ! + ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1) + ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj ) + ftse(ji,jj) = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1) + ftsw(ji,jj) = zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj ) + END DO ; END DO + ! + CASE( np_EET ) != EEN scheme using e3t energy conserving scheme + ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + z1_ht = ssmask(ji,jj) / ( (ht_0(ji,jj)*(1._wp+r3t(ji,jj,Kmm))) + 1._wp - ssmask(ji,jj) ) + ftne(ji,jj) = ( ff_f(ji-1,jj ) + ff_f(ji ,jj ) + ff_f(ji ,jj-1) ) * z1_ht + ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) + ff_f(ji ,jj ) ) * z1_ht + ftse(ji,jj) = ( ff_f(ji ,jj ) + ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht + ftsw(ji,jj) = ( ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) ) * z1_ht + END DO ; END DO + ! + END SELECT + + END SUBROUTINE dyn_cor_2d_init + + + SUBROUTINE dyn_cor_2d( pht, phu, phv, punb, pvnb, zhU, zhV, zu_trd, zv_trd ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_cor_2d *** + !! + !! ** Purpose : Compute u and v coriolis trends + !!---------------------------------------------------------------------- + INTEGER :: ji ,jj ! dummy loop indices + REAL(wp) :: zx1, zx2, zy1, zy2, z1_hu, z1_hv ! - - + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pht, phu, phv, punb, pvnb, zhV + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: zhU + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: zu_trd, zv_trd + !!---------------------------------------------------------------------- + SELECT CASE( nvor_scheme ) + CASE( np_ENT ) ! enstrophy conserving scheme (f-point) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + z1_hu = ssumask(ji,jj) / ( phu(ji,jj) + 1._wp - ssumask(ji,jj) ) + z1_hv = ssvmask(ji,jj) / ( phv(ji,jj) + 1._wp - ssvmask(ji,jj) ) + zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu & + & * ( e1e2t(ji+1,jj)*pht(ji+1,jj)*ff_t(ji+1,jj) * ( pvnb(ji+1,jj) + pvnb(ji+1,jj-1) ) & + & + e1e2t(ji ,jj)*pht(ji ,jj)*ff_t(ji ,jj) * ( pvnb(ji ,jj) + pvnb(ji ,jj-1) ) ) + ! + zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv & + & * ( e1e2t(ji,jj+1)*pht(ji,jj+1)*ff_t(ji,jj+1) * ( punb(ji,jj+1) + punb(ji-1,jj+1) ) & + & + e1e2t(ji,jj )*pht(ji,jj )*ff_t(ji,jj ) * ( punb(ji,jj ) + punb(ji-1,jj ) ) ) + END DO ; END DO + ! + CASE( np_ENE , np_MIX ) ! energy conserving scheme (t-point) ENE or MIX + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) + zy2 = ( zhV(ji,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) + zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) + zx2 = ( zhU(ji ,jj) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) + ! energy conserving formulation for planetary vorticity term + zu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) + zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) + END DO ; END DO + ! + CASE( np_ENS ) ! enstrophy conserving scheme (f-point) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zy1 = r1_8 * ( zhV(ji ,jj-1) + zhV(ji+1,jj-1) & + & + zhV(ji ,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) + zx1 = - r1_8 * ( zhU(ji-1,jj ) + zhU(ji-1,jj+1) & + & + zhU(ji ,jj ) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) + zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) + zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) + END DO ; END DO + ! + CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zhV(ji ,jj ) & + & + ftnw(ji+1,jj) * zhV(ji+1,jj ) & + & + ftse(ji,jj ) * zhV(ji ,jj-1) & + & + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) + zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zhU(ji-1,jj+1) & + & + ftse(ji,jj+1) * zhU(ji ,jj+1) & + & + ftnw(ji,jj ) * zhU(ji-1,jj ) & + & + ftne(ji,jj ) * zhU(ji ,jj ) ) + END DO ; END DO + ! + END SELECT + ! + END SUBROUTINE dyn_cor_2D + + + SUBROUTINE wad_tmsk( pssh, ptmsk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wad_lmt *** + !! + !! ** Purpose : set wetting & drying mask at tracer points + !! for the current barotropic sub-step + !! + !! ** Method : ??? + !! + !! ** Action : ptmsk : wetting & drying t-mask + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh ! + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: ptmsk ! + ! + INTEGER :: ji, jj ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( ln_wd_dl_rmp ) THEN + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + IF ( pssh(ji,jj) + ht_0(ji,jj) > 2._wp * rn_wdmin1 ) THEN + ! IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin2 ) THEN + ptmsk(ji,jj) = 1._wp + ELSEIF( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN + ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) - rn_wdmin1 )*r_rn_wdmin1) ) + ELSE + ptmsk(ji,jj) = 0._wp + ENDIF + END DO ; END DO + ELSE + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN ; ptmsk(ji,jj) = 1._wp + ELSE ; ptmsk(ji,jj) = 0._wp + ENDIF + END DO ; END DO + ENDIF + ! + END SUBROUTINE wad_tmsk + + + SUBROUTINE wad_Umsk( pTmsk, phU, phV, pu, pv, pUmsk, pVmsk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wad_lmt *** + !! + !! ** Purpose : set wetting & drying mask at tracer points + !! for the current barotropic sub-step + !! + !! ** Method : ??? + !! + !! ** Action : ptmsk : wetting & drying t-mask + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pTmsk ! W & D t-mask + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phV, pu, pv! ocean velocities and transports + REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: phU! ocean velocities and transports + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pUmsk, pVmsk ! W & D u- and v-mask + ! + INTEGER :: ji, jj ! dummy loop indices + !!---------------------------------------------------------------------- + ! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 0) ! not jpi-column + IF ( phU(ji,jj) > 0._wp ) THEN ; pUmsk(ji,jj) = pTmsk(ji ,jj) + ELSE ; pUmsk(ji,jj) = pTmsk(ji+1,jj) + ENDIF + phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) + pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) + END DO ; END DO + ! + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 1) ! not jpj-row + IF ( phV(ji,jj) > 0._wp ) THEN ; pVmsk(ji,jj) = pTmsk(ji,jj ) + ELSE ; pVmsk(ji,jj) = pTmsk(ji,jj+1) + ENDIF + phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj) + pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) + END DO ; END DO + ! + END SUBROUTINE wad_Umsk + + + SUBROUTINE wad_spg( pshn, zcpx, zcpy ) + !!--------------------------------------------------------------------- + !! *** ROUTINE wad_sp *** + !! + !! ** Purpose : + !!---------------------------------------------------------------------- + INTEGER :: ji ,jj ! dummy loop indices + LOGICAL :: ll_tmp1, ll_tmp2 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pshn + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy + !!---------------------------------------------------------------------- + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ll_tmp1 = MIN( pshn(ji,jj) , pshn(ji+1,jj) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( pshn(ji,jj) + ht_0(ji,jj) , pshn(ji+1,jj) + ht_0(ji+1,jj) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( pshn(ji+1,jj) - pshn(ji ,jj)) > 1.E-12 ).AND.( & + & MAX( pshn(ji,jj) , pshn(ji+1,jj) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) + IF(ll_tmp1) THEN + zcpx(ji,jj) = 1.0_wp + ELSEIF(ll_tmp2) THEN + ! no worries about pshn(ji+1,jj) - pshn(ji ,jj) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (pshn(ji+1,jj) + ht_0(ji+1,jj) - pshn(ji,jj) - ht_0(ji,jj)) & + & / (pshn(ji+1,jj) - pshn(ji ,jj)) ) + zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) + ELSE + zcpx(ji,jj) = 0._wp + ENDIF + ! + ll_tmp1 = MIN( pshn(ji,jj) , pshn(ji,jj+1) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( pshn(ji,jj) + ht_0(ji,jj) , pshn(ji,jj+1) + ht_0(ji,jj+1) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( pshn(ji,jj) - pshn(ji,jj+1)) > 1.E-12 ).AND.( & + & MAX( pshn(ji,jj) , pshn(ji,jj+1) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpy(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about pshn(ji,jj+1) - pshn(ji,jj ) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (pshn(ji,jj+1) + ht_0(ji,jj+1) - pshn(ji,jj) - ht_0(ji,jj)) & + & / (pshn(ji,jj+1) - pshn(ji,jj )) ) + zcpy(ji,jj) = MAX( 0._wp , MIN( zcpy(ji,jj) , 1.0_wp ) ) + ELSE + zcpy(ji,jj) = 0._wp + ENDIF + END DO ; END DO + + END SUBROUTINE wad_spg + + + SUBROUTINE dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b ,pvv_b, pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_drg_init *** + !! + !! ** Purpose : - add the baroclinic top/bottom drag contribution to + !! the baroclinic part of the barotropic RHS + !! - compute the barotropic drag coefficients + !! + !! ** Method : computation done over the INNER domain only + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(in ) :: puu, pvv ! ocean velocities and RHS of momentum equation + REAL(wp), DIMENSION(jpi,jpj,jpt) , INTENT(in ) :: puu_b, pvv_b ! barotropic velocities at main time levels + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: pu_RHSi, pv_RHSi ! baroclinic part of the barotropic RHS + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pCdU_u , pCdU_v ! barotropic drag coefficients + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ikbu, ikbv, iktu, iktv + REAL(wp) :: zztmp + REAL(wp), DIMENSION(jpi,jpj) :: zu_i, zv_i + !!---------------------------------------------------------------------- + ! + ! !== Set the barotropic drag coef. ==! + ! + IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! top+bottom friction (ocean cavities) + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) + pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) + END DO ; END DO + ELSE ! bottom friction only + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) + pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) + END DO ; END DO + ENDIF + ! + ! !== BOTTOM stress contribution from baroclinic velocities ==! + ! + IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW bottom baroclinic velocities + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ikbu = mbku(ji,jj) + ikbv = mbkv(ji,jj) + zu_i(ji,jj) = puu(ji,jj,ikbu,Kmm) - puu_b(ji,jj,Kmm) + zv_i(ji,jj) = pvv(ji,jj,ikbv,Kmm) - pvv_b(ji,jj,Kmm) + END DO ; END DO + ELSE ! CENTRED integration: use BEFORE bottom baroclinic velocities + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ikbu = mbku(ji,jj) + ikbv = mbkv(ji,jj) + zu_i(ji,jj) = puu(ji,jj,ikbu,Kbb) - puu_b(ji,jj,Kbb) + zv_i(ji,jj) = pvv(ji,jj,ikbv,Kbb) - pvv_b(ji,jj,Kbb) + END DO ; END DO + ENDIF + ! + IF( ln_wd_il ) THEN ! W/D : use the "clipped" bottom friction !!gm explain WHY, please ! + zztmp = -1._wp / rDt_e + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) * wdrampu(ji,jj) * MAX( & + & (r1_hu_0(ji,jj)/(1._wp+r3u(ji,jj,Kmm))) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp ) + pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) * wdrampv(ji,jj) * MAX( & + & (r1_hv_0(ji,jj)/(1._wp+r3v(ji,jj,Kmm))) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp ) + END DO ; END DO + ELSE ! use "unclipped" drag (even if explicit friction is used in 3D calculation) + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + (r1_hu_0(ji,jj)/(1._wp+r3u(ji,jj,Kmm))) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) + pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + (r1_hv_0(ji,jj)/(1._wp+r3v(ji,jj,Kmm))) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) + END DO ; END DO + END IF + ! + ! !== TOP stress contribution from baroclinic velocities ==! (no W/D case) + ! + IF( ln_isfcav.OR.ln_drgice_imp ) THEN + ! + IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW top baroclinic velocity + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + iktu = miku(ji,jj) + iktv = mikv(ji,jj) + zu_i(ji,jj) = puu(ji,jj,iktu,Kmm) - puu_b(ji,jj,Kmm) + zv_i(ji,jj) = pvv(ji,jj,iktv,Kmm) - pvv_b(ji,jj,Kmm) + END DO ; END DO + ELSE ! CENTRED integration: use BEFORE top baroclinic velocity + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + iktu = miku(ji,jj) + iktv = mikv(ji,jj) + zu_i(ji,jj) = puu(ji,jj,iktu,Kbb) - puu_b(ji,jj,Kbb) + zv_i(ji,jj) = pvv(ji,jj,iktv,Kbb) - pvv_b(ji,jj,Kbb) + END DO ; END DO + ENDIF + ! + ! ! use "unclipped" top drag (even if explicit friction is used in 3D calculation) + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + (r1_hu_0(ji,jj)/(1._wp+r3u(ji,jj,Kmm))) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) + pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + (r1_hv_0(ji,jj)/(1._wp+r3v(ji,jj,Kmm))) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) + END DO ; END DO + ! + ENDIF + ! + END SUBROUTINE dyn_drg_init + + SUBROUTINE ts_bck_interp( jn, ll_init, & ! <== in + & za0, za1, za2, za3 ) ! ==> out + !!---------------------------------------------------------------------- + INTEGER ,INTENT(in ) :: jn ! index of sub time step + LOGICAL ,INTENT(in ) :: ll_init ! + REAL(wp),INTENT( out) :: za0, za2, za3! Half-step back interpolation coefficient + REAL(dp),INTENT( out) :: za1! Half-step back interpolation coefficient + ! + REAL(wp) :: zepsilon, zgamma ! - - + !!---------------------------------------------------------------------- + ! ! set Half-step back interpolation coefficient + IF ( jn==1 .AND. ll_init ) THEN !* Forward-backward + za0 = 1._wp + za1 = 0._wp + za2 = 0._wp + za3 = 0._wp + ELSEIF( jn==2 .AND. ll_init ) THEN !* AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 + za0 = 1.0833333333333_wp ! za0 = 1-gam-eps + za1 =-0.1666666666666_wp ! za1 = gam + za2 = 0.0833333333333_wp ! za2 = eps + za3 = 0._wp + ELSE !* AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880 + IF( rn_bt_alpha == 0._wp ) THEN ! Time diffusion + za0 = 0.614_wp ! za0 = 1/2 + gam + 2*eps + za1 = 0.285_wp ! za1 = 1/2 - 2*gam - 3*eps + za2 = 0.088_wp ! za2 = gam + za3 = 0.013_wp ! za3 = eps + ELSE ! no time diffusion + zepsilon = 0.00976186_wp - 0.13451357_wp * rn_bt_alpha + zgamma = 0.08344500_wp - 0.51358400_wp * rn_bt_alpha + za0 = 0.5_wp + zgamma + 2._wp * rn_bt_alpha + 2._wp * zepsilon + za1 = 1._wp - za0 - zgamma - zepsilon + za2 = zgamma + za3 = zepsilon + ENDIF + ENDIF + END SUBROUTINE ts_bck_interp + + + !!====================================================================== +END MODULE dynspg_ts diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynvor.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynvor.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3d8d41e71213ab3a5b02bfb2a24e75b1c48acbd1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynvor.f90 @@ -0,0 +1,986 @@ + + + + + + + + + + + + + +MODULE dynvor + !!====================================================================== + !! *** MODULE dynvor *** + !! Ocean dynamics: Update the momentum trend with the relative and + !! planetary vorticity trends + !!====================================================================== + !! History : OPA ! 1989-12 (P. Andrich) vor_ens: Original code + !! 5.0 ! 1991-11 (G. Madec) vor_ene, vor_mix: Original code + !! 6.0 ! 1996-01 (G. Madec) s-coord, suppress work arrays + !! NEMO 0.5 ! 2002-08 (G. Madec) F90: Free form and module + !! 1.0 ! 2004-02 (G. Madec) vor_een: Original code + !! - ! 2003-08 (G. Madec) add vor_ctl + !! - ! 2005-11 (G. Madec) add dyn_vor (new step architecture) + !! 2.0 ! 2006-11 (G. Madec) flux form advection: add metric term + !! 3.2 ! 2009-04 (R. Benshila) vvl: correction of een scheme + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.7 ! 2014-04 (G. Madec) trend simplification: suppress jpdyn_trd_dat vorticity + !! - ! 2014-06 (G. Madec) suppression of velocity curl from in-core memory + !! - ! 2016-12 (G. Madec, E. Clementi) add Stokes-Coriolis trends (ln_stcor=T) + !! 4.0 ! 2017-07 (G. Madec) linear dynamics + trends diag. with Stokes-Coriolis + !! - ! 2018-03 (G. Madec) add two new schemes (ln_dynvor_enT and ln_dynvor_eet) + !! - ! 2018-04 (G. Madec) add pre-computed gradient for metric term calculation + !! 4.x ! 2020-03 (G. Madec, A. Nasser) make ln_dynvor_msk truly efficient on relative vorticity + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) add vortex force trends (ln_vortex_force=T) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_vor : Update the momentum trend with the vorticity trend + !! vor_enT : energy conserving scheme at T-pt (ln_dynvor_enT=T) + !! vor_ene : energy conserving scheme (ln_dynvor_ene=T) + !! vor_ens : enstrophy conserving scheme (ln_dynvor_ens=T) + !! vor_een : energy and enstrophy conserving (ln_dynvor_een=T) + !! vor_eeT : energy conserving at T-pt (ln_dynvor_eeT=T) + !! dyn_vor_init : set and control of the different vorticity option + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE dommsk ! ocean mask + USE dynadv ! momentum advection + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + USE sbcwave ! Surface Waves (add Stokes-Coriolis force) + USE sbc_oce, ONLY : ln_stcor, ln_vortex_force ! use Stoke-Coriolis force + ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_vor ! routine called by step.F90 + PUBLIC dyn_vor_init ! routine called by nemogcm.F90 + + ! !!* Namelist namdyn_vor: vorticity term + LOGICAL, PUBLIC :: ln_dynvor_ens !: enstrophy conserving scheme (ENS) + LOGICAL, PUBLIC :: ln_dynvor_ene !: f-point energy conserving scheme (ENE) + LOGICAL, PUBLIC :: ln_dynvor_enT !: t-point energy conserving scheme (ENT) + LOGICAL, PUBLIC :: ln_dynvor_eeT !: t-point energy conserving scheme (EET) + LOGICAL, PUBLIC :: ln_dynvor_een !: energy & enstrophy conserving scheme (EEN) + LOGICAL, PUBLIC :: ln_dynvor_mix !: mixed scheme (MIX) + LOGICAL, PUBLIC :: ln_dynvor_msk !: vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes) + INTEGER, PUBLIC :: nn_e3f_typ !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) + + INTEGER, PUBLIC :: nvor_scheme !: choice of the type of advection scheme + ! ! associated indices: + INTEGER, PUBLIC, PARAMETER :: np_ENS = 0 ! ENS scheme + INTEGER, PUBLIC, PARAMETER :: np_ENE = 1 ! ENE scheme + INTEGER, PUBLIC, PARAMETER :: np_ENT = 2 ! ENT scheme (t-point vorticity) + INTEGER, PUBLIC, PARAMETER :: np_EET = 3 ! EET scheme (EEN using e3t) + INTEGER, PUBLIC, PARAMETER :: np_EEN = 4 ! EEN scheme + INTEGER, PUBLIC, PARAMETER :: np_MIX = 5 ! MIX scheme + + INTEGER :: ncor, nrvm, ntot ! choice of calculated vorticity + ! ! associated indices: + INTEGER, PUBLIC, PARAMETER :: np_COR = 1 ! Coriolis (planetary) + INTEGER, PUBLIC, PARAMETER :: np_RVO = 2 ! relative vorticity + INTEGER, PUBLIC, PARAMETER :: np_MET = 3 ! metric term + INTEGER, PUBLIC, PARAMETER :: np_CRV = 4 ! relative + planetary (total vorticity) + INTEGER, PUBLIC, PARAMETER :: np_CME = 5 ! Coriolis + metric term + + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2u_2 ! = di(e2u)/2 used in T-point metric term calculation + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1v_2 ! = dj(e1v)/2 - - - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2u)/(2*e1e2f) used in F-point metric term calculation + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1v)/(2*e1e2f) - - - - + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: e3f_0vor ! e3f used in EEN, ENE and ENS cases (1 only) + + REAL(wp) :: r1_4 = 0.250_wp ! =1/4 + REAL(wp) :: r1_8 = 0.125_wp ! =1/8 + REAL(wp) :: r1_12 = 1._wp / 12._wp ! 1/12 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynvor.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_vor( kt, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! + !! ** Purpose : compute the lateral ocean tracer physics. + !! + !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now vorticity term trend + !! - save the trends in (ztrdu,ztrdv) in 2 parts (relative + !! and planetary vorticity trends) and send them to trd_dyn + !! for futher diagnostics (l_trddyn=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocity field and RHS of momentum equation + ! + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_vor') + ! + IF( l_trddyn ) THEN !== trend diagnostics case : split the added trend in two parts ==! + ! + ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) + ! + ztrdu(:,:,:) = puu(:,:,:,Krhs) !* planetary vorticity trend + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + SELECT CASE( nvor_scheme ) + CASE( np_ENS ) ; CALL vor_ens( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! enstrophy conserving scheme + CASE( np_ENE, np_MIX ) ; CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme + CASE( np_ENT ) ; CALL vor_enT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (T-pts) + CASE( np_EET ) ; CALL vor_eeT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (een with e3t) + CASE( np_EEN ) ; CALL vor_een( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy & enstrophy scheme + END SELECT + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt, Kmm ) + ! + IF( n_dynadv /= np_LIN_dyn ) THEN !* relative vorticity or metric trend (only in non-linear case) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + SELECT CASE( nvor_scheme ) + CASE( np_ENT ) ; CALL vor_enT( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (T-pts) + CASE( np_EET ) ; CALL vor_eeT( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (een with e3t) + CASE( np_ENE ) ; CALL vor_ene( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme + CASE( np_ENS, np_MIX ) ; CALL vor_ens( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! enstrophy conserving scheme + CASE( np_EEN ) ; CALL vor_een( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy & enstrophy scheme + END SELECT + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt, Kmm ) + ENDIF + ! + DEALLOCATE( ztrdu, ztrdv ) + ! + ELSE !== total vorticity trend added to the general trend ==! + ! + SELECT CASE ( nvor_scheme ) !== vorticity trend added to the general trend ==! + CASE( np_ENT ) !* energy conserving scheme (T-pts) + CALL vor_enT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend + IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN + CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN + CALL vor_enT( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force + ENDIF + CASE( np_EET ) !* energy conserving scheme (een scheme using e3t) + CALL vor_eeT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend + IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN + CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN + CALL vor_eeT( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force + ENDIF + CASE( np_ENE ) !* energy conserving scheme + CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend + IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN + CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN + CALL vor_ene( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force + ENDIF + CASE( np_ENS ) !* enstrophy conserving scheme + CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend + + IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN + CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN + CALL vor_ens( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force + ENDIF + CASE( np_MIX ) !* mixed ene-ens scheme + CALL vor_ens( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! relative vorticity or metric trend (ens) + CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! planetary vorticity trend (ene) + IF( ln_stcor ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + IF( ln_vortex_force ) CALL vor_ens( kt, Kmm, nrvm, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add vortex force + CASE( np_EEN ) !* energy and enstrophy conserving scheme + CALL vor_een( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend + IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN + CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN + CALL vor_een( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force + ENDIF + END SELECT + ! + ENDIF + ! + ! ! print sum trends (used for debugging) + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' vor - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_vor') + ! + END SUBROUTINE dyn_vor + + + SUBROUTINE vor_enT( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE vor_enT *** + !! + !! ** Purpose : Compute the now total vorticity trend and add it to + !! the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! and t-point evaluation of vorticity (planetary and relative). + !! conserves the horizontal kinetic energy. + !! The general trend of momentum is increased due to the vorticity + !! term which is given by: + !! voru = 1/bu mj[ ( mi(mj(bf*rvor))+bt*f_t)/e3t mj[vn] ] + !! vorv = 1/bv mi[ ( mi(mj(bf*rvor))+bt*f_t)/e3f mj[un] ] + !! where rvor is the relative vorticity at f-point + !! + !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zwx, zwy, zwt ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_enT : vorticity term: t-point energy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! + SELECT CASE( kvor ) !== relative vorticity considered ==! + ! + CASE ( np_RVO , np_CRV ) !* relative vorticity at f-point is used + ALLOCATE( zwz(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) ) + DO jk = 1, jpkm1 ! Horizontal slab + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END DO ; END DO + IF( ln_dynvor_msk ) THEN ! mask relative vorticity + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) + END DO ; END DO + ENDIF + END DO + IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) + ! + END SELECT + + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + SELECT CASE( kvor ) !== volume weighted vorticity considered ==! + ! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + zwt(ji,jj) = ff_t(ji,jj) * e1e2t(ji,jj)*(e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO + CASE ( np_RVO ) !* relative vorticity + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + zwt(ji,jj) = r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & + & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) & + & * e1e2t(ji,jj)*(e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO + CASE ( np_MET ) !* metric term + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & + & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & + & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) & + & * e1e2t(ji,jj)*(e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO + CASE ( np_CME ) !* Coriolis + metric + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) & + & + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & + & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO + CASE DEFAULT ! error + CALL ctl_stop('STOP','dyn_vor: wrong value for kvor') + END SELECT + ! + ! !== compute and add the vorticity term trend =! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1e2u(ji,jj) / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) & + & * ( zwt(ji+1,jj) * ( pv(ji+1,jj,jk) + pv(ji+1,jj-1,jk) ) & + & + zwt(ji ,jj) * ( pv(ji ,jj,jk) + pv(ji ,jj-1,jk) ) ) + ! + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e1e2v(ji,jj) / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) & + & * ( zwt(ji,jj+1) * ( pu(ji,jj+1,jk) + pu(ji-1,jj+1,jk) ) & + & + zwt(ji,jj ) * ( pu(ji,jj ,jk) + pu(ji-1,jj ,jk) ) ) + END DO ; END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + ! + SELECT CASE( kvor ) ! deallocate zwz if necessary + CASE ( np_RVO , np_CRV ) ; DEALLOCATE( zwz ) + END SELECT + ! + END SUBROUTINE vor_enT + + + SUBROUTINE vor_ene( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE vor_ene *** + !! + !! ** Purpose : Compute the now total vorticity trend and add it to + !! the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! and the Sadourny (1975) flux form formulation : conserves the + !! horizontal kinetic energy. + !! The general trend of momentum is increased due to the vorticity + !! term which is given by: + !! voru = 1/e1u mj-1[ (rvor+f)/e3f mi(e1v*e3v pvv(:,:,:,Kmm)) ] + !! vorv = 1/e2v mi-1[ (rvor+f)/e3f mj(e2u*e3u puu(:,:,:,Kmm)) ] + !! where rvor is the relative vorticity + !! + !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend + !! + !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zx1, zy1, zx2, zy2, ze3f, zmsk ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zwx, zwy, zwz ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_ene : vorticity term: energy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ff_f(ji,jj) + END DO ; END DO + CASE ( np_RVO ) !* relative vorticity + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END DO ; END DO + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) + END DO ; END DO + ENDIF + CASE ( np_MET ) !* metric term + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END DO ; END DO + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ff_f(ji,jj) + ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END DO ; END DO + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term) + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) + END DO ; END DO + ENDIF + CASE ( np_CME ) !* Coriolis + metric + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END DO ; END DO + CASE DEFAULT ! error + CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' ) + END SELECT + ! + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) !== potential vorticity ==! (1) + zwz(ji,jj) = zwz(ji,jj) / (e3f_0vor(ji,jj,jk)*(1._wp+r3f(ji,jj)*fe3mask(ji,jj,jk))) + END DO ; END DO + ! !== horizontal fluxes ==! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zwx(ji,jj) = e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * pu(ji,jj,jk) + zwy(ji,jj) = e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * pv(ji,jj,jk) + END DO ; END DO + ! + ! !== compute and add the vorticity term trend =! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1) + zy2 = zwy(ji,jj ) + zwy(ji+1,jj ) + zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1) + zx2 = zwx(ji ,jj) + zwx(ji ,jj+1) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) + END DO ; END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + END SUBROUTINE vor_ene + + + SUBROUTINE vor_ens( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE vor_ens *** + !! + !! ** Purpose : Compute the now total vorticity trend and add it to + !! the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! and the Sadourny (1975) flux FORM formulation : conserves the + !! potential enstrophy of a horizontally non-divergent flow. the + !! trend of the vorticity term is given by: + !! voru = 1/e1u mj-1[ (rvor+f)/e3f ] mj-1[ mi(e1v*e3v pvv(:,:,:,Kmm)) ] + !! vorv = 1/e2v mi-1[ (rvor+f)/e3f ] mi-1[ mj(e2u*e3u puu(:,:,:,Kmm)) ] + !! Add this trend to the general momentum trend: + !! (u(rhs),v(Krhs)) = (u(rhs),v(Krhs)) + ( voru , vorv ) + !! + !! ** Action : - Update (pu_rhs,pv_rhs)) arrays with the now vorticity term trend + !! + !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zuav, zvau, ze3f, zmsk ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zwx, zwy, zwz ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_ens : vorticity term: enstrophy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ff_f(ji,jj) + END DO ; END DO + CASE ( np_RVO ) !* relative vorticity + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END DO ; END DO + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) + END DO ; END DO + ENDIF + CASE ( np_MET ) !* metric term + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END DO ; END DO + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ff_f(ji,jj) + ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END DO ; END DO + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term) + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) + END DO ; END DO + ENDIF + CASE ( np_CME ) !* Coriolis + metric + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zwz(ji,jj) = ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END DO ; END DO + CASE DEFAULT ! error + CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' ) + END SELECT + ! + ! + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) !== potential vorticity ==! (1) + zwz(ji,jj) = zwz(ji,jj) / (e3f_0vor(ji,jj,jk)*(1._wp+r3f(ji,jj)*fe3mask(ji,jj,jk))) + END DO ; END DO + ! !== horizontal fluxes ==! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zwx(ji,jj) = e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * pu(ji,jj,jk) + zwy(ji,jj) = e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * pv(ji,jj,jk) + END DO ; END DO + ! + ! !== compute and add the vorticity term trend =! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zuav = r1_8 * r1_e1u(ji,jj) * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) & + & + zwy(ji ,jj ) + zwy(ji+1,jj ) ) + zvau =-r1_8 * r1_e2v(ji,jj) * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) & + & + zwx(ji ,jj ) + zwx(ji ,jj+1) ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zuav * ( zwz(ji ,jj-1) + zwz(ji,jj) ) + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zvau * ( zwz(ji-1,jj ) + zwz(ji,jj) ) + END DO ; END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + END SUBROUTINE vor_ens + + + SUBROUTINE vor_een( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE vor_een *** + !! + !! ** Purpose : Compute the now total vorticity trend and add it to + !! the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! and the Arakawa and Lamb (1980) flux form formulation : conserves + !! both the horizontal kinetic energy and the potential enstrophy + !! when horizontal divergence is zero (see the NEMO documentation) + !! Add this trend to the general momentum trend (pu_rhs,pv_rhs). + !! + !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend + !! + !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zua, zva ! local scalars + REAL(wp) :: zmsk, ze3f ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: z1_e3f + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zwx , zwy + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: ztnw, ztne, ztsw, ztse + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpkm1) :: zwz ! 3D workspace, jpkm1 -> jpkm1 -> avoid lbc_lnk on jpk that is not defined + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_een : vorticity term: energy and enstrophy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! == reciprocal of e3 at F-point (1) + z1_e3f(ji,jj) = 1._wp / (e3f_0vor(ji,jj,jk)*(1._wp+r3f(ji,jj)*fe3mask(ji,jj,jk))) + END DO ; END DO + ! + SELECT CASE( kvor ) !== vorticity considered ==! + ! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ff_f(ji,jj) * z1_e3f(ji,jj) + END DO ; END DO + CASE ( np_RVO ) !* relative vorticity + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ( e2v(ji+1,jj ) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji ,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj)*z1_e3f(ji,jj) + END DO ; END DO + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) + END DO ; END DO + ENDIF + CASE ( np_MET ) !* metric term + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ( ( pv(ji+1,jj,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) ) * z1_e3f(ji,jj) + END DO ; END DO + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( ( e2v(ji+1,jj ) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & - ( e1u(ji ,jj+1) * pu(ji,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * r1_e1e2f(ji,jj) ) * z1_e3f(ji,jj) + END DO ; END DO + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) + END DO ; END DO + ENDIF + CASE ( np_CME ) !* Coriolis + metric + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) ) * z1_e3f(ji,jj) + END DO ; END DO + CASE DEFAULT ! error + CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' ) + END SELECT + ! ! =============== + END DO ! End of slab + ! ! =============== + ! + IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) + ! + ! ! =============== + ! ! Horizontal slab + ! ! =============== + DO jk = 1, jpkm1 + ! + ! !== horizontal fluxes ==! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zwx(ji,jj) = e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * pu(ji,jj,jk) + zwy(ji,jj) = e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * pv(ji,jj,jk) + END DO ; END DO + ! + ! !== compute and add the vorticity term trend =! + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + ztne(ji,jj) = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + ztse(ji,jj) = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + ztsw(ji,jj) = zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + END DO ; END DO + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) & + & + ztse(ji,jj ) * zwy(ji ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) ) + zva = - r1_12 * r1_e2v(ji,jj) * ( ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji ,jj+1) & + & + ztnw(ji,jj ) * zwx(ji-1,jj ) + ztne(ji,jj ) * zwx(ji ,jj ) ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zua + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zva + END DO ; END DO + END DO + ! ! =============== + ! ! End of slab + ! ! =============== + END SUBROUTINE vor_een + + + SUBROUTINE vor_eeT( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE vor_eeT *** + !! + !! ** Purpose : Compute the now total vorticity trend and add it to + !! the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! and the Arakawa and Lamb (1980) vector form formulation using + !! a modified version of Arakawa and Lamb (1980) scheme (see vor_een). + !! The change consists in + !! Add this trend to the general momentum trend (pu_rhs,pv_rhs). + !! + !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend + !! + !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zua, zva ! local scalars + REAL(wp) :: zmsk, z1_e3t ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zwx , zwy + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: ztnw, ztne, ztsw, ztse + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpkm1) :: zwz ! 3D workspace, avoid lbc_lnk on jpk that is not defined + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_eeT : vorticity term: energy and enstrophy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ff_f(ji,jj) + END DO ; END DO + CASE ( np_RVO ) !* relative vorticity + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zwz(ji,jj,jk) = ( (e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk)) & + & - (e1u(ji ,jj+1) * pu(ji ,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk)) ) & + & * r1_e1e2f(ji,jj) + END DO ; END DO + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) + END DO ; END DO + ENDIF + CASE ( np_MET ) !* metric term + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END DO ; END DO + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( (e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk)) & + & - (e1u(ji ,jj+1) * pu(ji ,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk)) ) & + & * r1_e1e2f(ji,jj) ) + END DO ; END DO + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) + END DO ; END DO + ENDIF + CASE ( np_CME ) !* Coriolis + metric + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END DO ; END DO + CASE DEFAULT ! error + CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' ) + END SELECT + ! + ! ! =============== + END DO ! End of slab + ! ! =============== + ! + IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + ! !== horizontal fluxes ==! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zwx(ji,jj) = e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * pu(ji,jj,jk) + zwy(ji,jj) = e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * pv(ji,jj,jk) + END DO ; END DO + ! + ! !== compute and add the vorticity term trend =! + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + z1_e3t = 1._wp / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + ztne(ji,jj) = ( zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) ) * z1_e3t + ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) ) * z1_e3t + ztse(ji,jj) = ( zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t + ztsw(ji,jj) = ( zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) ) * z1_e3t + END DO ; END DO + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) & + & + ztse(ji,jj ) * zwy(ji ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) ) + zva = - r1_12 * r1_e2v(ji,jj) * ( ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji ,jj+1) & + & + ztnw(ji,jj ) * zwx(ji-1,jj ) + ztne(ji,jj ) * zwx(ji ,jj ) ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zua + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zva + END DO ; END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + END SUBROUTINE vor_eeT + + + SUBROUTINE dyn_vor_init + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_vor_init *** + !! + !! ** Purpose : Control the consistency between cpp options for + !! tracer advection schemes + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ioptio, ios ! local integer + REAL(wp) :: zmsk ! local scalars + !! + NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_enT, ln_dynvor_eeT, & + & ln_dynvor_een, nn_e3f_typ , ln_dynvor_mix, ln_dynvor_msk + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_vor_init : vorticity term : read namelist and control the consistency' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + READ ( numnam_ref, namdyn_vor, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_vor in reference namelist' ) + READ ( numnam_cfg, namdyn_vor, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist' ) + IF(lwm) WRITE ( numond, namdyn_vor ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) ' Namelist namdyn_vor : choice of the vorticity term scheme' + WRITE(numout,*) ' enstrophy conserving scheme ln_dynvor_ens = ', ln_dynvor_ens + WRITE(numout,*) ' f-point energy conserving scheme ln_dynvor_ene = ', ln_dynvor_ene + WRITE(numout,*) ' t-point energy conserving scheme ln_dynvor_enT = ', ln_dynvor_enT + WRITE(numout,*) ' energy conserving scheme (een using e3t) ln_dynvor_eeT = ', ln_dynvor_eeT + WRITE(numout,*) ' enstrophy and energy conserving scheme ln_dynvor_een = ', ln_dynvor_een + WRITE(numout,*) ' e3f = averaging /4 (=0) or /sum(tmask) (=1) nn_e3f_typ = ', nn_e3f_typ + WRITE(numout,*) ' mixed enstrophy/energy conserving scheme ln_dynvor_mix = ', ln_dynvor_mix + WRITE(numout,*) ' masked (=T) or unmasked(=F) vorticity ln_dynvor_msk = ', ln_dynvor_msk + ENDIF + +!!gm this should be removed when choosing a unique strategy for fmask at the coast + ! If energy, enstrophy or mixed advection of momentum in vector form change the value for masks + ! at angles with three ocean points and one land point + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' change fmask value in the angles (T) ln_vorlat = ', ln_vorlat + IF( ln_vorlat .AND. ( ln_dynvor_ene .OR. ln_dynvor_ens .OR. ln_dynvor_mix ) ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) + IF( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & + & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) == 3._wp ) fmask(ji,jj,jk) = 1._wp + END DO ; END DO ; END DO + ! + CALL lbc_lnk( 'dynvor', fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask + ! + ENDIF +!!gm end + + ioptio = 0 ! type of scheme for vorticity (set nvor_scheme) + IF( ln_dynvor_ens ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENS ; ENDIF + IF( ln_dynvor_ene ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENE ; ENDIF + IF( ln_dynvor_enT ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENT ; ENDIF + IF( ln_dynvor_eeT ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_EET ; ENDIF + IF( ln_dynvor_een ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_EEN ; ENDIF + IF( ln_dynvor_mix ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_MIX ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( ' use ONE and ONLY one vorticity scheme' ) + ! + IF(lwp) WRITE(numout,*) ! type of calculated vorticity (set ncor, nrvm, ntot) + ncor = np_COR ! planetary vorticity + SELECT CASE( n_dynadv ) + CASE( np_LIN_dyn ) + IF(lwp) WRITE(numout,*) ' ==>>> linear dynamics : total vorticity = Coriolis' + nrvm = np_COR ! planetary vorticity + ntot = np_COR ! - - + CASE( np_VEC_c2 ) + IF(lwp) WRITE(numout,*) ' ==>>> vector form dynamics : total vorticity = Coriolis + relative vorticity' + nrvm = np_RVO ! relative vorticity + ntot = np_CRV ! relative + planetary vorticity + CASE( np_FLX_c2 , np_FLX_ubs ) + IF(lwp) WRITE(numout,*) ' ==>>> flux form dynamics : total vorticity = Coriolis + metric term' + nrvm = np_MET ! metric term + ntot = np_CME ! Coriolis + metric term + ! + SELECT CASE( nvor_scheme ) ! pre-computed gradients for the metric term: + CASE( np_ENT ) !* T-point metric term : pre-compute di(e2u)/2 and dj(e1v)/2 + ALLOCATE( di_e2u_2(jpi,jpj), dj_e1v_2(jpi,jpj) ) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + di_e2u_2(ji,jj) = ( e2u(ji,jj) - e2u(ji-1,jj ) ) * 0.5_wp + dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji ,jj-1) ) * 0.5_wp + END DO ; END DO + CALL lbc_lnk( 'dynvor', di_e2u_2, 'T', -1.0_wp , dj_e1v_2, 'T', -1.0_wp ) ! Lateral boundary conditions + ! + CASE DEFAULT !* F-point metric term : pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f) + ALLOCATE( di_e2v_2e1e2f(jpi,jpj), dj_e1u_2e1e2f(jpi,jpj) ) + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + di_e2v_2e1e2f(ji,jj) = ( e2v(ji+1,jj ) - e2v(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj) + dj_e1u_2e1e2f(ji,jj) = ( e1u(ji ,jj+1) - e1u(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj) + END DO ; END DO + CALL lbc_lnk( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp ) ! Lateral boundary conditions + END SELECT + ! + END SELECT + SELECT CASE( nvor_scheme ) ! qco or linssh cases : pre-computed a specific e3f_0 for some vorticity schemes + CASE( np_ENS , np_ENE , np_EEN , np_MIX ) + ! + ALLOCATE( e3f_0vor(jpi,jpj,jpk) ) + ! + SELECT CASE( nn_e3f_typ ) + CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + e3f_0vor(ji,jj,jk) = ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) & + & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & + & + e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) & + & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) * 0.25_wp + END DO ; END DO ; END DO + CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zmsk = (tmask(ji,jj+1,jk) +tmask(ji+1,jj+1,jk) & + & + tmask(ji,jj ,jk) +tmask(ji+1,jj ,jk) ) + ! + IF( zmsk /= 0._wp ) THEN + e3f_0vor(ji,jj,jk) = ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) & + & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & + & + e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) & + & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) / zmsk + ELSE ; e3f_0vor(ji,jj,jk) = 0._wp + ENDIF + END DO ; END DO ; END DO + END SELECT + ! + CALL lbc_lnk( 'dynvor', e3f_0vor, 'F', 1._wp ) + ! ! insure e3f_0vor /= 0 + WHERE( e3f_0vor(:,:,:) == 0._wp ) e3f_0vor(:,:,:) = e3f_0(:,:,:) + ! + END SELECT + ! + IF(lwp) THEN ! Print the choice + WRITE(numout,*) + SELECT CASE( nvor_scheme ) + CASE( np_ENS ) ; WRITE(numout,*) ' ==>>> enstrophy conserving scheme (ENS)' + CASE( np_ENE ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at F-points) (ENE)' + CASE( np_ENT ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at T-points) (ENT)' + IF( ln_dynadv_vec ) CALL ctl_warn('dyn_vor_init: ENT scheme may not work in vector form') + CASE( np_EET ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (EEN scheme using e3t) (EET)' + CASE( np_EEN ) ; WRITE(numout,*) ' ==>>> energy and enstrophy conserving scheme (EEN)' + CASE( np_MIX ) ; WRITE(numout,*) ' ==>>> mixed enstrophy/energy conserving scheme (MIX)' + END SELECT + ENDIF + ! + END SUBROUTINE dyn_vor_init + + !!============================================================================== +END MODULE dynvor diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynzad.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynzad.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ce693192d14e5a922cd3ffbeced55bb36b151d70 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynzad.f90 @@ -0,0 +1,156 @@ + + + + + + + + + + + + + +MODULE dynzad + !!====================================================================== + !! *** MODULE dynzad *** + !! Ocean dynamics : vertical advection trend + !!====================================================================== + !! History : OPA ! 1991-01 (G. Madec) Original code + !! NEMO 0.5 ! 2002-07 (G. Madec) Free form, F90 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_zad : vertical advection momentum trend + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition: ocean + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + USE sbcwave, ONLY: wsd ! Surface Waves (add vertical Stokes-drift) + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_zad ! routine called by dynadv.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynzad.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_zad ( kt, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dynzad *** + !! + !! ** Purpose : Compute the now vertical momentum advection trend and + !! add it to the general trend of momentum equation. + !! + !! ** Method : The now vertical advection of momentum is given by: + !! w dz(u) = u(rhs) + 1/(e1e2u*e3u) mk+1[ mi(e1e2t*ww) dk(u) ] + !! w dz(v) = v(rhs) + 1/(e1e2v*e3v) mk+1[ mj(e1e2t*ww) dk(v) ] + !! Add this trend to the general trend (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)): + !! (u(rhs),v(rhs)) = (u(rhs),v(rhs)) + w dz(u,v) + !! + !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the vert. momentum adv. trends + !! - Send the trends to trddyn for diagnostics (l_trddyn=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step inedx + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zua, zva ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zww + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwuw, zwvw + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_zad') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_zad : 2nd order vertical advection scheme' + ENDIF + ENDIF + + IF( l_trddyn ) THEN ! Save puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + + DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical + IF( ln_vortex_force ) THEN ! vertical fluxes + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ( ww(ji,jj,jk) + wsd(ji,jj,jk) ) + END DO ; END DO + ELSE + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) + END DO ; END DO + ENDIF + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! vertical momentum advection at w-point + zwuw(ji,jj,jk) = ( zww(ji+1,jj ) + zww(ji,jj) ) * ( puu(ji,jj,jk-1,Kmm) - puu(ji,jj,jk,Kmm) ) + zwvw(ji,jj,jk) = ( zww(ji ,jj+1) + zww(ji,jj) ) * ( pvv(ji,jj,jk-1,Kmm) - pvv(ji,jj,jk,Kmm) ) + END DO ; END DO + END DO + ! + ! Surface and bottom advective fluxes set to zero + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zwuw(ji,jj, 1 ) = 0._wp + zwvw(ji,jj, 1 ) = 0._wp + zwuw(ji,jj,jpk) = 0._wp + zwvw(ji,jj,jpk) = 0._wp + END DO ; END DO + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! Vertical momentum advection at u- and v-points + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & + & / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) & + & / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + END DO ; END DO ; END DO + + IF( l_trddyn ) THEN ! save the vertical advection trends for diagnostic + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt, Kmm ) + DEALLOCATE( ztrdu, ztrdv ) + ENDIF + ! ! Control print + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' zad - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_zad') + ! + END SUBROUTINE dyn_zad + + !!====================================================================== +END MODULE dynzad diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynzdf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynzdf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dfff17fedfc55ec72860ce23b854519218019195 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/dynzdf.f90 @@ -0,0 +1,478 @@ + + + + + + + + + + + + + +MODULE dynzdf + !!============================================================================== + !! *** MODULE dynzdf *** + !! Ocean dynamics : vertical component of the momentum mixing trend + !!============================================================================== + !! History : 1.0 ! 2005-11 (G. Madec) Original code + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 4.0 ! 2017-06 (G. Madec) remove the explicit time-stepping option + avm at t-point + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_zdf : compute the after velocity through implicit calculation of vertical mixing + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! surface boundary condition: ocean + USE zdf_oce ! ocean vertical physics variables + USE zdfdrg ! vertical physics: top/bottom drag coef. + USE dynadv ,ONLY: ln_dynadv_vec ! dynamics: advection form + USE dynldf_iso,ONLY: akzu, akzv ! dynamics: vertical component of rotated lateral mixing + USE ldfdyn ! lateral diffusion: eddy viscosity coef. and type of operator + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_zdf ! routine called by step.F90 + + REAL(wp) :: r_vvl ! non-linear free surface indicator: =0 if ln_linssh=T, =1 otherwise + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynzdf.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_zdf( kt, Kbb, Kmm, Krhs, puu, pvv, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_zdf *** + !! + !! ** Purpose : compute the trend due to the vert. momentum diffusion + !! together with the Leap-Frog time stepping using an + !! implicit scheme. + !! + !! ** Method : - Leap-Frog time stepping on all trends but the vertical mixing + !! u(after) = u(before) + 2*dt * u(rhs) vector form or linear free surf. + !! u(after) = ( e3u_b*u(before) + 2*dt * e3u_n*u(rhs) ) / e3u_after otherwise + !! - update the after velocity with the implicit vertical mixing. + !! This requires to solver the following system: + !! u(after) = u(after) + 1/e3u_after dk+1[ mi(avm) / e3uw_after dk[ua] ] + !! with the following surface/top/bottom boundary condition: + !! surface: wind stress input (averaged over kt-1/2 & kt+1/2) + !! top & bottom : top stress (iceshelf-ocean) & bottom stress (cf zdfdrg.F90) + !! + !! ** Action : (puu(:,:,:,Kaa),pvv(:,:,:,Kaa)) after velocity + !!--------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iku, ikv ! local integers + REAL(wp) :: zzwi, ze3ua, zdt ! local scalars + REAL(wp) :: zzws, ze3va ! - - + REAL(wp) :: z1_e3ua, z1_e3va ! - - + REAL(wp) :: zWu , zWv ! - - + REAL(wp) :: zWui, zWvi ! - - + REAL(wp) :: zWus, zWvs ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwi, zwd, zws ! 3D workspace + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv ! - - + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_zdf') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN !* initialization + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_zdf_imp : vertical momentum diffusion implicit operator' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' + ! + If( ln_linssh ) THEN ; r_vvl = 0._wp ! non-linear free surface indicator + ELSE ; r_vvl = 1._wp + ENDIF + ENDIF + ENDIF + ! !* explicit top/bottom drag case + IF( .NOT.ln_drgimp ) CALL zdf_drg_exp( kt, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add top/bottom friction trend to (puu(Kaa),pvv(Kaa)) + ! + ! + IF( l_trddyn ) THEN !* temporary save of ta and sa trends + ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! + ! !== RHS: Leap-Frog time stepping on all trends but the vertical mixing ==! (put in puu(:,:,:,Kaa),pvv(:,:,:,Kaa)) + ! + ! ! time stepping except vertical diffusion + IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! applied on velocity + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kbb) + rDt * puu(ji,jj,jk,Krhs) ) * umask(ji,jj,jk) + pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kbb) + rDt * pvv(ji,jj,jk,Krhs) ) * vmask(ji,jj,jk) + END DO ; END DO ; END DO + ELSE ! applied on thickness weighted velocity + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + puu(ji,jj,jk,Kaa) = ( (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kbb)*umask(ji,jj,jk))) * puu(ji,jj,jk,Kbb ) & + & + rDt * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * puu(ji,jj,jk,Krhs) ) & + & / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,jk))) * umask(ji,jj,jk) + pvv(ji,jj,jk,Kaa) = ( (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kbb)*vmask(ji,jj,jk))) * pvv(ji,jj,jk,Kbb ) & + & + rDt * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * pvv(ji,jj,jk,Krhs) ) & + & / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,jk))) * vmask(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ! ! add top/bottom friction + ! With split-explicit free surface, barotropic stress is treated explicitly Update velocities at the bottom. + ! J. Chanut: The bottom stress is computed considering after barotropic velocities, which does + ! not lead to the effective stress seen over the whole barotropic loop. + ! G. Madec : in linear free surface, (e3u_0(:,:,:)*(1._wp+r3u(:,:,Kaa)*umask(:,:,:))) = (e3u_0(:,:,:)*(1._wp+r3u(:,:,Kmm)*umask(:,:,:))) = e3u_0, so systematic use of (e3u_0(:,:,:)*(1._wp+r3u(:,:,Kaa)*umask(:,:,:))) + IF( ln_drgimp .AND. ln_dynspg_ts ) THEN + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! remove barotropic velocities + puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - uu_b(ji,jj,Kaa) ) * umask(ji,jj,jk) + pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - vv_b(ji,jj,Kaa) ) * vmask(ji,jj,jk) + END DO ; END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! Add bottom/top stress due to barotropic component only + iku = mbku(ji,jj) ! ocean bottom level at u- and v-points + ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) + ze3ua = ( 1._wp - r_vvl ) * (e3u_0(ji,jj,iku)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,iku))) & + & + r_vvl * (e3u_0(ji,jj,iku)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,iku))) + ze3va = ( 1._wp - r_vvl ) * (e3v_0(ji,jj,ikv)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,ikv))) & + & + r_vvl * (e3v_0(ji,jj,ikv)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,ikv))) + puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua + pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va + END DO ; END DO + IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities (ISF) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + iku = miku(ji,jj) ! top ocean level at u- and v-points + ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) + ze3ua = ( 1._wp - r_vvl ) * (e3u_0(ji,jj,iku)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,iku))) & + & + r_vvl * (e3u_0(ji,jj,iku)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,iku))) + ze3va = ( 1._wp - r_vvl ) * (e3v_0(ji,jj,ikv)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,ikv))) & + & + r_vvl * (e3v_0(ji,jj,ikv)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,ikv))) + puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + rDt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua + pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va + END DO ; END DO + END IF + ENDIF + ! + ! !== Vertical diffusion on u ==! + ! + ! !* Matrix construction + zdt = rDt * 0.5 + IF( ln_zad_Aimp ) THEN !! + SELECT CASE( nldf_dyn ) + CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ze3ua = ( 1._wp - r_vvl ) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) & + & + r_vvl * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,jk))) ! after scale factor at U-point + zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) & + & / ( ze3ua * (e3uw_0(ji,jj,jk )*(1._wp+r3u(ji,jj,Kmm))) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) & + & / ( ze3ua * (e3uw_0(ji,jj,jk+1)*(1._wp+r3u(ji,jj,Kmm))) ) * wumask(ji,jj,jk+1) + zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua + zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua + zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) + zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) + END DO ; END DO ; END DO + CASE DEFAULT ! iso-level lateral mixing + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ze3ua = ( 1._wp - r_vvl ) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) & ! after scale factor at U-point + & + r_vvl * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,jk))) + zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) & + & / ( ze3ua * (e3uw_0(ji,jj,jk )*(1._wp+r3u(ji,jj,Kmm))) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) & + & / ( ze3ua * (e3uw_0(ji,jj,jk+1)*(1._wp+r3u(ji,jj,Kmm))) ) * wumask(ji,jj,jk+1) + zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua + zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua + zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) + zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) + END DO ; END DO ; END DO + END SELECT + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !* Surface boundary conditions + zwi(ji,jj,1) = 0._wp + ze3ua = ( 1._wp - r_vvl ) * (e3u_0(ji,jj,1)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,1))) & + & + r_vvl * (e3u_0(ji,jj,1)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,1))) + zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) & + & / ( ze3ua * (e3uw_0(ji,jj,2)*(1._wp+r3u(ji,jj,Kmm))) ) * wumask(ji,jj,2) + zWus = ( wi(ji ,jj,2) + wi(ji+1,jj,2) ) / ze3ua + zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) + zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWus, 0._wp ) ) + END DO ; END DO + ELSE + SELECT CASE( nldf_dyn ) + CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ze3ua = ( 1._wp - r_vvl ) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) & + & + r_vvl * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,jk))) ! after scale factor at U-point + zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) & + & / ( ze3ua * (e3uw_0(ji,jj,jk )*(1._wp+r3u(ji,jj,Kmm))) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) & + & / ( ze3ua * (e3uw_0(ji,jj,jk+1)*(1._wp+r3u(ji,jj,Kmm))) ) * wumask(ji,jj,jk+1) + zwi(ji,jj,jk) = zzwi + zws(ji,jj,jk) = zzws + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + END DO ; END DO ; END DO + CASE DEFAULT ! iso-level lateral mixing + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ze3ua = ( 1._wp - r_vvl ) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) & + & + r_vvl * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,jk))) ! after scale factor at U-point + zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) & + & / ( ze3ua * (e3uw_0(ji,jj,jk )*(1._wp+r3u(ji,jj,Kmm))) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) & + & / ( ze3ua * (e3uw_0(ji,jj,jk+1)*(1._wp+r3u(ji,jj,Kmm))) ) * wumask(ji,jj,jk+1) + zwi(ji,jj,jk) = zzwi + zws(ji,jj,jk) = zzws + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + END DO ; END DO ; END DO + END SELECT + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !* Surface boundary conditions + zwi(ji,jj,1) = 0._wp + zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) + END DO ; END DO + ENDIF + ! + ! + ! !== Apply semi-implicit bottom friction ==! + ! + ! Only needed for semi-implicit bottom friction setup. The explicit + ! bottom friction has been included in "u(v)a" which act as the R.H.S + ! column vector of the tri-diagonal matrix equation + ! + IF ( ln_drgimp ) THEN ! implicit bottom friction + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + iku = mbku(ji,jj) ! ocean bottom level at u- and v-points + ze3ua = ( 1._wp - r_vvl ) * (e3u_0(ji,jj,iku)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,iku))) & + & + r_vvl * (e3u_0(ji,jj,iku)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,iku))) ! after scale factor at T-point + zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua + END DO ; END DO + IF ( ln_isfcav.OR.ln_drgice_imp ) THEN ! top friction (always implicit) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + !!gm top Cd is masked (=0 outside cavities) no need of test on mik>=2 ==>> it has been suppressed + iku = miku(ji,jj) ! ocean top level at u- and v-points + ze3ua = ( 1._wp - r_vvl ) * (e3u_0(ji,jj,iku)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,iku))) & + & + r_vvl * (e3u_0(ji,jj,iku)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,iku))) ! after scale factor at T-point + zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua + END DO ; END DO + END IF + ENDIF + ! + ! Matrix inversion starting from the first level + !----------------------------------------------------------------------- + ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk ) + ! + ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 ) + ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 ) + ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 ) + ! ( ... )( ... ) ( ... ) + ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk ) + ! + ! m is decomposed in the product of an upper and a lower triangular matrix + ! The 3 diagonal terms are in 2d arrays: zwd, zws, zwi + ! The solution (the after velocity) is in puu(:,:,:,Kaa) + !----------------------------------------------------------------------- + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == + zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! + ze3ua = ( 1._wp - r_vvl ) * (e3u_0(ji,jj,1)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,1))) & + & + r_vvl * (e3u_0(ji,jj,1)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,1))) + puu(ji,jj,1,Kaa) = puu(ji,jj,1,Kaa) + rDt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & + & / ( ze3ua * rho0 ) * umask(ji,jj,1) + END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + puu(ji,jj,jk,Kaa) = puu(ji,jj,jk,Kaa) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * puu(ji,jj,jk-1,Kaa) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !== thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk ==! + puu(ji,jj,jpkm1,Kaa) = puu(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) + END DO ; END DO + DO jk = jpk-2, 1, -1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - zws(ji,jj,jk) * puu(ji,jj,jk+1,Kaa) ) / zwd(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! !== Vertical diffusion on v ==! + ! + ! !* Matrix construction + zdt = rDt * 0.5 + IF( ln_zad_Aimp ) THEN !! + SELECT CASE( nldf_dyn ) + CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzv) + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ze3va = ( 1._wp - r_vvl ) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) & + & + r_vvl * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,jk))) ! after scale factor at V-point + zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) & + & / ( ze3va * (e3vw_0(ji,jj,jk )*(1._wp+r3v(ji,jj,Kmm))) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) & + & / ( ze3va * (e3vw_0(ji,jj,jk+1)*(1._wp+r3v(ji,jj,Kmm))) ) * wvmask(ji,jj,jk+1) + zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va + zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va + zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) + zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) + zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) + END DO ; END DO ; END DO + CASE DEFAULT ! iso-level lateral mixing + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ze3va = ( 1._wp - r_vvl ) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) & + & + r_vvl * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,jk))) ! after scale factor at V-point + zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) & + & / ( ze3va * (e3vw_0(ji,jj,jk )*(1._wp+r3v(ji,jj,Kmm))) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) & + & / ( ze3va * (e3vw_0(ji,jj,jk+1)*(1._wp+r3v(ji,jj,Kmm))) ) * wvmask(ji,jj,jk+1) + zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va + zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va + zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) + zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) + zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) + END DO ; END DO ; END DO + END SELECT + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !* Surface boundary conditions + zwi(ji,jj,1) = 0._wp + ze3va = ( 1._wp - r_vvl ) * (e3v_0(ji,jj,1)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,1))) & + & + r_vvl * (e3v_0(ji,jj,1)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,1))) + zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) & + & / ( ze3va * (e3vw_0(ji,jj,2)*(1._wp+r3v(ji,jj,Kmm))) ) * wvmask(ji,jj,2) + zWvs = ( wi(ji,jj ,2) + wi(ji,jj+1,2) ) / ze3va + zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) + zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWvs, 0._wp ) ) + END DO ; END DO + ELSE + SELECT CASE( nldf_dyn ) + CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ze3va = ( 1._wp - r_vvl ) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) & + & + r_vvl * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,jk))) ! after scale factor at V-point + zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) & + & / ( ze3va * (e3vw_0(ji,jj,jk )*(1._wp+r3v(ji,jj,Kmm))) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) & + & / ( ze3va * (e3vw_0(ji,jj,jk+1)*(1._wp+r3v(ji,jj,Kmm))) ) * wvmask(ji,jj,jk+1) + zwi(ji,jj,jk) = zzwi + zws(ji,jj,jk) = zzws + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + END DO ; END DO ; END DO + CASE DEFAULT ! iso-level lateral mixing + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ze3va = ( 1._wp - r_vvl ) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) & + & + r_vvl * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,jk))) ! after scale factor at V-point + zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) & + & / ( ze3va * (e3vw_0(ji,jj,jk )*(1._wp+r3v(ji,jj,Kmm))) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) & + & / ( ze3va * (e3vw_0(ji,jj,jk+1)*(1._wp+r3v(ji,jj,Kmm))) ) * wvmask(ji,jj,jk+1) + zwi(ji,jj,jk) = zzwi + zws(ji,jj,jk) = zzws + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + END DO ; END DO ; END DO + END SELECT + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !* Surface boundary conditions + zwi(ji,jj,1) = 0._wp + zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) + END DO ; END DO + ENDIF + ! + ! !== Apply semi-implicit top/bottom friction ==! + ! + ! Only needed for semi-implicit bottom friction setup. The explicit + ! bottom friction has been included in "u(v)a" which act as the R.H.S + ! column vector of the tri-diagonal matrix equation + ! + IF( ln_drgimp ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) + ze3va = ( 1._wp - r_vvl ) * (e3v_0(ji,jj,ikv)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,ikv))) & + & + r_vvl * (e3v_0(ji,jj,ikv)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,ikv))) ! after scale factor at T-point + zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va + END DO ; END DO + IF ( ln_isfcav.OR.ln_drgice_imp ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) + ze3va = ( 1._wp - r_vvl ) * (e3v_0(ji,jj,ikv)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,ikv))) & + & + r_vvl * (e3v_0(ji,jj,ikv)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,ikv))) ! after scale factor at T-point + zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / ze3va + END DO ; END DO + ENDIF + ENDIF + + ! Matrix inversion + !----------------------------------------------------------------------- + ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk ) + ! + ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 ) + ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 ) + ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 ) + ! ( ... )( ... ) ( ... ) + ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk ) + ! + ! m is decomposed in the product of an upper and lower triangular matrix + ! The 3 diagonal terms are in 2d arrays: zwd, zws, zwi + ! The solution (after velocity) is in 2d array va + !----------------------------------------------------------------------- + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == + zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! + ze3va = ( 1._wp - r_vvl ) * (e3v_0(ji,jj,1)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,1))) & + & + r_vvl * (e3v_0(ji,jj,1)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,1))) + pvv(ji,jj,1,Kaa) = pvv(ji,jj,1,Kaa) + rDt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & + & / ( ze3va * rho0 ) * vmask(ji,jj,1) + END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pvv(ji,jj,jk,Kaa) = pvv(ji,jj,jk,Kaa) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * pvv(ji,jj,jk-1,Kaa) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !== third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk ==! + pvv(ji,jj,jpkm1,Kaa) = pvv(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) + END DO ; END DO + DO jk = jpk-2, 1, -1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - zws(ji,jj,jk) * pvv(ji,jj,jk+1,Kaa) ) / zwd(ji,jj,jk) + END DO ; END DO ; END DO + ! + IF( l_trddyn ) THEN ! save the vertical diffusive trends for further diagnostics + ztrdu(:,:,:) = ( puu(:,:,:,Kaa) - puu(:,:,:,Kbb) ) / rDt - ztrdu(:,:,:) + ztrdv(:,:,:) = ( pvv(:,:,:,Kaa) - pvv(:,:,:,Kbb) ) / rDt - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_zdf, kt, Kmm ) + DEALLOCATE( ztrdu, ztrdv ) + ENDIF + ! ! print mean trends (used for debugging) + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' zdf - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Kaa), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_zdf') + ! + END SUBROUTINE dyn_zdf + + !!============================================================================== +END MODULE dynzdf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/eosbn2.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/eosbn2.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e329835f74f7b9eeb8bedc736740335ff3440641 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/eosbn2.f90 @@ -0,0 +1,1846 @@ + + + + + + + + + + + + + +MODULE eosbn2 + !!============================================================================== + !! *** MODULE eosbn2 *** + !! Equation Of Seawater : in situ density - Brunt-Vaisala frequency + !!============================================================================== + !! History : OPA ! 1989-03 (O. Marti) Original code + !! 6.0 ! 1994-07 (G. Madec, M. Imbard) add bn2 + !! 6.0 ! 1994-08 (G. Madec) Add Jackett & McDougall eos + !! 7.0 ! 1996-01 (G. Madec) statement function for e3 + !! 8.1 ! 1997-07 (G. Madec) density instead of volumic mass + !! - ! 1999-02 (G. Madec, N. Grima) semi-implicit pressure gradient + !! 8.2 ! 2001-09 (M. Ben Jelloul) bugfix on linear eos + !! NEMO 1.0 ! 2002-10 (G. Madec) add eos_init + !! - ! 2002-11 (G. Madec, A. Bozec) partial step, eos_insitu_2d + !! - ! 2003-08 (G. Madec) F90, free form + !! 3.0 ! 2006-08 (G. Madec) add tfreez function (now eos_fzp function) + !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + !! - ! 2010-10 (G. Nurser, G. Madec) add alpha/beta used in ldfslp + !! 3.7 ! 2012-03 (F. Roquet, G. Madec) add primitive of alpha and beta used in PE computation + !! - ! 2012-05 (F. Roquet) add Vallis and original JM95 equation of state + !! - ! 2013-04 (F. Roquet, G. Madec) add eos_rab, change bn2 computation and reorganize the module + !! - ! 2014-09 (F. Roquet) add TEOS-10, S-EOS, and modify EOS-80 + !! - ! 2015-06 (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! eos : generic interface of the equation of state + !! eos_insitu : Compute the in situ density + !! eos_insitu_pot: Compute the insitu and surface referenced potential volumic mass + !! eos_insitu_2d : Compute the in situ density for 2d fields + !! bn2 : compute the Brunt-Vaisala frequency + !! eos_pt_from_ct: compute the potential temperature from the Conservative Temperature + !! eos_rab : generic interface of in situ thermal/haline expansion ratio + !! eos_rab_3d : compute in situ thermal/haline expansion ratio + !! eos_rab_2d : compute in situ thermal/haline expansion ratio for 2d fields + !! eos_fzp_2d : freezing temperature for 2d fields + !! eos_fzp_0d : freezing temperature for scalar + !! eos_init : set eos parameters (namelist) + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE domutl, ONLY : is_tile + USE phycst ! physical constants + USE stopar ! Stochastic T/S fluctuations + USE stopts ! Stochastic T/S fluctuations + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE prtctl ! Print control + USE lbclnk ! ocean lateral boundary conditions + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + ! !! * Interface + INTERFACE eos + MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d, eos_insitu_pot_2d + END INTERFACE + ! + INTERFACE eos_rab + MODULE PROCEDURE rab_3d, rab_2d, rab_0d + END INTERFACE + ! + INTERFACE eos_fzp + MODULE PROCEDURE eos_fzp_2d, eos_fzp_0d + END INTERFACE + ! + PUBLIC eos ! called by step, istate, tranpc and zpsgrd modules + PUBLIC bn2 ! called by step module + PUBLIC eos_rab ! called by ldfslp, zdfddm, trabbl + PUBLIC eos_pt_from_ct ! called by sbcssm + PUBLIC eos_fzp ! called by traadv_cen2 and sbcice_... modules + PUBLIC eos_pen ! used for pe diagnostics in trdpen module + PUBLIC eos_init ! called by istate module + + ! !!** Namelist nameos ** + LOGICAL , PUBLIC :: ln_TEOS10 + LOGICAL , PUBLIC :: ln_EOS80 + LOGICAL , PUBLIC :: ln_SEOS + + ! Parameters + LOGICAL , PUBLIC :: l_useCT ! =T in ln_TEOS10=T (i.e. use eos_pt_from_ct to compute sst_m), =F otherwise + INTEGER , PUBLIC :: neos ! Identifier for equation of state used + + INTEGER , PARAMETER :: np_teos10 = -1 ! parameter for using TEOS10 + INTEGER , PARAMETER :: np_eos80 = 0 ! parameter for using EOS80 + INTEGER , PARAMETER :: np_seos = 1 ! parameter for using Simplified Equation of state + + ! !!! simplified eos coefficients (default value: Vallis 2006) + REAL(wp), PUBLIC :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff. + REAL(wp), PUBLIC :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff. + REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 + REAL(wp) :: rn_lambda2 = 5.4914e-4_wp ! cabbeling coeff. in S^2 + REAL(wp) :: rn_mu1 = 1.4970e-4_wp ! thermobaric coeff. in T + REAL(wp) :: rn_mu2 = 1.1090e-5_wp ! thermobaric coeff. in S + REAL(wp) :: rn_nu = 2.4341e-3_wp ! cabbeling coeff. in theta*salt + + ! TEOS10/EOS80 parameters + REAL(wp) :: r1_S0, r1_T0, r1_Z0, rdeltaS + + ! EOS parameters + REAL(wp) :: EOS000 , EOS100 , EOS200 , EOS300 , EOS400 , EOS500 , EOS600 + REAL(wp) :: EOS010 , EOS110 , EOS210 , EOS310 , EOS410 , EOS510 + REAL(wp) :: EOS020 , EOS120 , EOS220 , EOS320 , EOS420 + REAL(wp) :: EOS030 , EOS130 , EOS230 , EOS330 + REAL(wp) :: EOS040 , EOS140 , EOS240 + REAL(wp) :: EOS050 , EOS150 + REAL(wp) :: EOS060 + REAL(wp) :: EOS001 , EOS101 , EOS201 , EOS301 , EOS401 + REAL(wp) :: EOS011 , EOS111 , EOS211 , EOS311 + REAL(wp) :: EOS021 , EOS121 , EOS221 + REAL(wp) :: EOS031 , EOS131 + REAL(wp) :: EOS041 + REAL(wp) :: EOS002 , EOS102 , EOS202 + REAL(wp) :: EOS012 , EOS112 + REAL(wp) :: EOS022 + REAL(wp) :: EOS003 , EOS103 + REAL(wp) :: EOS013 + + ! ALPHA parameters + REAL(wp) :: ALP000 , ALP100 , ALP200 , ALP300 , ALP400 , ALP500 + REAL(wp) :: ALP010 , ALP110 , ALP210 , ALP310 , ALP410 + REAL(wp) :: ALP020 , ALP120 , ALP220 , ALP320 + REAL(wp) :: ALP030 , ALP130 , ALP230 + REAL(wp) :: ALP040 , ALP140 + REAL(wp) :: ALP050 + REAL(wp) :: ALP001 , ALP101 , ALP201 , ALP301 + REAL(wp) :: ALP011 , ALP111 , ALP211 + REAL(wp) :: ALP021 , ALP121 + REAL(wp) :: ALP031 + REAL(wp) :: ALP002 , ALP102 + REAL(wp) :: ALP012 + REAL(wp) :: ALP003 + + ! BETA parameters + REAL(wp) :: BET000 , BET100 , BET200 , BET300 , BET400 , BET500 + REAL(wp) :: BET010 , BET110 , BET210 , BET310 , BET410 + REAL(wp) :: BET020 , BET120 , BET220 , BET320 + REAL(wp) :: BET030 , BET130 , BET230 + REAL(wp) :: BET040 , BET140 + REAL(wp) :: BET050 + REAL(wp) :: BET001 , BET101 , BET201 , BET301 + REAL(wp) :: BET011 , BET111 , BET211 + REAL(wp) :: BET021 , BET121 + REAL(wp) :: BET031 + REAL(wp) :: BET002 , BET102 + REAL(wp) :: BET012 + REAL(wp) :: BET003 + + ! PEN parameters + REAL(wp) :: PEN000 , PEN100 , PEN200 , PEN300 , PEN400 + REAL(wp) :: PEN010 , PEN110 , PEN210 , PEN310 + REAL(wp) :: PEN020 , PEN120 , PEN220 + REAL(wp) :: PEN030 , PEN130 + REAL(wp) :: PEN040 + REAL(wp) :: PEN001 , PEN101 , PEN201 + REAL(wp) :: PEN011 , PEN111 + REAL(wp) :: PEN021 + REAL(wp) :: PEN002 , PEN102 + REAL(wp) :: PEN012 + + ! ALPHA_PEN parameters + REAL(wp) :: APE000 , APE100 , APE200 , APE300 + REAL(wp) :: APE010 , APE110 , APE210 + REAL(wp) :: APE020 , APE120 + REAL(wp) :: APE030 + REAL(wp) :: APE001 , APE101 + REAL(wp) :: APE011 + REAL(wp) :: APE002 + + ! BETA_PEN parameters + REAL(wp) :: BPE000 , BPE100 , BPE200 , BPE300 + REAL(wp) :: BPE010 , BPE110 , BPE210 + REAL(wp) :: BPE020 , BPE120 + REAL(wp) :: BPE030 + REAL(wp) :: BPE001 , BPE101 + REAL(wp) :: BPE011 + REAL(wp) :: BPE002 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: eosbn2.F90 15136 2021-07-23 10:07:28Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE eos_insitu( pts, prd, pdep ) + !! + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] + !! + CALL eos_insitu_t( pts, is_tile(pts), prd, is_tile(prd), pdep, is_tile(pdep) ) + END SUBROUTINE eos_insitu + + SUBROUTINE eos_insitu_t( pts, ktts, prd, ktrd, pdep, ktdep ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_insitu *** + !! + !! ** Purpose : Compute the in situ density (ratio rho/rho0) from + !! potential temperature and salinity using an equation of state + !! selected in the nameos namelist + !! + !! ** Method : prd(t,s,z) = ( rho(t,s,z) - rho0 ) / rho0 + !! with prd in situ density anomaly no units + !! t TEOS10: CT or EOS80: PT Celsius + !! s TEOS10: SA or EOS80: SP TEOS10: g/kg or EOS80: psu + !! z depth meters + !! rho in situ density kg/m^3 + !! rho0 reference density kg/m^3 + !! + !! ln_teos10 : polynomial TEOS-10 equation of state is used for rho(t,s,z). + !! Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celsius, sa=35.5 g/kg + !! + !! ln_eos80 : polynomial EOS-80 equation of state is used for rho(t,s,z). + !! Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celsius, sp=35.5 psu + !! + !! ln_seos : simplified equation of state + !! prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rho0 + !! linear case function of T only: rn_alpha<>0, other coefficients = 0 + !! linear eos function of T and S: rn_alpha and rn_beta<>0, other coefficients=0 + !! Vallis like equation: use default values of coefficients + !! + !! ** Action : compute prd , the in situ density (no units) + !! + !! References : Roquet et al, Ocean Modelling, in preparation (2014) + !! Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006 + !! TEOS-10 Manual, 2010 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktts, ktrd, ktdep + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktts+1:,(ntsj-nn_hls-1)*ktts+1: ,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktrd+1:,(ntsj-nn_hls-1)*ktrd+1: ,: ), INTENT( out) :: prd ! in situ density [-] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktdep+1:,(ntsj-nn_hls-1)*ktdep+1:,: ), INTENT(in ) :: pdep ! depth [m] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt, zh, ztm! local scalars + REAL(dp) :: zs! local scalars + REAL(wp) :: zn1, zn2! - - + REAL(dp) :: zn, zn0, zn3! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos-insitu') + ! + SELECT CASE( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zh = pdep(ji,jj,jk) * r1_Z0 ! depth + zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,jk) ! tmask + ! + zn3 = EOS013*zt & + & + EOS103*zs+EOS003 + ! + zn2 = (EOS022*zt & + & + EOS112*zs+EOS012)*zt & + & + (EOS202*zs+EOS102)*zs+EOS002 + ! + zn1 = (((EOS041*zt & + & + EOS131*zs+EOS031)*zt & + & + (EOS221*zs+EOS121)*zs+EOS021)*zt & + & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & + & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 + ! + zn0 = (((((EOS060*zt & + & + EOS150*zs+EOS050)*zt & + & + (EOS240*zs+EOS140)*zs+EOS040)*zt & + & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & + & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & + & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & + & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + prd(ji,jj,jk) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked) + ! + END DO ; END DO ; END DO + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zt = pts (ji,jj,jk,jp_tem) - 10._wp + zs = pts (ji,jj,jk,jp_sal) - 35._wp + zh = pdep (ji,jj,jk) + ztm = tmask(ji,jj,jk) + ! + zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & + & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & + & - rn_nu * zt * zs + ! + prd(ji,jj,jk) = zn * r1_rho0 * ztm ! density anomaly (masked) + END DO ; END DO ; END DO + ! + END SELECT + ! + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ' ) + ! + IF( ln_timing ) CALL timing_stop('eos-insitu') + ! + END SUBROUTINE eos_insitu_t + + + SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) + !! + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] + REAL(dp), DIMENSION(:,:,:) , INTENT( out) :: prhop ! potential density (surface referenced) + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] + !! + CALL eos_insitu_pot_t( pts, is_tile(pts), prd, is_tile(prd), prhop, is_tile(prhop), pdep, is_tile(pdep) ) + END SUBROUTINE eos_insitu_pot + + + SUBROUTINE eos_insitu_pot_t( pts, ktts, prd, ktrd, prhop, ktrhop, pdep, ktdep ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_insitu_pot *** + !! + !! ** Purpose : Compute the in situ density (ratio rho/rho0) and the + !! potential volumic mass (Kg/m3) from potential temperature and + !! salinity fields using an equation of state selected in the + !! namelist. + !! + !! ** Action : - prd , the in situ density (no units) + !! - prhop, the potential volumic mass (Kg/m3) + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktts, ktrd, ktrhop, ktdep + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktts+1:,(ntsj-nn_hls-1)*ktts+1: ,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktrd+1:,(ntsj-nn_hls-1)*ktrd+1: ,: ), INTENT( out) :: prd ! in situ density [-] + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktrhop+1:,(ntsj-nn_hls-1)*ktrhop+1:,: ), INTENT( out) :: prhop ! potential density (surface referenced) + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktdep+1:,(ntsj-nn_hls-1)*ktdep+1: ,: ), INTENT(in ) :: pdep ! depth [m] + ! + INTEGER :: ji, jj, jk, jsmp ! dummy loop indices + INTEGER :: jdof + REAL(wp) :: zt, zh, zstemp, ztm! local scalars + REAL(dp) :: zs! local scalars + REAL(wp) :: zn1, zn2, zn3! - - + REAL(dp) :: zn, zn0! - - + REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos-pot') + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + ! Stochastic equation of state + IF ( ln_sto_eos ) THEN + ALLOCATE(zn0_sto(1:2*nn_sto_eos)) + ALLOCATE(zn_sto(1:2*nn_sto_eos)) + ALLOCATE(zsign(1:2*nn_sto_eos)) + DO jsmp = 1, 2*nn_sto_eos, 2 + zsign(jsmp) = 1._wp + zsign(jsmp+1) = -1._wp + END DO + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + ! compute density (2*nn_sto_eos) times: + ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts) + ! (2) for t-dt, s-ds (with the opposite fluctuation) + DO jsmp = 1, nn_sto_eos*2 + jdof = (jsmp + 1) / 2 + zh = pdep(ji,jj,jk) * r1_Z0 ! depth + zt = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0 ! temperature + zstemp = pts (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp) + zs = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,jk) ! tmask + ! + zn3 = EOS013*zt & + & + EOS103*zs+EOS003 + ! + zn2 = (EOS022*zt & + & + EOS112*zs+EOS012)*zt & + & + (EOS202*zs+EOS102)*zs+EOS002 + ! + zn1 = (((EOS041*zt & + & + EOS131*zs+EOS031)*zt & + & + (EOS221*zs+EOS121)*zs+EOS021)*zt & + & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & + & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 + ! + zn0_sto(jsmp) = (((((EOS060*zt & + & + EOS150*zs+EOS050)*zt & + & + (EOS240*zs+EOS140)*zs+EOS040)*zt & + & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & + & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & + & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & + & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 + ! + zn_sto(jsmp) = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp) + END DO + ! + ! compute stochastic density as the mean of the (2*nn_sto_eos) densities + prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp + DO jsmp = 1, nn_sto_eos*2 + prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp) ! potential density referenced at the surface + ! + prd(ji,jj,jk) = prd(ji,jj,jk) + ( zn_sto(jsmp) * r1_rho0 - 1._wp ) ! density anomaly (masked) + END DO + prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos + prd (ji,jj,jk) = 0.5_wp * prd (ji,jj,jk) * ztm / nn_sto_eos + END DO ; END DO ; END DO + DEALLOCATE(zn0_sto,zn_sto,zsign) + ! Non-stochastic equation of state + ELSE + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zh = pdep(ji,jj,jk) * r1_Z0 ! depth + zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,jk) ! tmask + ! + zn3 = EOS013*zt & + & + EOS103*zs+EOS003 + ! + zn2 = (EOS022*zt & + & + EOS112*zs+EOS012)*zt & + & + (EOS202*zs+EOS102)*zs+EOS002 + ! + zn1 = (((EOS041*zt & + & + EOS131*zs+EOS031)*zt & + & + (EOS221*zs+EOS121)*zs+EOS021)*zt & + & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & + & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 + ! + zn0 = (((((EOS060*zt & + & + EOS150*zs+EOS050)*zt & + & + (EOS240*zs+EOS140)*zs+EOS040)*zt & + & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & + & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & + & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & + & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + prhop(ji,jj,jk) = zn0 * ztm ! potential density referenced at the surface + ! + prd(ji,jj,jk) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked) + END DO ; END DO ; END DO + ENDIF + + CASE( np_seos ) !== simplified EOS ==! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zt = pts (ji,jj,jk,jp_tem) - 10._wp + zs = pts (ji,jj,jk,jp_sal) - 35._wp + zh = pdep (ji,jj,jk) + ztm = tmask(ji,jj,jk) + ! ! potential density referenced at the surface + zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt & + & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs & + & - rn_nu * zt * zs + prhop(ji,jj,jk) = ( rho0 + zn ) * ztm + ! ! density anomaly (masked) + zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh + prd(ji,jj,jk) = zn * r1_rho0 * ztm + ! + END DO ; END DO ; END DO + ! + END SELECT + ! + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ' ) + ! + IF( ln_timing ) CALL timing_stop('eos-pot') + ! + END SUBROUTINE eos_insitu_pot_t + + + SUBROUTINE eos_insitu_2d( pts, pdep, prd ) + !! + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:) , INTENT( out) :: prd ! in situ density + !! + CALL eos_insitu_2d_t( pts, is_tile(pts), pdep, is_tile(pdep), prd, is_tile(prd) ) + END SUBROUTINE eos_insitu_2d + + + SUBROUTINE eos_insitu_2d_t( pts, ktts, pdep, ktdep, prd, ktrd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_insitu_2d *** + !! + !! ** Purpose : Compute the in situ density (ratio rho/rho0) from + !! potential temperature and salinity using an equation of state + !! selected in the nameos namelist. * 2D field case + !! + !! ** Action : - prd , the in situ density (no units) (unmasked) + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktts, ktdep, ktrd + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktts+1:,(ntsj-nn_hls-1)*ktts+1:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktdep+1:,(ntsj-nn_hls-1)*ktdep+1: ), INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktrd+1:,(ntsj-nn_hls-1)*ktrd+1: ), INTENT( out) :: prd ! in situ density + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt , zh , zs ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos2d') + ! + prd(:,:) = 0._wp + ! + SELECT CASE( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zh = pdep(ji,jj) * r1_Z0 ! depth + zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ! + zn3 = EOS013*zt & + & + EOS103*zs+EOS003 + ! + zn2 = (EOS022*zt & + & + EOS112*zs+EOS012)*zt & + & + (EOS202*zs+EOS102)*zs+EOS002 + ! + zn1 = (((EOS041*zt & + & + EOS131*zs+EOS031)*zt & + & + (EOS221*zs+EOS121)*zs+EOS021)*zt & + & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & + & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 + ! + zn0 = (((((EOS060*zt & + & + EOS150*zs+EOS050)*zt & + & + (EOS240*zs+EOS140)*zs+EOS040)*zt & + & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & + & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & + & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & + & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + prd(ji,jj) = zn * r1_rho0 - 1._wp ! unmasked in situ density anomaly + ! + END DO ; END DO + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zt = pts (ji,jj,jp_tem) - 10._wp + zs = pts (ji,jj,jp_sal) - 35._wp + zh = pdep (ji,jj) ! depth at the partial step level + ! + zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & + & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & + & - rn_nu * zt * zs + ! + prd(ji,jj) = zn * r1_rho0 ! unmasked in situ density anomaly + ! + END DO ; END DO + ! + END SELECT + ! + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) + ! + IF( ln_timing ) CALL timing_stop('eos2d') + ! + END SUBROUTINE eos_insitu_2d_t + + + SUBROUTINE eos_insitu_pot_2d( pts, prhop ) + !! + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(:,:) , INTENT( out) :: prhop ! potential density (surface referenced) + !! + CALL eos_insitu_pot_2d_t( pts, is_tile(pts), prhop, is_tile(prhop) ) + END SUBROUTINE eos_insitu_pot_2d + + + SUBROUTINE eos_insitu_pot_2d_t( pts, ktts, prhop, ktrhop ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_insitu_pot *** + !! + !! ** Purpose : Compute the in situ density (ratio rho/rho0) and the + !! potential volumic mass (Kg/m3) from potential temperature and + !! salinity fields using an equation of state selected in the + !! namelist. + !! + !! ** Action : + !! - prhop, the potential volumic mass (Kg/m3) + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktts, ktrhop + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktts+1:,(ntsj-nn_hls-1)*ktts+1:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktrhop+1:,(ntsj-nn_hls-1)*ktrhop+1: ), INTENT( out) :: prhop ! potential density (surface referenced) + ! + INTEGER :: ji, jj, jk, jsmp ! dummy loop indices + INTEGER :: jdof + REAL(wp) :: zt , zh , zstemp, zs , ztm ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - + REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos-pot') + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,1) ! tmask + ! + zn0 = (((((EOS060*zt & + & + EOS150*zs+EOS050)*zt & + & + (EOS240*zs+EOS140)*zs+EOS040)*zt & + & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & + & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & + & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & + & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 + ! + ! + prhop(ji,jj) = zn0 * ztm ! potential density referenced at the surface + ! + END DO ; END DO + + CASE( np_seos ) !== simplified EOS ==! + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zt = pts (ji,jj,jp_tem) - 10._wp + zs = pts (ji,jj,jp_sal) - 35._wp + ztm = tmask(ji,jj,1) + ! ! potential density referenced at the surface + zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt & + & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs & + & - rn_nu * zt * zs + prhop(ji,jj) = ( rho0 + zn ) * ztm + ! + END DO ; END DO + ! + END SELECT + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' pot: ', kdim=1 ) + ! + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' eos-pot: ' ) + ! + IF( ln_timing ) CALL timing_stop('eos-pot') + ! + END SUBROUTINE eos_insitu_pot_2d_t + + + SUBROUTINE rab_3d( pts, pab, Kmm ) + !! + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(:,:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio + !! + CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) + END SUBROUTINE rab_3d + + + SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rab_3d *** + !! + !! ** Purpose : Calculates thermal/haline expansion ratio at T-points + !! + !! ** Method : calculates alpha / beta at T-points + !! + !! ** Action : - pab : thermal/haline expansion ratio at T-points + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + INTEGER , INTENT(in ) :: ktts, ktab + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktts+1:,(ntsj-nn_hls-1)*ktts+1:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktab+1:,(ntsj-nn_hls-1)*ktab+1:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt , zh , zs , ztm ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('rab_3d') + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zh = (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * r1_Z0 ! depth + zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,jk) ! tmask + ! + ! alpha + zn3 = ALP003 + ! + zn2 = ALP012*zt + ALP102*zs+ALP002 + ! + zn1 = ((ALP031*zt & + & + ALP121*zs+ALP021)*zt & + & + (ALP211*zs+ALP111)*zs+ALP011)*zt & + & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 + ! + zn0 = ((((ALP050*zt & + & + ALP140*zs+ALP040)*zt & + & + (ALP230*zs+ALP130)*zs+ALP030)*zt & + & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & + & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & + & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(ji,jj,jk,jp_tem) = zn * r1_rho0 * ztm + ! + ! beta + zn3 = BET003 + ! + zn2 = BET012*zt + BET102*zs+BET002 + ! + zn1 = ((BET031*zt & + & + BET121*zs+BET021)*zt & + & + (BET211*zs+BET111)*zs+BET011)*zt & + & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 + ! + zn0 = ((((BET050*zt & + & + BET140*zs+BET040)*zt & + & + (BET230*zs+BET130)*zs+BET030)*zt & + & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & + & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & + & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(ji,jj,jk,jp_sal) = zn / zs * r1_rho0 * ztm + ! + END DO ; END DO ; END DO + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zt = pts (ji,jj,jk,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) + zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) + zh = (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ! depth in meters at t-point + ztm = tmask(ji,jj,jk) ! land/sea bottom mask = surf. mask + ! + zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs + pab(ji,jj,jk,jp_tem) = zn * r1_rho0 * ztm ! alpha + ! + zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt + pab(ji,jj,jk,jp_sal) = zn * r1_rho0 * ztm ! beta + ! + END DO ; END DO ; END DO + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'rab_3d:', ctmp1 ) + ! + END SELECT + ! + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', & + ! & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ' ) + ! + IF( ln_timing ) CALL timing_stop('rab_3d') + ! + END SUBROUTINE rab_3d_t + + + SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) + !! + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio + !! + CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) + END SUBROUTINE rab_2d + + + SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rab_2d *** + !! + !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) + !! + !! ** Action : - pab : thermal/haline expansion ratio at T-points + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + INTEGER , INTENT(in ) :: ktts, ktdep, ktab + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktts+1:,(ntsj-nn_hls-1)*ktts+1:,:), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktdep+1:,(ntsj-nn_hls-1)*ktdep+1: ), INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktab+1:,(ntsj-nn_hls-1)*ktab+1:,:), INTENT( out) :: pab ! thermal/haline expansion ratio + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt , zh , zs ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('rab_2d') + ! + pab(:,:,:) = 0._wp + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zh = pdep(ji,jj) * r1_Z0 ! depth + zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ! + ! alpha + zn3 = ALP003 + ! + zn2 = ALP012*zt + ALP102*zs+ALP002 + ! + zn1 = ((ALP031*zt & + & + ALP121*zs+ALP021)*zt & + & + (ALP211*zs+ALP111)*zs+ALP011)*zt & + & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 + ! + zn0 = ((((ALP050*zt & + & + ALP140*zs+ALP040)*zt & + & + (ALP230*zs+ALP130)*zs+ALP030)*zt & + & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & + & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & + & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(ji,jj,jp_tem) = zn * r1_rho0 + ! + ! beta + zn3 = BET003 + ! + zn2 = BET012*zt + BET102*zs+BET002 + ! + zn1 = ((BET031*zt & + & + BET121*zs+BET021)*zt & + & + (BET211*zs+BET111)*zs+BET011)*zt & + & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 + ! + zn0 = ((((BET050*zt & + & + BET140*zs+BET040)*zt & + & + (BET230*zs+BET130)*zs+BET030)*zt & + & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & + & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & + & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(ji,jj,jp_sal) = zn / zs * r1_rho0 + ! + ! + END DO ; END DO + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) + zs = pts (ji,jj,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) + zh = pdep (ji,jj) ! depth at the partial step level + ! + zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs + pab(ji,jj,jp_tem) = zn * r1_rho0 ! alpha + ! + zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt + pab(ji,jj,jp_sal) = zn * r1_rho0 ! beta + ! + END DO ; END DO + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'rab_2d:', ctmp1 ) + ! + END SELECT + ! + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', & + ! & tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) + ! + IF( ln_timing ) CALL timing_stop('rab_2d') + ! + END SUBROUTINE rab_2d_t + + + SUBROUTINE rab_0d( pts, pdep, pab, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rab_0d *** + !! + !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) + !! + !! ** Action : - pab : thermal/haline expansion ratio at T-points + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(jpts) , INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio + ! + REAL(wp) :: zt , zh , zs ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('rab_0d') + ! + pab(:) = 0._wp + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + ! + zh = pdep * r1_Z0 ! depth + zt = pts (jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ! + ! alpha + zn3 = ALP003 + ! + zn2 = ALP012*zt + ALP102*zs+ALP002 + ! + zn1 = ((ALP031*zt & + & + ALP121*zs+ALP021)*zt & + & + (ALP211*zs+ALP111)*zs+ALP011)*zt & + & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 + ! + zn0 = ((((ALP050*zt & + & + ALP140*zs+ALP040)*zt & + & + (ALP230*zs+ALP130)*zs+ALP030)*zt & + & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & + & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & + & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(jp_tem) = zn * r1_rho0 + ! + ! beta + zn3 = BET003 + ! + zn2 = BET012*zt + BET102*zs+BET002 + ! + zn1 = ((BET031*zt & + & + BET121*zs+BET021)*zt & + & + (BET211*zs+BET111)*zs+BET011)*zt & + & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 + ! + zn0 = ((((BET050*zt & + & + BET140*zs+BET040)*zt & + & + (BET230*zs+BET130)*zs+BET030)*zt & + & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & + & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & + & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(jp_sal) = zn / zs * r1_rho0 + ! + ! + ! + CASE( np_seos ) !== simplified EOS ==! + ! + zt = pts(jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) + zs = pts(jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) + zh = pdep ! depth at the partial step level + ! + zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs + pab(jp_tem) = zn * r1_rho0 ! alpha + ! + zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt + pab(jp_sal) = zn * r1_rho0 ! beta + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'rab_0d:', ctmp1 ) + ! + END SELECT + ! + IF( ln_timing ) CALL timing_stop('rab_0d') + ! + END SUBROUTINE rab_0d + + + SUBROUTINE bn2( pts, pab, pn2, Kmm ) + !! + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] + REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] + !! + CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) + END SUBROUTINE bn2 + + + SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bn2 *** + !! + !! ** Purpose : Compute the local Brunt-Vaisala frequency at the + !! time-step of the input arguments + !! + !! ** Method : pn2 = grav * (alpha dk[T] + beta dk[S] ) / e3w + !! where alpha and beta are given in pab, and computed on T-points. + !! N.B. N^2 is set one for all to zero at jk=1 in istate module. + !! + !! ** Action : pn2 : square of the brunt-vaisala frequency at w-point + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + INTEGER , INTENT(in ) :: ktab, ktn2 + REAL(dp), DIMENSION(jpi,jpj, jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktab+1:,(ntsj-nn_hls-1)*ktab+1:,:,:), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktn2+1:,(ntsj-nn_hls-1)*ktn2+1:,: ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zaw, zbw, zrw ! local scalars + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('bn2') + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90 + zrw = ( (gdepw_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) & + & / ( (gdept_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) + ! + zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw + zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw + ! + pn2(ji,jj,jk) = grav * ( zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) & + & - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) & + & / (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ' ) + ! + IF( ln_timing ) CALL timing_stop('bn2') + ! + END SUBROUTINE bn2_t + + + FUNCTION eos_pt_from_ct( ctmp, psal ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_pt_from_ct *** + !! + !! ** Purpose : Compute pot.temp. from cons. temp. [Celsius] + !! + !! ** Method : rational approximation (5/3th order) of TEOS-10 algorithm + !! checkvalue: pt=20.02391895 Celsius for sa=35.7g/kg, ct=20degC + !! + !! Reference : TEOS-10, UNESCO + !! Rational approximation to TEOS10 algorithm (rms error on WOA13 values: 4.0e-5 degC) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ctmp ! Cons. Temp [Celsius] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] + ! Leave result array automatic rather than making explicitly allocated + REAL(wp), DIMENSION(jpi,jpj) :: ptmp ! potential temperature [Celsius] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zt , zs , ztm ! local scalars + REAL(wp) :: zn , zd ! local scalars + REAL(wp) :: zdeltaS , z1_S0 , z1_T0 + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos_pt_from_ct') + ! + zdeltaS = 5._wp + z1_S0 = 0.875_wp/35.16504_wp + z1_T0 = 1._wp/40._wp + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zt = ctmp (ji,jj) * z1_T0 + zs = SQRT( ABS( psal(ji,jj) + zdeltaS ) * z1_S0 ) + ztm = tmask(ji,jj,1) + ! + zn = ((((-2.1385727895e-01_wp*zt & + & - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt & + & + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt & + & + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt & + & + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs & + & +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt & + & + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs & + & -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp + ! + zd = (2.0035003456_wp*zt & + & -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt & + & + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp + ! + ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm + ! + END DO ; END DO + ! + IF( ln_timing ) CALL timing_stop('eos_pt_from_ct') + ! + END FUNCTION eos_pt_from_ct + + + SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) + !! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:) , INTENT(out ) :: ptf ! freezing temperature [Celsius] + !! + CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) + END SUBROUTINE eos_fzp_2d + + + SUBROUTINE eos_fzp_2d_t( psal, ptf, kttf, pdep ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_fzp *** + !! + !! ** Purpose : Compute the freezing point temperature [Celsius] + !! + !! ** Method : UNESCO freezing point (ptf) in Celsius is given by + !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z + !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m + !! + !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kttf + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: psal ! salinity [psu] + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ), OPTIONAL :: pdep ! depth [m] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*kttf+1:,(ntsj-nn_hls-1)*kttf+1:), INTENT(out ) :: ptf ! freezing temperature [Celsius] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zt, zs, z1_S0 ! local scalars + !!---------------------------------------------------------------------- + ! + SELECT CASE ( neos ) + ! + CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==! + ! + z1_S0 = 1._wp / 35.16504_wp + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 ) ! square root salinity + ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & + & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp + END DO ; END DO + ptf(:,:) = ptf(:,:) * psal(:,:) + ! + IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) + ! + CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==! + ! + ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) & + & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:) + ! + IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'eos_fzp_2d:', ctmp1 ) + ! + END SELECT + ! + END SUBROUTINE eos_fzp_2d_t + + + SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_fzp *** + !! + !! ** Purpose : Compute the freezing point temperature [Celsius] + !! + !! ** Method : UNESCO freezing point (ptf) in Celsius is given by + !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z + !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m + !! + !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: psal ! salinity [psu] + REAL(wp), INTENT(in ), OPTIONAL :: pdep ! depth [m] + REAL(wp), INTENT(out) :: ptf ! freezing temperature [Celsius] + ! + REAL(wp) :: zs ! local scalars + !!---------------------------------------------------------------------- + ! + SELECT CASE ( neos ) + ! + CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==! + ! + zs = SQRT( ABS( psal ) / 35.16504_wp ) ! square root salinity + ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & + & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp + ptf = ptf * psal + ! + IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep + ! + CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==! + ! + ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal ) & + & - 2.154996e-4_wp * psal ) * psal + ! + IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'eos_fzp_0d:', ctmp1 ) + ! + END SELECT + ! + END SUBROUTINE eos_fzp_0d + + + SUBROUTINE eos_pen( pts, pab_pe, ppen, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_pen *** + !! + !! ** Purpose : Calculates nonlinear anomalies of alpha_PE, beta_PE and PE at T-points + !! + !! ** Method : PE is defined analytically as the vertical + !! primitive of EOS times -g integrated between 0 and z>0. + !! pen is the nonlinear bsq-PE anomaly: pen = ( PE - rho0 gz ) / rho0 gz - rd + !! = 1/z * /int_0^z rd dz - rd + !! where rd is the density anomaly (see eos_rhd function) + !! ab_pe are partial derivatives of PE anomaly with respect to T and S: + !! ab_pe(1) = - 1/(rho0 gz) * dPE/dT + drd/dT = - d(pen)/dT + !! ab_pe(2) = 1/(rho0 gz) * dPE/dS + drd/dS = d(pen)/dS + !! + !! ** Action : - pen : PE anomaly given at T-points + !! : - pab_pe : given at T-points + !! pab_pe(:,:,:,jp_tem) is alpha_pe + !! pab_pe(:,:,:,jp_sal) is beta_pe + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab_pe ! alpha_pe and beta_pe + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: ppen ! potential energy anomaly + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt , zh , zs , ztm ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2 ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos_pen') + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zh = (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * r1_Z0 ! depth + zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,jk) ! tmask + ! + ! potential energy non-linear anomaly + zn2 = (PEN012)*zt & + & + PEN102*zs+PEN002 + ! + zn1 = ((PEN021)*zt & + & + PEN111*zs+PEN011)*zt & + & + (PEN201*zs+PEN101)*zs+PEN001 + ! + zn0 = ((((PEN040)*zt & + & + PEN130*zs+PEN030)*zt & + & + (PEN220*zs+PEN120)*zs+PEN020)*zt & + & + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt & + & + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000 + ! + zn = ( zn2 * zh + zn1 ) * zh + zn0 + ! + ppen(ji,jj,jk) = zn * zh * r1_rho0 * ztm + ! + ! alphaPE non-linear anomaly + zn2 = APE002 + ! + zn1 = (APE011)*zt & + & + APE101*zs+APE001 + ! + zn0 = (((APE030)*zt & + & + APE120*zs+APE020)*zt & + & + (APE210*zs+APE110)*zs+APE010)*zt & + & + ((APE300*zs+APE200)*zs+APE100)*zs+APE000 + ! + zn = ( zn2 * zh + zn1 ) * zh + zn0 + ! + pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rho0 * ztm + ! + ! betaPE non-linear anomaly + zn2 = BPE002 + ! + zn1 = (BPE011)*zt & + & + BPE101*zs+BPE001 + ! + zn0 = (((BPE030)*zt & + & + BPE120*zs+BPE020)*zt & + & + (BPE210*zs+BPE110)*zs+BPE010)*zt & + & + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000 + ! + zn = ( zn2 * zh + zn1 ) * zh + zn0 + ! + pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rho0 * ztm + ! + END DO ; END DO ; END DO + ! + CASE( np_seos ) !== Vallis (2006) simplified EOS ==! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zt = pts(ji,jj,jk,jp_tem) - 10._wp ! temperature anomaly (t-T0) + zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) + zh = (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ! depth in meters at t-point + ztm = tmask(ji,jj,jk) ! tmask + zn = 0.5_wp * zh * r1_rho0 * ztm + ! ! Potential Energy + ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn + ! ! alphaPE + pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn + pab_pe(ji,jj,jk,jp_sal) = rn_b0 * rn_mu2 * zn + ! + END DO ; END DO ; END DO + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'eos_pen:', ctmp1 ) + ! + END SELECT + ! + IF( ln_timing ) CALL timing_stop('eos_pen') + ! + END SUBROUTINE eos_pen + + + SUBROUTINE eos_init + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_init *** + !! + !! ** Purpose : initializations for the equation of state + !! + !! ** Method : Read the namelist nameos and control the parameters + !!---------------------------------------------------------------------- + INTEGER :: ios ! local integer + INTEGER :: ioptio ! local integer + !! + NAMELIST/nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, rn_a0, rn_b0, rn_lambda1, rn_mu1, & + & rn_lambda2, rn_mu2, rn_nu + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist' ) + ! + READ ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist' ) + IF(lwm) WRITE( numond, nameos ) + ! + rho0 = 1026._wp !: volumic mass of reference [kg/m3] + rcp = 3991.86795711963_wp !: heat capacity [J/K] + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'eos_init : equation of state' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist nameos : Chosen the Equation Of Seawater (EOS)' + WRITE(numout,*) ' TEOS-10 : rho=F(Conservative Temperature, Absolute Salinity, depth) ln_TEOS10 = ', ln_TEOS10 + WRITE(numout,*) ' EOS-80 : rho=F(Potential Temperature, Practical Salinity, depth) ln_EOS80 = ', ln_EOS80 + WRITE(numout,*) ' S-EOS : rho=F(Conservative Temperature, Absolute Salinity, depth) ln_SEOS = ', ln_SEOS + ENDIF + + ! Check options for equation of state & set neos based on logical flags + ioptio = 0 + IF( ln_TEOS10 ) THEN ; ioptio = ioptio+1 ; neos = np_teos10 ; ENDIF + IF( ln_EOS80 ) THEN ; ioptio = ioptio+1 ; neos = np_eos80 ; ENDIF + IF( ln_SEOS ) THEN ; ioptio = ioptio+1 ; neos = np_seos ; ENDIF + IF( ioptio /= 1 ) CALL ctl_stop("Exactly one equation of state option must be selected") + ! + SELECT CASE( neos ) ! check option + ! + CASE( np_teos10 ) !== polynomial TEOS-10 ==! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> use of TEOS-10 equation of state (cons. temp. and abs. salinity)' + ! + l_useCT = .TRUE. ! model temperature is Conservative temperature + ! + rdeltaS = 32._wp + r1_S0 = 0.875_wp/35.16504_wp + r1_T0 = 1._wp/40._wp + r1_Z0 = 1.e-4_wp + ! + EOS000 = 8.0189615746e+02_wp + EOS100 = 8.6672408165e+02_wp + EOS200 = -1.7864682637e+03_wp + EOS300 = 2.0375295546e+03_wp + EOS400 = -1.2849161071e+03_wp + EOS500 = 4.3227585684e+02_wp + EOS600 = -6.0579916612e+01_wp + EOS010 = 2.6010145068e+01_wp + EOS110 = -6.5281885265e+01_wp + EOS210 = 8.1770425108e+01_wp + EOS310 = -5.6888046321e+01_wp + EOS410 = 1.7681814114e+01_wp + EOS510 = -1.9193502195_wp + EOS020 = -3.7074170417e+01_wp + EOS120 = 6.1548258127e+01_wp + EOS220 = -6.0362551501e+01_wp + EOS320 = 2.9130021253e+01_wp + EOS420 = -5.4723692739_wp + EOS030 = 2.1661789529e+01_wp + EOS130 = -3.3449108469e+01_wp + EOS230 = 1.9717078466e+01_wp + EOS330 = -3.1742946532_wp + EOS040 = -8.3627885467_wp + EOS140 = 1.1311538584e+01_wp + EOS240 = -5.3563304045_wp + EOS050 = 5.4048723791e-01_wp + EOS150 = 4.8169980163e-01_wp + EOS060 = -1.9083568888e-01_wp + EOS001 = 1.9681925209e+01_wp + EOS101 = -4.2549998214e+01_wp + EOS201 = 5.0774768218e+01_wp + EOS301 = -3.0938076334e+01_wp + EOS401 = 6.6051753097_wp + EOS011 = -1.3336301113e+01_wp + EOS111 = -4.4870114575_wp + EOS211 = 5.0042598061_wp + EOS311 = -6.5399043664e-01_wp + EOS021 = 6.7080479603_wp + EOS121 = 3.5063081279_wp + EOS221 = -1.8795372996_wp + EOS031 = -2.4649669534_wp + EOS131 = -5.5077101279e-01_wp + EOS041 = 5.5927935970e-01_wp + EOS002 = 2.0660924175_wp + EOS102 = -4.9527603989_wp + EOS202 = 2.5019633244_wp + EOS012 = 2.0564311499_wp + EOS112 = -2.1311365518e-01_wp + EOS022 = -1.2419983026_wp + EOS003 = -2.3342758797e-02_wp + EOS103 = -1.8507636718e-02_wp + EOS013 = 3.7969820455e-01_wp + ! + ALP000 = -6.5025362670e-01_wp + ALP100 = 1.6320471316_wp + ALP200 = -2.0442606277_wp + ALP300 = 1.4222011580_wp + ALP400 = -4.4204535284e-01_wp + ALP500 = 4.7983755487e-02_wp + ALP010 = 1.8537085209_wp + ALP110 = -3.0774129064_wp + ALP210 = 3.0181275751_wp + ALP310 = -1.4565010626_wp + ALP410 = 2.7361846370e-01_wp + ALP020 = -1.6246342147_wp + ALP120 = 2.5086831352_wp + ALP220 = -1.4787808849_wp + ALP320 = 2.3807209899e-01_wp + ALP030 = 8.3627885467e-01_wp + ALP130 = -1.1311538584_wp + ALP230 = 5.3563304045e-01_wp + ALP040 = -6.7560904739e-02_wp + ALP140 = -6.0212475204e-02_wp + ALP050 = 2.8625353333e-02_wp + ALP001 = 3.3340752782e-01_wp + ALP101 = 1.1217528644e-01_wp + ALP201 = -1.2510649515e-01_wp + ALP301 = 1.6349760916e-02_wp + ALP011 = -3.3540239802e-01_wp + ALP111 = -1.7531540640e-01_wp + ALP211 = 9.3976864981e-02_wp + ALP021 = 1.8487252150e-01_wp + ALP121 = 4.1307825959e-02_wp + ALP031 = -5.5927935970e-02_wp + ALP002 = -5.1410778748e-02_wp + ALP102 = 5.3278413794e-03_wp + ALP012 = 6.2099915132e-02_wp + ALP003 = -9.4924551138e-03_wp + ! + BET000 = 1.0783203594e+01_wp + BET100 = -4.4452095908e+01_wp + BET200 = 7.6048755820e+01_wp + BET300 = -6.3944280668e+01_wp + BET400 = 2.6890441098e+01_wp + BET500 = -4.5221697773_wp + BET010 = -8.1219372432e-01_wp + BET110 = 2.0346663041_wp + BET210 = -2.1232895170_wp + BET310 = 8.7994140485e-01_wp + BET410 = -1.1939638360e-01_wp + BET020 = 7.6574242289e-01_wp + BET120 = -1.5019813020_wp + BET220 = 1.0872489522_wp + BET320 = -2.7233429080e-01_wp + BET030 = -4.1615152308e-01_wp + BET130 = 4.9061350869e-01_wp + BET230 = -1.1847737788e-01_wp + BET040 = 1.4073062708e-01_wp + BET140 = -1.3327978879e-01_wp + BET050 = 5.9929880134e-03_wp + BET001 = -5.2937873009e-01_wp + BET101 = 1.2634116779_wp + BET201 = -1.1547328025_wp + BET301 = 3.2870876279e-01_wp + BET011 = -5.5824407214e-02_wp + BET111 = 1.2451933313e-01_wp + BET211 = -2.4409539932e-02_wp + BET021 = 4.3623149752e-02_wp + BET121 = -4.6767901790e-02_wp + BET031 = -6.8523260060e-03_wp + BET002 = -6.1618945251e-02_wp + BET102 = 6.2255521644e-02_wp + BET012 = -2.6514181169e-03_wp + BET003 = -2.3025968587e-04_wp + ! + PEN000 = -9.8409626043_wp + PEN100 = 2.1274999107e+01_wp + PEN200 = -2.5387384109e+01_wp + PEN300 = 1.5469038167e+01_wp + PEN400 = -3.3025876549_wp + PEN010 = 6.6681505563_wp + PEN110 = 2.2435057288_wp + PEN210 = -2.5021299030_wp + PEN310 = 3.2699521832e-01_wp + PEN020 = -3.3540239802_wp + PEN120 = -1.7531540640_wp + PEN220 = 9.3976864981e-01_wp + PEN030 = 1.2324834767_wp + PEN130 = 2.7538550639e-01_wp + PEN040 = -2.7963967985e-01_wp + PEN001 = -1.3773949450_wp + PEN101 = 3.3018402659_wp + PEN201 = -1.6679755496_wp + PEN011 = -1.3709540999_wp + PEN111 = 1.4207577012e-01_wp + PEN021 = 8.2799886843e-01_wp + PEN002 = 1.7507069098e-02_wp + PEN102 = 1.3880727538e-02_wp + PEN012 = -2.8477365341e-01_wp + ! + APE000 = -1.6670376391e-01_wp + APE100 = -5.6087643219e-02_wp + APE200 = 6.2553247576e-02_wp + APE300 = -8.1748804580e-03_wp + APE010 = 1.6770119901e-01_wp + APE110 = 8.7657703198e-02_wp + APE210 = -4.6988432490e-02_wp + APE020 = -9.2436260751e-02_wp + APE120 = -2.0653912979e-02_wp + APE030 = 2.7963967985e-02_wp + APE001 = 3.4273852498e-02_wp + APE101 = -3.5518942529e-03_wp + APE011 = -4.1399943421e-02_wp + APE002 = 7.1193413354e-03_wp + ! + BPE000 = 2.6468936504e-01_wp + BPE100 = -6.3170583896e-01_wp + BPE200 = 5.7736640125e-01_wp + BPE300 = -1.6435438140e-01_wp + BPE010 = 2.7912203607e-02_wp + BPE110 = -6.2259666565e-02_wp + BPE210 = 1.2204769966e-02_wp + BPE020 = -2.1811574876e-02_wp + BPE120 = 2.3383950895e-02_wp + BPE030 = 3.4261630030e-03_wp + BPE001 = 4.1079296834e-02_wp + BPE101 = -4.1503681096e-02_wp + BPE011 = 1.7676120780e-03_wp + BPE002 = 1.7269476440e-04_wp + ! + CASE( np_eos80 ) !== polynomial EOS-80 formulation ==! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> use of EOS-80 equation of state (pot. temp. and pract. salinity)' + ! + l_useCT = .FALSE. ! model temperature is Potential temperature + rdeltaS = 20._wp + r1_S0 = 1._wp/40._wp + r1_T0 = 1._wp/40._wp + r1_Z0 = 1.e-4_wp + ! + EOS000 = 9.5356891948e+02_wp + EOS100 = 1.7136499189e+02_wp + EOS200 = -3.7501039454e+02_wp + EOS300 = 5.1856810420e+02_wp + EOS400 = -3.7264470465e+02_wp + EOS500 = 1.4302533998e+02_wp + EOS600 = -2.2856621162e+01_wp + EOS010 = 1.0087518651e+01_wp + EOS110 = -1.3647741861e+01_wp + EOS210 = 8.8478359933_wp + EOS310 = -7.2329388377_wp + EOS410 = 1.4774410611_wp + EOS510 = 2.0036720553e-01_wp + EOS020 = -2.5579830599e+01_wp + EOS120 = 2.4043512327e+01_wp + EOS220 = -1.6807503990e+01_wp + EOS320 = 8.3811577084_wp + EOS420 = -1.9771060192_wp + EOS030 = 1.6846451198e+01_wp + EOS130 = -2.1482926901e+01_wp + EOS230 = 1.0108954054e+01_wp + EOS330 = -6.2675951440e-01_wp + EOS040 = -8.0812310102_wp + EOS140 = 1.0102374985e+01_wp + EOS240 = -4.8340368631_wp + EOS050 = 1.2079167803_wp + EOS150 = 1.1515380987e-01_wp + EOS060 = -2.4520288837e-01_wp + EOS001 = 1.0748601068e+01_wp + EOS101 = -1.7817043500e+01_wp + EOS201 = 2.2181366768e+01_wp + EOS301 = -1.6750916338e+01_wp + EOS401 = 4.1202230403_wp + EOS011 = -1.5852644587e+01_wp + EOS111 = -7.6639383522e-01_wp + EOS211 = 4.1144627302_wp + EOS311 = -6.6955877448e-01_wp + EOS021 = 9.9994861860_wp + EOS121 = -1.9467067787e-01_wp + EOS221 = -1.2177554330_wp + EOS031 = -3.4866102017_wp + EOS131 = 2.2229155620e-01_wp + EOS041 = 5.9503008642e-01_wp + EOS002 = 1.0375676547_wp + EOS102 = -3.4249470629_wp + EOS202 = 2.0542026429_wp + EOS012 = 2.1836324814_wp + EOS112 = -3.4453674320e-01_wp + EOS022 = -1.2548163097_wp + EOS003 = 1.8729078427e-02_wp + EOS103 = -5.7238495240e-02_wp + EOS013 = 3.8306136687e-01_wp + ! + ALP000 = -2.5218796628e-01_wp + ALP100 = 3.4119354654e-01_wp + ALP200 = -2.2119589983e-01_wp + ALP300 = 1.8082347094e-01_wp + ALP400 = -3.6936026529e-02_wp + ALP500 = -5.0091801383e-03_wp + ALP010 = 1.2789915300_wp + ALP110 = -1.2021756164_wp + ALP210 = 8.4037519952e-01_wp + ALP310 = -4.1905788542e-01_wp + ALP410 = 9.8855300959e-02_wp + ALP020 = -1.2634838399_wp + ALP120 = 1.6112195176_wp + ALP220 = -7.5817155402e-01_wp + ALP320 = 4.7006963580e-02_wp + ALP030 = 8.0812310102e-01_wp + ALP130 = -1.0102374985_wp + ALP230 = 4.8340368631e-01_wp + ALP040 = -1.5098959754e-01_wp + ALP140 = -1.4394226233e-02_wp + ALP050 = 3.6780433255e-02_wp + ALP001 = 3.9631611467e-01_wp + ALP101 = 1.9159845880e-02_wp + ALP201 = -1.0286156825e-01_wp + ALP301 = 1.6738969362e-02_wp + ALP011 = -4.9997430930e-01_wp + ALP111 = 9.7335338937e-03_wp + ALP211 = 6.0887771651e-02_wp + ALP021 = 2.6149576513e-01_wp + ALP121 = -1.6671866715e-02_wp + ALP031 = -5.9503008642e-02_wp + ALP002 = -5.4590812035e-02_wp + ALP102 = 8.6134185799e-03_wp + ALP012 = 6.2740815484e-02_wp + ALP003 = -9.5765341718e-03_wp + ! + BET000 = 2.1420623987_wp + BET100 = -9.3752598635_wp + BET200 = 1.9446303907e+01_wp + BET300 = -1.8632235232e+01_wp + BET400 = 8.9390837485_wp + BET500 = -1.7142465871_wp + BET010 = -1.7059677327e-01_wp + BET110 = 2.2119589983e-01_wp + BET210 = -2.7123520642e-01_wp + BET310 = 7.3872053057e-02_wp + BET410 = 1.2522950346e-02_wp + BET020 = 3.0054390409e-01_wp + BET120 = -4.2018759976e-01_wp + BET220 = 3.1429341406e-01_wp + BET320 = -9.8855300959e-02_wp + BET030 = -2.6853658626e-01_wp + BET130 = 2.5272385134e-01_wp + BET230 = -2.3503481790e-02_wp + BET040 = 1.2627968731e-01_wp + BET140 = -1.2085092158e-01_wp + BET050 = 1.4394226233e-03_wp + BET001 = -2.2271304375e-01_wp + BET101 = 5.5453416919e-01_wp + BET201 = -6.2815936268e-01_wp + BET301 = 2.0601115202e-01_wp + BET011 = -9.5799229402e-03_wp + BET111 = 1.0286156825e-01_wp + BET211 = -2.5108454043e-02_wp + BET021 = -2.4333834734e-03_wp + BET121 = -3.0443885826e-02_wp + BET031 = 2.7786444526e-03_wp + BET002 = -4.2811838287e-02_wp + BET102 = 5.1355066072e-02_wp + BET012 = -4.3067092900e-03_wp + BET003 = -7.1548119050e-04_wp + ! + PEN000 = -5.3743005340_wp + PEN100 = 8.9085217499_wp + PEN200 = -1.1090683384e+01_wp + PEN300 = 8.3754581690_wp + PEN400 = -2.0601115202_wp + PEN010 = 7.9263222935_wp + PEN110 = 3.8319691761e-01_wp + PEN210 = -2.0572313651_wp + PEN310 = 3.3477938724e-01_wp + PEN020 = -4.9997430930_wp + PEN120 = 9.7335338937e-02_wp + PEN220 = 6.0887771651e-01_wp + PEN030 = 1.7433051009_wp + PEN130 = -1.1114577810e-01_wp + PEN040 = -2.9751504321e-01_wp + PEN001 = -6.9171176978e-01_wp + PEN101 = 2.2832980419_wp + PEN201 = -1.3694684286_wp + PEN011 = -1.4557549876_wp + PEN111 = 2.2969116213e-01_wp + PEN021 = 8.3654420645e-01_wp + PEN002 = -1.4046808820e-02_wp + PEN102 = 4.2928871430e-02_wp + PEN012 = -2.8729602515e-01_wp + ! + APE000 = -1.9815805734e-01_wp + APE100 = -9.5799229402e-03_wp + APE200 = 5.1430784127e-02_wp + APE300 = -8.3694846809e-03_wp + APE010 = 2.4998715465e-01_wp + APE110 = -4.8667669469e-03_wp + APE210 = -3.0443885826e-02_wp + APE020 = -1.3074788257e-01_wp + APE120 = 8.3359333577e-03_wp + APE030 = 2.9751504321e-02_wp + APE001 = 3.6393874690e-02_wp + APE101 = -5.7422790533e-03_wp + APE011 = -4.1827210323e-02_wp + APE002 = 7.1824006288e-03_wp + ! + BPE000 = 1.1135652187e-01_wp + BPE100 = -2.7726708459e-01_wp + BPE200 = 3.1407968134e-01_wp + BPE300 = -1.0300557601e-01_wp + BPE010 = 4.7899614701e-03_wp + BPE110 = -5.1430784127e-02_wp + BPE210 = 1.2554227021e-02_wp + BPE020 = 1.2166917367e-03_wp + BPE120 = 1.5221942913e-02_wp + BPE030 = -1.3893222263e-03_wp + BPE001 = 2.8541225524e-02_wp + BPE101 = -3.4236710714e-02_wp + BPE011 = 2.8711395266e-03_wp + BPE002 = 5.3661089288e-04_wp + ! + CASE( np_seos ) !== Simplified EOS ==! + + r1_S0 = 0.875_wp/35.16504_wp ! Used to convert CT in potential temperature when using bulk formulae (eos_pt_from_ct) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> use of simplified eos: ' + WRITE(numout,*) ' rhd(dT=T-10,dS=S-35,Z) = [-a0*(1+lambda1/2*dT+mu1*Z)*dT ' + WRITE(numout,*) ' + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS] / rho0' + WRITE(numout,*) ' with the following coefficients :' + WRITE(numout,*) ' thermal exp. coef. rn_a0 = ', rn_a0 + WRITE(numout,*) ' saline cont. coef. rn_b0 = ', rn_b0 + WRITE(numout,*) ' cabbeling coef. rn_lambda1 = ', rn_lambda1 + WRITE(numout,*) ' cabbeling coef. rn_lambda2 = ', rn_lambda2 + WRITE(numout,*) ' thermobar. coef. rn_mu1 = ', rn_mu1 + WRITE(numout,*) ' thermobar. coef. rn_mu2 = ', rn_mu2 + WRITE(numout,*) ' 2nd cabbel. coef. rn_nu = ', rn_nu + WRITE(numout,*) ' Caution: rn_beta0=0 incompatible with ddm parameterization ' + ENDIF + l_useCT = .TRUE. ! Use conservative temperature + ! + CASE DEFAULT !== ERROR in neos ==! + WRITE(ctmp1,*) ' bad flag value for neos = ', neos, '. You should never see this error' + CALL ctl_stop( ctmp1 ) + ! + END SELECT + ! + rho0_rcp = rho0 * rcp + r1_rho0 = 1._wp / rho0 + r1_rcp = 1._wp / rcp + r1_rho0_rcp = 1._wp / rho0_rcp + ! + IF(lwp) THEN + IF( l_useCT ) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> model uses Conservative Temperature' + WRITE(numout,*) ' Important: model must be initialized with CT and SA fields' + ELSE + WRITE(numout,*) + WRITE(numout,*) ' ==>>> model does not use Conservative Temperature' + ENDIF + ENDIF + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Associated physical constant' + IF(lwp) WRITE(numout,*) ' volumic mass of reference rho0 = ', rho0 , ' kg/m^3' + IF(lwp) WRITE(numout,*) ' 1. / rho0 r1_rho0 = ', r1_rho0, ' m^3/kg' + IF(lwp) WRITE(numout,*) ' ocean specific heat rcp = ', rcp , ' J/Kelvin' + IF(lwp) WRITE(numout,*) ' rho0 * rcp rho0_rcp = ', rho0_rcp + IF(lwp) WRITE(numout,*) ' 1. / ( rho0 * rcp ) r1_rho0_rcp = ', r1_rho0_rcp + ! + END SUBROUTINE eos_init + + !!====================================================================== +END MODULE eosbn2 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/fldread.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/fldread.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c0c416e1ac5d64be003427e76cb37dff35033a75 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/fldread.f90 @@ -0,0 +1,1614 @@ + + + + + + + + + + + + + +MODULE fldread + !!====================================================================== + !! *** MODULE fldread *** + !! Ocean forcing: read input field for surface boundary condition + !!===================================================================== + !! History : 2.0 ! 2006-06 (S. Masson, G. Madec) Original code + !! 3.0 ! 2008-05 (S. Alderson) Modified for Interpolation in memory from input grid to model grid + !! 3.4 ! 2013-10 (D. Delrosso, P. Oddo) suppression of land point prior to interpolation + !! ! 12-2015 (J. Harle) Adding BDY on-the-fly interpolation + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! fld_read : read input fields used for the computation of the surface boundary condition + !! fld_init : initialization of field read + !! fld_def : define the record(s) of the file and its name + !! fld_get : read the data + !! fld_map : read global data from file and map onto local data using a general mapping (use for open boundaries) + !! fld_rot : rotate the vector fields onto the local grid direction + !! fld_clopn : close/open the files + !! fld_fill : fill the data structure with the associated information read in namelist + !! wgt_list : manage the weights used for interpolation + !! wgt_print : print the list of known weights + !! fld_weight : create a WGT structure and fill in data from file, restructuring as required + !! apply_seaoverland : fill land with ocean values + !! seaoverland : create shifted matrices for seaoverland application + !! fld_interp : apply weights to input gridded data to create data on model grid + !! fld_filename : define the filename according to a given date + !! ksec_week : function returning seconds between 00h of the beginning of the week and half of the current time step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constant + USE sbc_oce ! surface boundary conditions : fields + USE geo2ocean ! for vector rotation on to model grid + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE ioipsl , ONLY : ymds2ju, ju2ymds ! for calendar + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary conditions (online interpolation case) + + IMPLICIT NONE + PRIVATE + + PUBLIC fld_map ! routine called by tides_init + PUBLIC fld_read, fld_fill ! called by sbc... modules + PUBLIC fld_def + + TYPE, PUBLIC :: FLD_N !: Namelist field informations + CHARACTER(len = 256) :: clname ! generic name of the NetCDF flux file + REAL(wp) :: freqh ! frequency of each flux file + CHARACTER(len = 34) :: clvar ! generic name of the variable in the NetCDF flux file + LOGICAL :: ln_tint ! time interpolation or not (T/F) + LOGICAL :: ln_clim ! climatology or not (T/F) + CHARACTER(len = 8) :: clftyp ! type of data file 'daily', 'monthly' or yearly' + CHARACTER(len = 256) :: wname ! generic name of a NetCDF weights file to be used, blank if not + CHARACTER(len = 34) :: vcomp ! symbolic component name if a vector that needs rotation + ! ! a string starting with "U" or "V" for each component + ! ! chars 2 onwards identify which components go together + CHARACTER(len = 34) :: lname ! generic name of a NetCDF land/sea mask file to be used, blank if not + ! ! 0=sea 1=land + END TYPE FLD_N + + TYPE, PUBLIC :: FLD !: Input field related variables + CHARACTER(len = 256) :: clrootname ! generic name of the NetCDF file + CHARACTER(len = 256) :: clname ! current name of the NetCDF file + REAL(wp) :: freqh ! frequency of each flux file + CHARACTER(len = 34) :: clvar ! generic name of the variable in the NetCDF flux file + LOGICAL :: ln_tint ! time interpolation or not (T/F) + LOGICAL :: ln_clim ! climatology or not (T/F) + CHARACTER(len = 8) :: clftyp ! type of data file 'daily', 'monthly' or yearly' + CHARACTER(len = 1) :: cltype ! nature of grid-points: T, U, V... + REAL(wp) :: zsgn ! -1. the sign change across the north fold, = 1. otherwise + INTEGER :: num ! iom id of the jpfld files to be read + INTEGER , DIMENSION(2,2) :: nrec ! before/after record (1: index, 2: second since Jan. 1st 00h of yr nit000) + INTEGER :: nbb ! index of before values + INTEGER :: naa ! index of after values + INTEGER , ALLOCATABLE, DIMENSION(:) :: nrecsec ! + REAL(wp), POINTER, DIMENSION(:,:,: ) :: fnow ! input fields interpolated to now time step + REAL(wp), POINTER, DIMENSION(:,:,:,:) :: fdta ! 2 consecutive record of input fields + CHARACTER(len = 256) :: wgtname ! current name of the NetCDF weight file acting as a key + ! ! into the WGTLIST structure + CHARACTER(len = 34) :: vcomp ! symbolic name for a vector component that needs rotation + LOGICAL, DIMENSION(2) :: rotn ! flag to indicate whether before/after field has been rotated + INTEGER :: nreclast ! last record to be read in the current file + CHARACTER(len = 256) :: lsmname ! current name of the NetCDF mask file acting as a key + ! ! + ! ! Variables related to BDY + INTEGER :: igrd ! grid type for bdy data + INTEGER :: ibdy ! bdy set id number + INTEGER, POINTER, DIMENSION(:) :: imap ! Array of integer pointers to 1D arrays + LOGICAL :: ltotvel ! total velocity or not (T/F) + LOGICAL :: lzint ! T if it requires a vertical interpolation + END TYPE FLD + +!$AGRIF_DO_NOT_TREAT + + !! keep list of all weights variables so they're only read in once + !! need to add AGRIF directives not to process this structure + !! also need to force wgtname to include AGRIF nest number + TYPE :: WGT !: Input weights related variables + CHARACTER(len = 256) :: wgtname ! current name of the NetCDF weight file + INTEGER , DIMENSION(2) :: ddims ! shape of input grid + INTEGER , DIMENSION(2) :: botleft ! top left corner of box in input grid containing + ! ! current processor grid + INTEGER , DIMENSION(2) :: topright ! top right corner of box + INTEGER :: jpiwgt ! width of box on input grid + INTEGER :: jpjwgt ! height of box on input grid + INTEGER :: numwgt ! number of weights (4=bilinear, 16=bicubic) + INTEGER :: nestid ! for agrif, keep track of nest we're in + INTEGER :: overlap ! =0 when cyclic grid has no overlapping EW columns + ! ! =>1 when they have one or more overlapping columns + ! ! =-1 not cyclic + LOGICAL :: cyclic ! east-west cyclic or not + INTEGER, DIMENSION(:,:,:), POINTER :: data_jpi ! array of source integers + INTEGER, DIMENSION(:,:,:), POINTER :: data_jpj ! array of source integers + REAL(wp), DIMENSION(:,:,:), POINTER :: data_wgt ! array of weights on model grid + REAL(wp), DIMENSION(:,:,:), POINTER :: fly_dta ! array of values on input grid + REAL(wp), DIMENSION(:,:,:), POINTER :: col ! temporary array for reading in columns + END TYPE WGT + + INTEGER, PARAMETER :: tot_wgts = 20 + TYPE( WGT ), DIMENSION(tot_wgts) :: ref_wgts ! array of wgts + INTEGER :: nxt_wgt = 1 ! point to next available space in ref_wgts array + INTEGER :: nflag = 0 + REAL(wp), PARAMETER :: undeff_lsm = -999.00_wp + +!$AGRIF_END_DO_NOT_TREAT + + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: fldread.F90 15023 2021-06-18 14:35:25Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE fld_read( kt, kn_fsbc, sd, kit, pt_offset, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_read *** + !! + !! ** Purpose : provide at each time step the surface ocean fluxes + !! (momentum, heat, freshwater and runoff) + !! + !! ** Method : READ each input fields in NetCDF files using IOM + !! and intepolate it to the model time-step. + !! Several assumptions are made on the input file: + !! blahblahblah.... + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) + TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables + INTEGER , INTENT(in ), OPTIONAL :: kit ! subcycle timestep for timesplitting option + REAL(wp) , INTENT(in ), OPTIONAL :: pt_offset ! provide fields at time other than "now" + INTEGER , INTENT(in ), OPTIONAL :: Kmm ! ocean time level index + !! + INTEGER :: imf ! size of the structure sd + INTEGER :: jf ! dummy indices + INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step + INTEGER :: ibb, iaa ! shorter name for sd(jf)%nbb and sd(jf)%naa + LOGICAL :: ll_firstcall ! true if this is the first call to fld_read for this set of fields + REAL(wp) :: zt_offset ! local time offset variable + REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation + REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation + CHARACTER(LEN=1000) :: clfmt ! write format + !!--------------------------------------------------------------------- + ll_firstcall = kt == nit000 + IF( PRESENT(kit) ) ll_firstcall = ll_firstcall .and. kit == 1 + + IF( nn_components == jp_iam_sas ) THEN ; zt_offset = REAL( nn_fsbc, wp ) + ELSE ; zt_offset = 0. + ENDIF + IF( PRESENT(pt_offset) ) zt_offset = pt_offset + + ! Note that all varibles starting by nsec_* are shifted time by +1/2 time step to be centrered + IF( PRESENT(kit) ) THEN ! ignore kn_fsbc in this case + isecsbc = nsec_year + nsec1jan000 + NINT( ( REAL( kit,wp) + zt_offset ) * rn_Dt / REAL(nn_e,wp) ) + ELSE ! middle of sbc time step + ! note: we use kn_fsbc-1 because nsec_year is defined at the middle of the current time step + isecsbc = nsec_year + nsec1jan000 + NINT( ( 0.5*REAL(kn_fsbc-1,wp) + zt_offset ) * rn_Dt ) + ENDIF + imf = SIZE( sd ) + ! + IF( ll_firstcall ) THEN ! initialization + DO jf = 1, imf + IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE + CALL fld_init( isecsbc, sd(jf) ) ! read each before field (put them in after as they will be swapped) + END DO + IF( lwp ) CALL wgt_print() ! control print + ENDIF + ! ! ====================================== ! + IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! update field at each kn_fsbc time-step ! + ! ! ====================================== ! + ! + DO jf = 1, imf ! --- loop over field --- ! + ! + IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE + CALL fld_update( isecsbc, sd(jf), Kmm ) + ! + END DO ! --- end loop over field --- ! + + CALL fld_rot( kt, sd ) ! rotate vector before/now/after fields if needed + + DO jf = 1, imf ! --- loop over field --- ! + ! + IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE + ! + ibb = sd(jf)%nbb ; iaa = sd(jf)%naa + ! + IF( sd(jf)%ln_tint ) THEN ! temporal interpolation + IF(lwp .AND. ( kt - nit000 <= 20 .OR. nitend - kt <= 20 ) ) THEN + clfmt = "(' fld_read: var ', a, ' kt = ', i8, ' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // & + & "', records b/a: ', i6.4, '/', i6.4, ' (days ', f9.4,'/', f9.4, ')')" + WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & + & sd(jf)%nrec(1,ibb), sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday + IF( zt_offset /= 0._wp ) WRITE(numout, *) ' zt_offset is : ', zt_offset + ENDIF + ! temporal interpolation weights + ztinta = REAL( isecsbc - sd(jf)%nrec(2,ibb), wp ) / REAL( sd(jf)%nrec(2,iaa) - sd(jf)%nrec(2,ibb), wp ) + ztintb = 1. - ztinta + sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:,ibb) + ztinta * sd(jf)%fdta(:,:,:,iaa) + ELSE ! nothing to do... + IF(lwp .AND. ( kt - nit000 <= 20 .OR. nitend - kt <= 20 ) ) THEN + clfmt = "(' fld_read: var ', a, ' kt = ', i8,' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // & + & "', record: ', i6.4, ' (days ', f9.4, ' <-> ', f9.4, ')')" + WRITE(numout, clfmt) TRIM(sd(jf)%clvar), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & + & sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday + ENDIF + ENDIF + ! + IF( kt == nitend - kn_fsbc + 1 ) CALL iom_close( sd(jf)%num ) ! Close the input files + + END DO ! --- end loop over field --- ! + ! + ENDIF + ! + END SUBROUTINE fld_read + + + SUBROUTINE fld_init( ksecsbc, sdjf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_init *** + !! + !! ** Purpose : - first call(s) to fld_def to define before values + !! - open file + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ksecsbc ! + TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables + !!--------------------------------------------------------------------- + ! + IF( nflag == 0 ) nflag = -HUGE(0) + ! + CALL fld_def( sdjf ) + IF( sdjf%ln_tint .AND. ksecsbc < sdjf%nrecsec(1) ) CALL fld_def( sdjf, ldprev = .TRUE. ) + ! + CALL fld_clopn( sdjf ) + sdjf%nrec(:,sdjf%naa) = (/ 1, nflag /) ! default definition to force flp_update to read the file. + ! + END SUBROUTINE fld_init + + + SUBROUTINE fld_update( ksecsbc, sdjf, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_update *** + !! + !! ** Purpose : Compute + !! if sdjf%ln_tint = .TRUE. + !! nrec(:,iaa): record number and its time (nrec(:,ibb) is obtained from nrec(:,iaa) when swapping) + !! if sdjf%ln_tint = .FALSE. + !! nrec(1,iaa): record number + !! nrec(2,ibb) and nrec(2,iaa): time of the beginning and end of the record + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ksecsbc ! + TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables + INTEGER , OPTIONAL, INTENT(in ) :: Kmm ! ocean time level index + ! + INTEGER :: ja ! end of this record (in seconds) + INTEGER :: ibb, iaa ! shorter name for sdjf%nbb and sdjf%naa + !!---------------------------------------------------------------------- + ibb = sdjf%nbb ; iaa = sdjf%naa + ! + IF( ksecsbc > sdjf%nrec(2,iaa) ) THEN ! --> we need to update after data + + ! find where is the new after record... (it is not necessary sdjf%nrec(1,iaa)+1 ) + ja = sdjf%nrec(1,iaa) + DO WHILE ( ksecsbc >= sdjf%nrecsec(ja) .AND. ja < sdjf%nreclast ) ! Warning: make sure ja <= sdjf%nreclast in this test + ja = ja + 1 + END DO + IF( ksecsbc > sdjf%nrecsec(ja) ) ja = ja + 1 ! in case ksecsbc > sdjf%nrecsec(sdjf%nreclast) + + ! if ln_tint and if the new after is not ja+1, we need also to update after data before the swap + ! so, after the swap, sdjf%nrec(2,ibb) will still be the closest value located just before ksecsbc + IF( sdjf%ln_tint .AND. ( ja > sdjf%nrec(1,iaa) + 1 .OR. sdjf%nrec(2,iaa) == nflag ) ) THEN + sdjf%nrec(:,iaa) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec(:,iaa) with before information + CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data + ENDIF + + ! if after is in the next file... + IF( ja > sdjf%nreclast ) THEN + + CALL fld_def( sdjf ) + IF( ksecsbc > sdjf%nrecsec(sdjf%nreclast) ) CALL fld_def( sdjf, ldnext = .TRUE. ) + CALL fld_clopn( sdjf ) ! open next file + + ! find where is after in this new file + ja = 1 + DO WHILE ( ksecsbc > sdjf%nrecsec(ja) .AND. ja < sdjf%nreclast ) + ja = ja + 1 + END DO + IF( ksecsbc > sdjf%nrecsec(ja) ) ja = ja + 1 ! in case ksecsbc > sdjf%nrecsec(sdjf%nreclast) + + IF( ja > sdjf%nreclast ) THEN + CALL ctl_stop( "STOP", "fld_def: need next-next file? we should not be there... file: "//TRIM(sdjf%clrootname) ) + ENDIF + + ! if ln_tint and if after is not the first record, we must (potentially again) update after data before the swap + IF( sdjf%ln_tint .AND. ja > 1 ) THEN + IF( sdjf%nrecsec(0) /= nflag ) THEN ! no trick used: after file is not the current file + sdjf%nrec(:,iaa) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec(:,iaa) with before information + CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data + ENDIF + ENDIF + + ENDIF + + IF( sdjf%ln_tint ) THEN ! Swap data + sdjf%nbb = sdjf%naa ! swap indices + sdjf%naa = 3 - sdjf%naa ! = 2(1) if naa == 1(2) + ELSE ! No swap + sdjf%nrec(:,ibb) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! only for print + ENDIF + + ! read new after data + sdjf%nrec(:,sdjf%naa) = (/ ja, sdjf%nrecsec(ja) /) ! update nrec(:,naa) as it is used by fld_get + CALL fld_get( sdjf, Kmm ) ! read after data (with nrec(:,naa) informations) + + ENDIF + ! + END SUBROUTINE fld_update + + + SUBROUTINE fld_get( sdjf, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_get *** + !! + !! ** Purpose : read the data + !!---------------------------------------------------------------------- + TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables + INTEGER , OPTIONAL, INTENT(in ) :: Kmm ! ocean time level index + ! + INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) + INTEGER :: iaa ! shorter name for sdjf%naa + INTEGER :: iw ! index into wgts array + INTEGER :: idvar ! variable ID + INTEGER :: idmspc ! number of spatial dimensions + REAL(wp) :: zsgn ! sign used in the call to lbc_lbk called by iom_get + REAL(wp), DIMENSION(:,:,:), POINTER :: dta_alias ! short cut + !!--------------------------------------------------------------------- + iaa = sdjf%naa + ! + IF( sdjf%ln_tint ) THEN ; dta_alias => sdjf%fdta(:,:,:,iaa) + ELSE ; dta_alias => sdjf%fnow(:,:,: ) + ENDIF + ipk = SIZE( dta_alias, 3 ) + ! + IF( LEN_TRIM(sdjf%vcomp) > 0 ) THEN ; zsgn = 1._wp ! geographical vectors -> sign change done later when rotating + ELSE ; zsgn = sdjf%zsgn + ENDIF + ! + IF( ASSOCIATED(sdjf%imap) ) THEN ! BDY case + CALL fld_map( sdjf%num, sdjf%clvar, dta_alias(:,:,:), sdjf%nrec(1,iaa), & + & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint, Kmm ) + ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN ! On-the-fly interpolation + CALL wgt_list( sdjf, iw ) + CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, dta_alias(:,:,:), sdjf%nrec(1,iaa), sdjf%lsmname ) + CALL lbc_lnk( 'fldread', dta_alias(:,:,:), sdjf%cltype, zsgn, kfillmode = jpfillcopy ) + ELSE ! default case + idvar = iom_varid( sdjf%num, sdjf%clvar ) + idmspc = iom_file ( sdjf%num )%ndims( idvar ) + IF( iom_file( sdjf%num )%luld( idvar ) ) idmspc = idmspc - 1 ! id of the last spatial dimension + CALL iom_get( sdjf%num, jpdom_global, sdjf%clvar, dta_alias(:,:,:), sdjf%nrec(1,iaa), & + & sdjf%cltype, REAL(zsgn,dp), kfill = jpfillcopy ) + ENDIF + ! + sdjf%rotn(iaa) = .false. ! vector not yet rotated + ! + END SUBROUTINE fld_get + + + SUBROUTINE fld_map( knum, cdvar, pdta, krec, kmap, kgrd, kbdy, ldtotvel, ldzint, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_map *** + !! + !! ** Purpose : read global data from file and map onto local data + !! using a general mapping (for open boundaries) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: knum ! stream number + CHARACTER(LEN=*) , INTENT(in ) :: cdvar ! variable name + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta ! bdy output field on model grid + INTEGER , INTENT(in ) :: krec ! record number to read (ie time slice) + INTEGER , DIMENSION(:) , INTENT(in ) :: kmap ! global-to-local bdy mapping indices + ! optional variables used for vertical interpolation: + INTEGER, OPTIONAL , INTENT(in ) :: kgrd ! grid type (t, u, v) + INTEGER, OPTIONAL , INTENT(in ) :: kbdy ! bdy number + LOGICAL, OPTIONAL , INTENT(in ) :: ldtotvel ! true if total ( = barotrop + barocline) velocity + LOGICAL, OPTIONAL , INTENT(in ) :: ldzint ! true if 3D variable requires a vertical interpolation + INTEGER, OPTIONAL , INTENT(in ) :: Kmm ! ocean time level index + !! + INTEGER :: ipi ! length of boundary data on local process + INTEGER :: ipj ! length of dummy dimension ( = 1 ) + INTEGER :: ipk ! number of vertical levels of pdta ( 2D: ipk=1 ; 3D: ipk=jpk ) + INTEGER :: ipkb ! number of vertical levels in boundary data file + INTEGER :: idvar ! variable ID + INTEGER :: indims ! number of dimensions of the variable + INTEGER, DIMENSION(4) :: idimsz ! size of variable dimensions + REAL(wp) :: zfv ! fillvalue + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zz_read ! work space for global boundary data + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read ! work space local data requiring vertical interpolation + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_z ! work space local data requiring vertical interpolation + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_dz ! work space local data requiring vertical interpolation + CHARACTER(LEN=1),DIMENSION(3) :: cltype + LOGICAL :: lluld ! is the variable using the unlimited dimension + LOGICAL :: llzint ! local value of ldzint + !!--------------------------------------------------------------------- + ! + cltype = (/'t','u','v'/) + ! + ipi = SIZE( pdta, 1 ) + ipj = SIZE( pdta, 2 ) ! must be equal to 1 + ipk = SIZE( pdta, 3 ) + ! + llzint = .FALSE. + IF( PRESENT(ldzint) ) llzint = ldzint + ! + idvar = iom_varid( knum, cdvar, kndims = indims, kdimsz = idimsz, lduld = lluld ) + IF( indims == 4 .OR. ( indims == 3 .AND. .NOT. lluld ) ) THEN ; ipkb = idimsz(3) ! xy(zl)t or xy(zl) + ELSE ; ipkb = 1 ! xy or xyt + ENDIF + ! + ALLOCATE( zz_read( idimsz(1), idimsz(2), ipkb ) ) ! ++++++++ !!! this can be very big... + ! + IF( ipk == 1 ) THEN + + IF( ipkb /= 1 ) CALL ctl_stop( 'fld_map : we must have ipkb = 1 to read surface data' ) + CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,1), krec ) ! call iom_get with a 2D file + CALL fld_map_core( zz_read, kmap, pdta ) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Do we include something here to adjust barotropic velocities ! + ! in case of a depth difference between bdy files and ! + ! bathymetry in the case ln_totvel = .false. and ipkb>0? ! + ! [as the enveloping and parital cells could change H] ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ELSE + ! + CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,:), krec ) ! call iom_get with a 3D file + ! + IF( ipkb /= ipk .OR. llzint ) THEN ! boundary data not on model vertical grid : vertical interpolation + ! + IF( ipk == jpk .AND. iom_varid(knum,'gdep'//cltype(kgrd)) /= -1 .AND. iom_varid(knum,'e3'//cltype(kgrd)) /= -1 ) THEN + + ALLOCATE( zdta_read(ipi,ipj,ipkb), zdta_read_z(ipi,ipj,ipkb), zdta_read_dz(ipi,ipj,ipkb) ) + + CALL fld_map_core( zz_read, kmap, zdta_read ) + CALL iom_get ( knum, jpdom_unknown, 'gdep'//cltype(kgrd), zz_read ) ! read only once? Potential temporal evolution? + CALL fld_map_core( zz_read, kmap, zdta_read_z ) + CALL iom_get ( knum, jpdom_unknown, 'e3'//cltype(kgrd), zz_read ) ! read only once? Potential temporal evolution? + CALL fld_map_core( zz_read, kmap, zdta_read_dz ) + + CALL iom_getatt(knum, '_FillValue', zfv, cdvar=cdvar ) + CALL fld_bdy_interp(zdta_read, zdta_read_z, zdta_read_dz, pdta, kgrd, kbdy, zfv, ldtotvel, Kmm) + DEALLOCATE( zdta_read, zdta_read_z, zdta_read_dz ) + + ELSE + IF( ipk /= jpk ) CALL ctl_stop( 'fld_map : this should be an impossible case...' ) + WRITE(ctmp1,*) 'fld_map : vertical interpolation for bdy variable '//TRIM(cdvar)//' requires ' + IF( iom_varid(knum, 'gdep'//cltype(kgrd)) == -1 ) CALL ctl_stop( ctmp1//'gdep'//cltype(kgrd)//' variable' ) + IF( iom_varid(knum, 'e3'//cltype(kgrd)) == -1 ) CALL ctl_stop( ctmp1// 'e3'//cltype(kgrd)//' variable' ) + + ENDIF + ! + ELSE ! bdy data assumed to be the same levels as bdy variables + ! + CALL fld_map_core( zz_read, kmap, pdta ) + ! + ENDIF ! ipkb /= ipk + ENDIF ! ipk == 1 + + DEALLOCATE( zz_read ) + + END SUBROUTINE fld_map + + + SUBROUTINE fld_map_core( pdta_read, kmap, pdta_bdy ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_map_core *** + !! + !! ** Purpose : inner core of fld_map + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! global boundary data + INTEGER, DIMENSION(: ), INTENT(in ) :: kmap ! global-to-local bdy mapping indices + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta_bdy ! bdy output field on model grid + !! + INTEGER, DIMENSION(3) :: idim_read, idim_bdy ! arrays dimensions + INTEGER :: ji, jj, jk, jb ! loop counters + INTEGER :: im1 + !!--------------------------------------------------------------------- + ! + idim_read = SHAPE( pdta_read ) + idim_bdy = SHAPE( pdta_bdy ) + ! + ! in all cases: idim_bdy(2) == 1 .AND. idim_read(1) * idim_read(2) == idim_bdy(1) + ! structured BDY with rimwidth > 1 : idim_read(2) == rimwidth /= 1 + ! structured BDY with rimwidth == 1 or unstructured BDY: idim_read(2) == 1 + ! + IF( idim_read(2) > 1 ) THEN ! structured BDY with rimwidth > 1 + DO jk = 1, idim_bdy(3) + DO jb = 1, idim_bdy(1) + im1 = kmap(jb) - 1 + jj = im1 / idim_read(1) + 1 + ji = MOD( im1, idim_read(1) ) + 1 + pdta_bdy(jb,1,jk) = pdta_read(ji,jj,jk) + END DO + END DO + ELSE + DO jk = 1, idim_bdy(3) + DO jb = 1, idim_bdy(1) ! horizontal remap of bdy data on the local bdy + pdta_bdy(jb,1,jk) = pdta_read(kmap(jb),1,jk) + END DO + END DO + ENDIF + + END SUBROUTINE fld_map_core + + SUBROUTINE fld_bdy_interp(pdta_read, pdta_read_z, pdta_read_dz, pdta, kgrd, kbdy, pfv, ldtotvel, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_bdy_interp *** + !! + !! ** Purpose : on the fly vertical interpolation to allow the use of + !! boundary data from non-native vertical grid + !!---------------------------------------------------------------------- + USE bdy_oce, ONLY: idx_bdy ! indexing for map <-> ij transformation + + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! data read in bdy file + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read_z ! depth of the data read in bdy file + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read_dz ! thickness of the levels in bdy file + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta ! output field on model grid (2 dimensional) + REAL(wp) , INTENT(in ) :: pfv ! fillvalue of the data read in bdy file + LOGICAL , INTENT(in ) :: ldtotvel ! true if toal ( = barotrop + barocline) velocity + INTEGER , INTENT(in ) :: kgrd ! grid type (t, u, v) + INTEGER , INTENT(in ) :: kbdy ! bdy number + INTEGER, OPTIONAL , INTENT(in ) :: Kmm ! ocean time level index + !! + INTEGER :: ipi ! length of boundary data on local process + INTEGER :: ipkb ! number of vertical levels in boundary data file + INTEGER :: ipkmax ! number of vertical levels in boundary data file where no mask + INTEGER :: jb, ji, jj, jk, jkb ! loop counters + REAL(wp) :: zcoef, zi ! + REAL(wp) :: ztrans, ztrans_new ! transports + REAL(wp), DIMENSION(jpk) :: zdepth, zdhalf ! level and half-level depth + !!--------------------------------------------------------------------- + + ipi = SIZE( pdta, 1 ) + ipkb = SIZE( pdta_read, 3 ) + + DO jb = 1, ipi + ji = idx_bdy(kbdy)%nbi(jb,kgrd) + jj = idx_bdy(kbdy)%nbj(jb,kgrd) + ! + ! --- max jk where input data /= FillValue --- ! + ipkmax = 1 + DO jkb = 2, ipkb + IF( pdta_read(jb,1,jkb) /= pfv ) ipkmax = MAX( ipkmax, jkb ) + END DO + ! + ! --- calculate depth at t,u,v points --- ! + SELECT CASE( kgrd ) + CASE(1) ! depth of T points: + zdepth(:) = (gdept_0(ji,jj,:)*(1._wp+r3t(ji,jj,Kmm))) + CASE(2) ! depth of U points: we must not use gdept_n as we don't want to do a communication + ! --> copy what is done for gdept_n in domvvl... + zdhalf(1) = 0.0_wp + zdepth(1) = 0.5_wp * (e3uw_0(ji,jj,1)*(1._wp+r3u(ji,jj,Kmm))) + DO jk = 2, jpk ! vertical sum + ! zcoef = umask - wumask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt + ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) + ! ! 0.5 where jk = mikt + !!gm ??????? BUG ? gdept_n as well as gde3w_n does not include the thickness of ISF ?? + zcoef = ( umask(ji,jj,jk) - wumask(ji,jj,jk) ) + zdhalf(jk) = zdhalf(jk-1) + (e3u_0(ji,jj,jk-1)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk-1))) + zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5_wp * (e3uw_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)))) & + & + (1._wp-zcoef) * ( zdepth(jk-1) + (e3uw_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)))) + END DO + CASE(3) ! depth of V points: we must not use gdept_n as we don't want to do a communication + ! --> copy what is done for gdept_n in domvvl... + zdhalf(1) = 0.0_wp + zdepth(1) = 0.5_wp * (e3vw_0(ji,jj,1)*(1._wp+r3v(ji,jj,Kmm))) + DO jk = 2, jpk ! vertical sum + ! zcoef = vmask - wvmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt + ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) + ! ! 0.5 where jk = mikt + !!gm ??????? BUG ? gdept_n as well as gde3w_n does not include the thickness of ISF ?? + zcoef = ( vmask(ji,jj,jk) - wvmask(ji,jj,jk) ) + zdhalf(jk) = zdhalf(jk-1) + (e3v_0(ji,jj,jk-1)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk-1))) + zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5_wp * (e3vw_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)))) & + + (1._wp-zcoef) * ( zdepth(jk-1) + (e3vw_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)))) + END DO + END SELECT + ! + ! --- interpolate bdy data on the model grid --- ! + DO jk = 1, jpk + IF( zdepth(jk) <= pdta_read_z(jb,1,1) ) THEN ! above the first level of external data + pdta(jb,1,jk) = pdta_read(jb,1,1) + ELSEIF( zdepth(jk) > pdta_read_z(jb,1,ipkmax) ) THEN ! below the last level of external data /= FillValue + pdta(jb,1,jk) = pdta_read(jb,1,ipkmax) + ELSE ! inbetween: vertical interpolation between jkb & jkb+1 + DO jkb = 1, ipkmax-1 + IF( ( ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) * ( zdepth(jk) - pdta_read_z(jb,1,jkb+1) ) ) <= 0._wp ) THEN ! linear interpolation between 2 levels + zi = ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) / ( pdta_read_z(jb,1,jkb+1) - pdta_read_z(jb,1,jkb) ) + pdta(jb,1,jk) = pdta_read(jb,1,jkb) + zi * ( pdta_read(jb,1,jkb+1) - pdta_read(jb,1,jkb) ) + ENDIF + END DO + ENDIF + END DO ! jpk + ! + END DO ! ipi + + ! --- mask data and adjust transport --- ! + SELECT CASE( kgrd ) + + CASE(1) ! mask data (probably unecessary) + DO jb = 1, ipi + ji = idx_bdy(kbdy)%nbi(jb,kgrd) + jj = idx_bdy(kbdy)%nbj(jb,kgrd) + DO jk = 1, jpk + pdta(jb,1,jk) = pdta(jb,1,jk) * tmask(ji,jj,jk) + END DO + END DO + + CASE(2) ! adjust the U-transport term + DO jb = 1, ipi + ji = idx_bdy(kbdy)%nbi(jb,kgrd) + jj = idx_bdy(kbdy)%nbj(jb,kgrd) + ztrans = 0._wp + DO jkb = 1, ipkb ! calculate transport on input grid + IF( pdta_read(jb,1,jkb) /= pfv ) ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb,1,jkb) + ENDDO + ztrans_new = 0._wp + DO jk = 1, jpk ! calculate transport on model grid + ztrans_new = ztrans_new + pdta(jb,1,jk ) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm )*umask(ji,jj,jk))) * umask(ji,jj,jk) + ENDDO + DO jk = 1, jpk ! make transport correction + IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data + pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * (r1_hu_0(ji,jj)/(1._wp+r3u(ji,jj,Kmm))) ) * umask(ji,jj,jk) + ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero + pdta(jb,1,jk) = pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * (r1_hu_0(ji,jj)/(1._wp+r3u(ji,jj,Kmm))) * umask(ji,jj,jk) + ENDIF + ENDDO + ENDDO + + CASE(3) ! adjust the V-transport term + DO jb = 1, ipi + ji = idx_bdy(kbdy)%nbi(jb,kgrd) + jj = idx_bdy(kbdy)%nbj(jb,kgrd) + ztrans = 0._wp + DO jkb = 1, ipkb ! calculate transport on input grid + IF( pdta_read(jb,1,jkb) /= pfv ) ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb,1,jkb) + ENDDO + ztrans_new = 0._wp + DO jk = 1, jpk ! calculate transport on model grid + ztrans_new = ztrans_new + pdta(jb,1,jk ) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm )*vmask(ji,jj,jk))) * vmask(ji,jj,jk) + ENDDO + DO jk = 1, jpk ! make transport correction + IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data + pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * (r1_hv_0(ji,jj)/(1._wp+r3v(ji,jj,Kmm))) ) * vmask(ji,jj,jk) + ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero + pdta(jb,1,jk) = pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * (r1_hv_0(ji,jj)/(1._wp+r3v(ji,jj,Kmm))) * vmask(ji,jj,jk) + ENDIF + ENDDO + ENDDO + END SELECT + + END SUBROUTINE fld_bdy_interp + + + SUBROUTINE fld_rot( kt, sd ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_rot *** + !! + !! ** Purpose : Vector fields may need to be rotated onto the local grid direction + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + TYPE(FLD), DIMENSION(:), INTENT(inout) :: sd ! input field related variables + ! + INTEGER :: ju, jv, jk, jn ! loop indices + INTEGER :: imf ! size of the structure sd + INTEGER :: ill ! character length + INTEGER :: iv ! indice of V component + CHARACTER (LEN=100) :: clcomp ! dummy weight name + REAL(wp), DIMENSION(jpi,jpj) :: utmp, vtmp ! temporary arrays for vector rotation + REAL(wp), DIMENSION(:,:,:), POINTER :: dta_u, dta_v ! short cut + !!--------------------------------------------------------------------- + ! + !! (sga: following code should be modified so that pairs arent searched for each time + ! + imf = SIZE( sd ) + DO ju = 1, imf + IF( TRIM(sd(ju)%clrootname) == 'NOT USED' ) CYCLE + ill = LEN_TRIM( sd(ju)%vcomp ) + DO jn = 2-COUNT((/sd(ju)%ln_tint/)), 2 + IF( ill > 0 .AND. .NOT. sd(ju)%rotn(jn) ) THEN ! find vector rotations required + IF( sd(ju)%vcomp(1:1) == 'U' ) THEN ! east-west component has symbolic name starting with 'U' + ! look for the north-south component which has same symbolic name but with 'U' replaced with 'V' + clcomp = 'V' // sd(ju)%vcomp(2:ill) ! works even if ill == 1 + iv = -1 + DO jv = 1, imf + IF( TRIM(sd(jv)%clrootname) == 'NOT USED' ) CYCLE + IF( TRIM(sd(jv)%vcomp) == TRIM(clcomp) ) iv = jv + END DO + IF( iv > 0 ) THEN ! fields ju and iv are two components which need to be rotated together + IF( sd(ju)%ln_tint ) THEN ; dta_u => sd(ju)%fdta(:,:,:,jn) ; dta_v => sd(iv)%fdta(:,:,:,jn) + ELSE ; dta_u => sd(ju)%fnow(:,:,: ) ; dta_v => sd(iv)%fnow(:,:,: ) + ENDIF + DO jk = 1, SIZE( sd(ju)%fnow, 3 ) + CALL rot_rep( dta_u(:,:,jk), dta_v(:,:,jk), 'T', 'en->i', utmp(:,:) ) + CALL rot_rep( dta_u(:,:,jk), dta_v(:,:,jk), 'T', 'en->j', vtmp(:,:) ) + dta_u(:,:,jk) = utmp(:,:) ; dta_v(:,:,jk) = vtmp(:,:) + END DO + sd(ju)%rotn(jn) = .TRUE. ! vector was rotated + IF( lwp .AND. kt == nit000 ) WRITE(numout,*) & + & 'fld_read: vector pair ('//TRIM(sd(ju)%clvar)//', '//TRIM(sd(iv)%clvar)//') rotated on to model grid' + ENDIF + ENDIF + ENDIF + END DO + END DO + ! + END SUBROUTINE fld_rot + + + SUBROUTINE fld_def( sdjf, ldprev, ldnext ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_def *** + !! + !! ** Purpose : define the record(s) of the file and its name + !!---------------------------------------------------------------------- + TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables + LOGICAL, OPTIONAL, INTENT(in ) :: ldprev ! + LOGICAL, OPTIONAL, INTENT(in ) :: ldnext ! + ! + INTEGER :: jt + INTEGER :: idaysec ! number of seconds in 1 day = NINT(rday) + INTEGER :: iyr, imt, idy, isecwk + INTEGER :: indexyr, indexmt + INTEGER :: ireclast + INTEGER :: ishift, istart + INTEGER, DIMENSION(2) :: isave + REAL(wp) :: zfreqs + LOGICAL :: llprev, llnext, llstop + LOGICAL :: llprevmt, llprevyr + LOGICAL :: llnextmt, llnextyr + !!---------------------------------------------------------------------- + idaysec = NINT(rday) + ! + IF( PRESENT(ldprev) ) THEN ; llprev = ldprev + ELSE ; llprev = .FALSE. + ENDIF + IF( PRESENT(ldnext) ) THEN ; llnext = ldnext + ELSE ; llnext = .FALSE. + ENDIF + + ! current file parameters + IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of the current week + isecwk = ksec_week( sdjf%clftyp(6:8) ) ! seconds between the beginning of the week and half of current time step + llprevmt = isecwk > nsec_month ! longer time since beginning of the current week than the current month + llprevyr = llprevmt .AND. nmonth == 1 + iyr = nyear - COUNT((/llprevyr/)) + imt = nmonth - COUNT((/llprevmt/)) + 12 * COUNT((/llprevyr/)) + idy = nday + nmonth_len(nmonth-1) * COUNT((/llprevmt/)) - isecwk / idaysec + isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and current week beginning + ELSE + iyr = nyear + imt = nmonth + idy = nday + isecwk = 0 + ENDIF + + ! previous file parameters + IF( llprev ) THEN + IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of previous week + isecwk = isecwk + 7 * idaysec ! seconds between the beginning of previous week and half of the time step + llprevmt = isecwk > nsec_month ! longer time since beginning of the previous week than the current month + llprevyr = llprevmt .AND. nmonth == 1 + iyr = nyear - COUNT((/llprevyr/)) + imt = nmonth - COUNT((/llprevmt/)) + 12 * COUNT((/llprevyr/)) + idy = nday + nmonth_len(nmonth-1) * COUNT((/llprevmt/)) - isecwk / idaysec + isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and previous week beginning + ELSE + idy = nday - COUNT((/ sdjf%clftyp == 'daily' /)) + imt = nmonth - COUNT((/ sdjf%clftyp == 'monthly' .OR. idy == 0 /)) + iyr = nyear - COUNT((/ sdjf%clftyp == 'yearly' .OR. imt == 0 /)) + IF( idy == 0 ) idy = nmonth_len(imt) + IF( imt == 0 ) imt = 12 + isecwk = 0 + ENDIF + ENDIF + + ! next file parameters + IF( llnext ) THEN + IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of next week + isecwk = 7 * idaysec - isecwk ! seconds between half of the time step and the beginning of next week + llnextmt = isecwk > ( nmonth_len(nmonth)*idaysec - nsec_month ) ! larger than the seconds to the end of the month + llnextyr = llnextmt .AND. nmonth == 12 + iyr = nyear + COUNT((/llnextyr/)) + imt = nmonth + COUNT((/llnextmt/)) - 12 * COUNT((/llnextyr/)) + idy = nday - nmonth_len(nmonth) * COUNT((/llnextmt/)) + isecwk / idaysec + 1 + isecwk = nsec_year + isecwk ! seconds between 00h jan 1st of current year and next week beginning + ELSE + idy = nday + COUNT((/ sdjf%clftyp == 'daily' /)) + imt = nmonth + COUNT((/ sdjf%clftyp == 'monthly' .OR. idy > nmonth_len(nmonth) /)) + iyr = nyear + COUNT((/ sdjf%clftyp == 'yearly' .OR. imt == 13 /)) + IF( idy > nmonth_len(nmonth) ) idy = 1 + IF( imt == 13 ) imt = 1 + isecwk = 0 + ENDIF + ENDIF + ! + ! find the last record to be read -> update sdjf%nreclast + indexyr = iyr - nyear + 1 ! which year are we looking for? previous(0), current(1) or next(2)? + indexmt = imt + 12 * ( indexyr - 1 ) ! which month are we looking for (relatively to current year)? + ! + ! Last record to be read in the current file + ! Predefine the number of record in the file according of its type. + ! We could compare this number with the number of records in the file and make a stop if the 2 numbers do not match... + ! However this would be much less fexible (e.g. for tests) and will force to rewite input files according to nleapy... + IF ( NINT(sdjf%freqh) == -12 ) THEN ; ireclast = 1 ! yearly mean: consider only 1 record + ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean: + IF( sdjf%clftyp == 'monthly' ) THEN ; ireclast = 1 ! consider that the file has 1 record + ELSE ; ireclast = 12 ! consider that the file has 12 record + ENDIF + ELSE ! higher frequency mean (in hours) + IF( sdjf%clftyp == 'monthly' ) THEN ; ireclast = NINT( 24. * REAL(nmonth_len(indexmt), wp) / sdjf%freqh ) + ELSEIF( sdjf%clftyp(1:4) == 'week' ) THEN ; ireclast = NINT( 24. * 7. / sdjf%freqh ) + ELSEIF( sdjf%clftyp == 'daily' ) THEN ; ireclast = NINT( 24. / sdjf%freqh ) + ELSE ; ireclast = NINT( 24. * REAL( nyear_len(indexyr), wp) / sdjf%freqh ) + ENDIF + ENDIF + + sdjf%nreclast = ireclast + ! Allocate arrays for beginning/middle/end of each record (seconds since Jan. 1st 00h of nit000 year) + IF( ALLOCATED(sdjf%nrecsec) ) DEALLOCATE( sdjf%nrecsec ) + ALLOCATE( sdjf%nrecsec( 0:ireclast ) ) + ! + IF ( NINT(sdjf%freqh) == -12 ) THEN ! yearly mean and yearly file + SELECT CASE( indexyr ) + CASE(0) ; sdjf%nrecsec(0) = nsec1jan000 - nyear_len( 0 ) * idaysec + CASE(1) ; sdjf%nrecsec(0) = nsec1jan000 + CASE(2) ; sdjf%nrecsec(0) = nsec1jan000 + nyear_len( 1 ) * idaysec + ENDSELECT + sdjf%nrecsec(1) = sdjf%nrecsec(0) + nyear_len( indexyr ) * idaysec + ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean: + IF( sdjf%clftyp == 'monthly' ) THEN ! monthly file + sdjf%nrecsec(0 ) = nsec1jan000 + nmonth_beg(indexmt ) + sdjf%nrecsec(1 ) = nsec1jan000 + nmonth_beg(indexmt+1) + ELSE ! yearly file + ishift = 12 * ( indexyr - 1 ) + sdjf%nrecsec(0:12) = nsec1jan000 + nmonth_beg(1+ishift:13+ishift) + ENDIF + ELSE ! higher frequency mean (in hours) + IF( sdjf%clftyp == 'monthly' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt) + ELSEIF( sdjf%clftyp(1:4) == 'week' ) THEN ; istart = nsec1jan000 + isecwk + ELSEIF( sdjf%clftyp == 'daily' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt) + ( idy - 1 ) * idaysec + ELSEIF( indexyr == 0 ) THEN ; istart = nsec1jan000 - nyear_len( 0 ) * idaysec + ELSEIF( indexyr == 2 ) THEN ; istart = nsec1jan000 + nyear_len( 1 ) * idaysec + ELSE ; istart = nsec1jan000 + ENDIF + zfreqs = sdjf%freqh * rhhmm * rmmss + DO jt = 0, sdjf%nreclast + sdjf%nrecsec(jt) = istart + NINT( zfreqs * REAL(jt,wp) ) + END DO + ENDIF + ! + IF( sdjf%ln_tint ) THEN ! record time defined in the middle of the record, computed using an implementation + ! of the rounded average that is valid over the full integer range + sdjf%nrecsec(1:sdjf%nreclast) = sdjf%nrecsec(0:sdjf%nreclast-1) / 2 + sdjf%nrecsec(1:sdjf%nreclast) / 2 + & + & MAX( MOD( sdjf%nrecsec(0:sdjf%nreclast-1), 2 ), MOD( sdjf%nrecsec(1:sdjf%nreclast), 2 ) ) + END IF + ! + sdjf%clname = fld_filename( sdjf, idy, imt, iyr ) + ! + END SUBROUTINE fld_def + + + SUBROUTINE fld_clopn( sdjf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_clopn *** + !! + !! ** Purpose : close/open the files + !!---------------------------------------------------------------------- + TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables + ! + INTEGER :: isave + LOGICAL :: llprev, llnext, llstop + !!---------------------------------------------------------------------- + ! + llprev = sdjf%nrecsec(sdjf%nreclast) < nsec000_1jan000 ! file ends before the beginning of the job -> file may not exist + llnext = sdjf%nrecsec( 1 ) > nsecend_1jan000 ! file begins after the end of the job -> file may not exist + + llstop = sdjf%ln_clim .OR. .NOT. ( llprev .OR. llnext ) + + IF( sdjf%num <= 0 .OR. .NOT. sdjf%ln_clim ) THEN + IF( sdjf%num > 0 ) CALL iom_close( sdjf%num ) ! close file if already open + CALL iom_open( sdjf%clname, sdjf%num, ldstop = llstop, ldiof = LEN_TRIM(sdjf%wgtname) > 0 ) + ENDIF + ! + IF( sdjf%num <= 0 .AND. .NOT. llstop ) THEN ! file not found but we do accept this... + ! + IF( llprev ) THEN ! previous file does not exist : go back to current and accept to read only the first record + CALL ctl_warn('previous file: '//TRIM(sdjf%clname)//' not found -> go back to current year/month/week/day file') + isave = sdjf%nrecsec(sdjf%nreclast) ! save previous file info + CALL fld_def( sdjf ) ! go back to current file + sdjf%nreclast = 1 ! force to use only the first record (do as if other were not existing...) + ENDIF + ! + IF( llnext ) THEN ! next file does not exist : go back to current and accept to read only the last record + CALL ctl_warn('next file: '//TRIM(sdjf%clname)//' not found -> go back to current year/month/week/day file') + isave = sdjf%nrecsec(1) ! save next file info + CALL fld_def( sdjf ) ! go back to current file + ENDIF + ! -> read "last" record but keep record info from the first record of next file + sdjf%nrecsec( sdjf%nreclast ) = isave + sdjf%nrecsec(0:sdjf%nreclast-1) = nflag + ! + CALL iom_open( sdjf%clname, sdjf%num, ldiof = LEN_TRIM(sdjf%wgtname) > 0 ) + ! + ENDIF + ! + END SUBROUTINE fld_clopn + + + SUBROUTINE fld_fill( sdf, sdf_n, cdir, cdcaller, cdtitle, cdnam, knoprint ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_fill *** + !! + !! ** Purpose : fill the data structure (sdf) with the associated information + !! read in namelist (sdf_n) and control print + !!---------------------------------------------------------------------- + TYPE(FLD) , DIMENSION(:) , INTENT(inout) :: sdf ! structure of input fields (file informations, fields read) + TYPE(FLD_N), DIMENSION(:) , INTENT(in ) :: sdf_n ! array of namelist information structures + CHARACTER(len=*) , INTENT(in ) :: cdir ! Root directory for location of flx files + CHARACTER(len=*) , INTENT(in ) :: cdcaller ! name of the calling routine + CHARACTER(len=*) , INTENT(in ) :: cdtitle ! description of the calling routine + CHARACTER(len=*) , INTENT(in ) :: cdnam ! name of the namelist from which sdf_n comes + INTEGER , OPTIONAL, INTENT(in ) :: knoprint ! no calling routine information printed + ! + INTEGER :: jf ! dummy indices + !!--------------------------------------------------------------------- + ! + DO jf = 1, SIZE(sdf) + sdf(jf)%clrootname = sdf_n(jf)%clname + IF( TRIM(sdf_n(jf)%clname) /= 'NOT USED' ) sdf(jf)%clrootname = TRIM( cdir )//sdf(jf)%clrootname + sdf(jf)%clname = "not yet defined" + sdf(jf)%freqh = sdf_n(jf)%freqh + sdf(jf)%clvar = sdf_n(jf)%clvar + sdf(jf)%ln_tint = sdf_n(jf)%ln_tint + sdf(jf)%ln_clim = sdf_n(jf)%ln_clim + sdf(jf)%clftyp = sdf_n(jf)%clftyp + sdf(jf)%cltype = 'T' ! by default don't do any call to lbc_lnk in iom_get + sdf(jf)%zsgn = 1. ! by default don't do change signe across the north fold + sdf(jf)%num = -1 + sdf(jf)%nbb = 1 ! start with before data in 1 + sdf(jf)%naa = 2 ! start with after data in 2 + sdf(jf)%wgtname = " " + IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 ) sdf(jf)%wgtname = TRIM( cdir )//sdf_n(jf)%wname + sdf(jf)%lsmname = " " + IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 ) sdf(jf)%lsmname = TRIM( cdir )//sdf_n(jf)%lname + sdf(jf)%vcomp = sdf_n(jf)%vcomp + sdf(jf)%rotn(:) = .TRUE. ! pretend to be rotated -> won't try to rotate data before the first call to fld_get + IF( sdf(jf)%clftyp(1:4) == 'week' .AND. nn_leapy == 0 ) & + & CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs nn_leapy = 1') + IF( sdf(jf)%clftyp(1:4) == 'week' .AND. sdf(jf)%ln_clim ) & + & CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs ln_clim = .FALSE.') + sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn + sdf(jf)%igrd = 0 + sdf(jf)%ibdy = 0 + sdf(jf)%imap => NULL() + sdf(jf)%ltotvel = .FALSE. + sdf(jf)%lzint = .FALSE. + END DO + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + IF( .NOT.PRESENT( knoprint) ) THEN + WRITE(numout,*) TRIM( cdcaller )//' : '//TRIM( cdtitle ) + WRITE(numout,*) (/ ('~', jf = 1, LEN_TRIM( cdcaller ) ) /) + ENDIF + WRITE(numout,*) ' fld_fill : fill data structure with information from namelist '//TRIM( cdnam ) + WRITE(numout,*) ' ~~~~~~~~' + WRITE(numout,*) ' list of files and frequency (>0: in hours ; <0 in months)' + DO jf = 1, SIZE(sdf) + WRITE(numout,*) ' root filename: ' , TRIM( sdf(jf)%clrootname ), ' variable name: ', TRIM( sdf(jf)%clvar ) + WRITE(numout,*) ' frequency: ' , sdf(jf)%freqh , & + & ' time interp: ' , sdf(jf)%ln_tint , & + & ' climatology: ' , sdf(jf)%ln_clim + WRITE(numout,*) ' weights: ' , TRIM( sdf(jf)%wgtname ), & + & ' pairing: ' , TRIM( sdf(jf)%vcomp ), & + & ' data type: ' , sdf(jf)%clftyp , & + & ' land/sea mask:' , TRIM( sdf(jf)%lsmname ) + call flush(numout) + END DO + ENDIF + ! + END SUBROUTINE fld_fill + + + SUBROUTINE wgt_list( sd, kwgt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE wgt_list *** + !! + !! ** Purpose : search array of WGTs and find a weights file entry, + !! or return a new one adding it to the end if new entry. + !! the weights data is read in and restructured (fld_weight) + !!---------------------------------------------------------------------- + TYPE( FLD ), INTENT(in ) :: sd ! field with name of weights file + INTEGER , INTENT( out) :: kwgt ! index of weights + ! + INTEGER :: kw, nestid ! local integer + !!---------------------------------------------------------------------- + ! + !! search down linked list + !! weights filename is either present or we hit the end of the list + ! + !! because agrif nest part of filenames are now added in iom_open + !! to distinguish between weights files on the different grids, need to track + !! nest number explicitly + nestid = 0 + DO kw = 1, nxt_wgt-1 + IF( ref_wgts(kw)%wgtname == sd%wgtname .AND. & + ref_wgts(kw)%nestid == nestid) THEN + kwgt = kw + RETURN + ENDIF + END DO + kwgt = nxt_wgt + CALL fld_weight( sd ) + ! + END SUBROUTINE wgt_list + + + SUBROUTINE wgt_print( ) + !!--------------------------------------------------------------------- + !! *** ROUTINE wgt_print *** + !! + !! ** Purpose : print the list of known weights + !!---------------------------------------------------------------------- + INTEGER :: kw ! + !!---------------------------------------------------------------------- + ! + DO kw = 1, nxt_wgt-1 + WRITE(numout,*) 'weight file: ',TRIM(ref_wgts(kw)%wgtname) + WRITE(numout,*) ' ddims: ',ref_wgts(kw)%ddims(1),ref_wgts(kw)%ddims(2) + WRITE(numout,*) ' numwgt: ',ref_wgts(kw)%numwgt + WRITE(numout,*) ' jpiwgt: ',ref_wgts(kw)%jpiwgt + WRITE(numout,*) ' jpjwgt: ',ref_wgts(kw)%jpjwgt + WRITE(numout,*) ' botleft: ',ref_wgts(kw)%botleft + WRITE(numout,*) ' topright: ',ref_wgts(kw)%topright + IF( ref_wgts(kw)%cyclic ) THEN + WRITE(numout,*) ' cyclical' + IF( ref_wgts(kw)%overlap > 0 ) WRITE(numout,*) ' with overlap of ', ref_wgts(kw)%overlap + ELSE + WRITE(numout,*) ' not cyclical' + ENDIF + IF( ASSOCIATED(ref_wgts(kw)%data_wgt) ) WRITE(numout,*) ' allocated' + END DO + ! + END SUBROUTINE wgt_print + + + SUBROUTINE fld_weight( sd ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_weight *** + !! + !! ** Purpose : create a new WGT structure and fill in data from file, + !! restructuring as required + !!---------------------------------------------------------------------- + TYPE( FLD ), INTENT(in) :: sd ! field with name of weights file + !! + INTEGER :: ji,jj,jn ! dummy loop indices + INTEGER :: inum ! local logical unit + INTEGER :: id ! local variable id + INTEGER :: ipk ! local vertical dimension + INTEGER :: zwrap ! local integer + LOGICAL :: cyclical ! + CHARACTER (len=5) :: clname ! + INTEGER , DIMENSION(4) :: ddims + INTEGER :: isrc + REAL(wp), DIMENSION(jpi,jpj) :: data_tmp + !!---------------------------------------------------------------------- + ! + IF( nxt_wgt > tot_wgts ) THEN + CALL ctl_stop("fld_weight: weights array size exceeded, increase tot_wgts") + ENDIF + ! + !! new weights file entry, add in extra information + !! a weights file represents a 2D grid of a certain shape, so we assume that the current + !! input data file is representative of all other files to be opened and processed with the + !! current weights file + + !! get data grid dimensions + id = iom_varid( sd%num, sd%clvar, ddims ) + + !! now open the weights file + CALL iom_open ( sd%wgtname, inum ) ! interpolation weights + IF( inum > 0 ) THEN + + !! determine whether we have an east-west cyclic grid + !! from global attribute called "ew_wrap" in the weights file + !! note that if not found, iom_getatt returns -999 and cyclic with no overlap is assumed + !! since this is the most common forcing configuration + + CALL iom_getatt(inum, 'ew_wrap', zwrap) + IF( zwrap >= 0 ) THEN + cyclical = .TRUE. + ELSE IF( zwrap == -999 ) THEN + cyclical = .TRUE. + zwrap = 0 + ELSE + cyclical = .FALSE. + ENDIF + + ref_wgts(nxt_wgt)%ddims(1) = ddims(1) + ref_wgts(nxt_wgt)%ddims(2) = ddims(2) + ref_wgts(nxt_wgt)%wgtname = sd%wgtname + ref_wgts(nxt_wgt)%overlap = zwrap + ref_wgts(nxt_wgt)%cyclic = cyclical + ref_wgts(nxt_wgt)%nestid = 0 + !! weights file is stored as a set of weights (wgt01->wgt04 or wgt01->wgt16) + !! for each weight wgtNN there is an integer array srcNN which gives the point in + !! the input data grid which is to be multiplied by the weight + !! they are both arrays on the model grid so the result of the multiplication is + !! added into an output array on the model grid as a running sum + + !! two possible cases: bilinear (4 weights) or bicubic (16 weights) + id = iom_varid(inum, 'src05', ldstop=.FALSE.) + IF( id <= 0 ) THEN ; ref_wgts(nxt_wgt)%numwgt = 4 + ELSE ; ref_wgts(nxt_wgt)%numwgt = 16 + ENDIF + + ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(Nis0:Nie0,Njs0:Nje0,4) ) + ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(Nis0:Nie0,Njs0:Nje0,4) ) + ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(Nis0:Nie0,Njs0:Nje0,ref_wgts(nxt_wgt)%numwgt) ) + + DO jn = 1,4 + WRITE(clname,'(a3,i2.2)') 'src',jn + CALL iom_get ( inum, jpdom_global, clname, data_tmp(:,:), cd_type = 'Z' ) ! no call to lbc_lnk + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + isrc = NINT(data_tmp(ji,jj)) - 1 + ref_wgts(nxt_wgt)%data_jpi(ji,jj,jn) = 1 + MOD(isrc, ref_wgts(nxt_wgt)%ddims(1)) + ref_wgts(nxt_wgt)%data_jpj(ji,jj,jn) = 1 + isrc / ref_wgts(nxt_wgt)%ddims(1) + END DO ; END DO + END DO + + DO jn = 1, ref_wgts(nxt_wgt)%numwgt + WRITE(clname,'(a3,i2.2)') 'wgt',jn + CALL iom_get ( inum, jpdom_global, clname, data_tmp(:,:), cd_type = 'Z' ) ! no call to lbc_lnk + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ref_wgts(nxt_wgt)%data_wgt(ji,jj,jn) = data_tmp(ji,jj) + END DO ; END DO + END DO + CALL iom_close (inum) + + ! find min and max indices in grid + ref_wgts(nxt_wgt)%botleft( 1) = MINVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:)) + ref_wgts(nxt_wgt)%botleft( 2) = MINVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:)) + ref_wgts(nxt_wgt)%topright(1) = MAXVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:)) + ref_wgts(nxt_wgt)%topright(2) = MAXVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:)) + + ! and therefore dimensions of the input box + ref_wgts(nxt_wgt)%jpiwgt = ref_wgts(nxt_wgt)%topright(1) - ref_wgts(nxt_wgt)%botleft(1) + 1 + ref_wgts(nxt_wgt)%jpjwgt = ref_wgts(nxt_wgt)%topright(2) - ref_wgts(nxt_wgt)%botleft(2) + 1 + + ! shift indexing of source grid + ref_wgts(nxt_wgt)%data_jpi(:,:,:) = ref_wgts(nxt_wgt)%data_jpi(:,:,:) - ref_wgts(nxt_wgt)%botleft(1) + 1 + ref_wgts(nxt_wgt)%data_jpj(:,:,:) = ref_wgts(nxt_wgt)%data_jpj(:,:,:) - ref_wgts(nxt_wgt)%botleft(2) + 1 + + ! create input grid, give it a halo to allow gradient calculations + ! SA: +3 stencil is a patch to avoid out-of-bound computation in some configuration. + ! a more robust solution will be given in next release + ipk = SIZE(sd%fnow, 3) + ALLOCATE( ref_wgts(nxt_wgt)%fly_dta(ref_wgts(nxt_wgt)%jpiwgt+3, ref_wgts(nxt_wgt)%jpjwgt+3 ,ipk) ) + IF( ref_wgts(nxt_wgt)%cyclic ) ALLOCATE( ref_wgts(nxt_wgt)%col(1,ref_wgts(nxt_wgt)%jpjwgt+3,ipk) ) + ! + nxt_wgt = nxt_wgt + 1 + ! + ELSE + CALL ctl_stop( ' fld_weight : unable to read the file ' ) + ENDIF + ! + END SUBROUTINE fld_weight + + + SUBROUTINE apply_seaoverland( clmaskfile, zfieldo, jpi1_lsm, jpi2_lsm, jpj1_lsm, & + & jpj2_lsm, itmpi, itmpj, itmpz, rec1_lsm, recn_lsm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE apply_seaoverland *** + !! + !! ** Purpose : avoid spurious fluxes in coastal or near-coastal areas + !! due to the wrong usage of "land" values from the coarse + !! atmospheric model when spatial interpolation is required + !! D. Delrosso INGV + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: itmpi,itmpj,itmpz ! lengths + INTEGER, INTENT(in ) :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices + INTEGER, DIMENSION(3), INTENT(in ) :: rec1_lsm,recn_lsm ! temporary arrays for start and length + REAL(wp),DIMENSION (:,:,:),INTENT(inout) :: zfieldo ! input/output array for seaoverland application + CHARACTER (len=100), INTENT(in ) :: clmaskfile ! land/sea mask file name + ! + INTEGER :: inum,jni,jnj,jnz,jc ! local indices + REAL(wp),DIMENSION (:,:,:),ALLOCATABLE :: zslmec1 ! local array for land point detection + REAL(wp),DIMENSION (:,:), ALLOCATABLE :: zfieldn ! array of forcing field with undeff for land points + REAL(wp),DIMENSION (:,:), ALLOCATABLE :: zfield ! array of forcing field + !!--------------------------------------------------------------------- + ! + ALLOCATE ( zslmec1(itmpi,itmpj,itmpz), zfieldn(itmpi,itmpj), zfield(itmpi,itmpj) ) + ! + ! Retrieve the land sea mask data + CALL iom_open( clmaskfile, inum ) + SELECT CASE( SIZE(zfieldo(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),3) ) + CASE(1) + CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), & + & 1, kstart = rec1_lsm, kcount = recn_lsm) + CASE DEFAULT + CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & + & 1, kstart = rec1_lsm, kcount = recn_lsm) + END SELECT + CALL iom_close( inum ) + ! + DO jnz=1,rec1_lsm(3) !! Loop over k dimension + ! + DO jni = 1, itmpi !! copy the original field into a tmp array + DO jnj = 1, itmpj !! substituting undeff over land points + zfieldn(jni,jnj) = zfieldo(jni,jnj,jnz) + IF( zslmec1(jni,jnj,jnz) == 1. ) zfieldn(jni,jnj) = undeff_lsm + END DO + END DO + ! + CALL seaoverland( zfieldn, itmpi, itmpj, zfield ) + DO jc = 1, nn_lsm + CALL seaoverland( zfield, itmpi, itmpj, zfield ) + END DO + ! + ! Check for Undeff and substitute original values + IF( ANY(zfield==undeff_lsm) ) THEN + DO jni = 1, itmpi + DO jnj = 1, itmpj + IF( zfield(jni,jnj)==undeff_lsm ) zfield(jni,jnj) = zfieldo(jni,jnj,jnz) + END DO + END DO + ENDIF + ! + zfieldo(:,:,jnz) = zfield(:,:) + ! + END DO !! End Loop over k dimension + ! + DEALLOCATE ( zslmec1, zfieldn, zfield ) + ! + END SUBROUTINE apply_seaoverland + + + SUBROUTINE seaoverland( zfieldn, ileni, ilenj, zfield ) + !!--------------------------------------------------------------------- + !! *** ROUTINE seaoverland *** + !! + !! ** Purpose : create shifted matrices for seaoverland application + !! D. Delrosso INGV + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ileni,ilenj ! lengths + REAL(wp), DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points + REAL(wp), DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field + ! + REAL(wp) , DIMENSION (ileni,ilenj) :: zmat1, zmat2, zmat3, zmat4 ! local arrays + REAL(wp) , DIMENSION (ileni,ilenj) :: zmat5, zmat6, zmat7, zmat8 ! - - + REAL(wp) , DIMENSION (ileni,ilenj) :: zlsm2d ! - - + REAL(wp) , DIMENSION (ileni,ilenj,8) :: zlsm3d ! - - + LOGICAL , DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection + LOGICAL , DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection + !!---------------------------------------------------------------------- + zmat8 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(:,1)/) , DIM=2 ) + zmat1 = eoshift( zmat8 , SHIFT=-1 , BOUNDARY = (/zmat8(1,:)/) , DIM=1 ) + zmat2 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(1,:)/) , DIM=1 ) + zmat4 = eoshift( zfieldn , SHIFT= 1 , BOUNDARY = (/zfieldn(:,ilenj)/) , DIM=2 ) + zmat3 = eoshift( zmat4 , SHIFT=-1 , BOUNDARY = (/zmat4(1,:)/) , DIM=1 ) + zmat5 = eoshift( zmat4 , SHIFT= 1 , BOUNDARY = (/zmat4(ileni,:)/) , DIM=1 ) + zmat6 = eoshift( zfieldn , SHIFT= 1 , BOUNDARY = (/zfieldn(ileni,:)/) , DIM=1 ) + zmat7 = eoshift( zmat8 , SHIFT= 1 , BOUNDARY = (/zmat8(ileni,:)/) , DIM=1 ) + ! + zlsm3d = RESHAPE( (/ zmat1, zmat2, zmat3, zmat4, zmat5, zmat6, zmat7, zmat8 /), (/ ileni, ilenj, 8 /)) + ll_msknan3d = .NOT.( zlsm3d == undeff_lsm ) + ll_msknan2d = .NOT.( zfieldn == undeff_lsm ) ! FALSE where is Undeff (land) + zlsm2d = SUM( zlsm3d, 3 , ll_msknan3d ) / MAX( 1 , COUNT( ll_msknan3d , 3 ) ) + WHERE( COUNT( ll_msknan3d , 3 ) == 0._wp ) zlsm2d = undeff_lsm + zfield = MERGE( zfieldn, zlsm2d, ll_msknan2d ) + ! + END SUBROUTINE seaoverland + + + SUBROUTINE fld_interp( num, clvar, kw, kk, dta, nrec, lsmfile) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_interp *** + !! + !! ** Purpose : apply weights to input gridded data to create data + !! on model grid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: num ! stream number + CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name + INTEGER , INTENT(in ) :: kw ! weights number + INTEGER , INTENT(in ) :: kk ! vertical dimension of kk + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: dta ! output field on model grid + INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) + CHARACTER(LEN=*) , INTENT(in ) :: lsmfile ! land sea mask file name + ! + INTEGER, DIMENSION(3) :: rec1, recn ! temporary arrays for start and length + INTEGER, DIMENSION(3) :: rec1_lsm, recn_lsm ! temporary arrays for start and length in case of seaoverland + INTEGER :: ii_lsm1,ii_lsm2,ij_lsm1,ij_lsm2 ! temporary indices + INTEGER :: ji, jj, jk, jn, jir, jjr ! loop counters + INTEGER :: ipk + INTEGER :: ni, nj ! lengths + INTEGER :: jpimin,jpiwid ! temporary indices + INTEGER :: jpimin_lsm,jpiwid_lsm ! temporary indices + INTEGER :: jpjmin,jpjwid ! temporary indices + INTEGER :: jpjmin_lsm,jpjwid_lsm ! temporary indices + INTEGER :: jpi1,jpi2,jpj1,jpj2 ! temporary indices + INTEGER :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices + INTEGER :: itmpi,itmpj,itmpz ! lengths + REAL(wp),DIMENSION(:,:,:), ALLOCATABLE :: ztmp_fly_dta ! local array of values on input grid + !!---------------------------------------------------------------------- + ipk = SIZE(dta, 3) + ! + !! for weighted interpolation we have weights at four corners of a box surrounding + !! a model grid point, each weight is multiplied by a grid value (bilinear case) + !! or by a grid value and gradients at the corner point (bicubic case) + !! so we need to have a 4 by 4 subgrid surrounding each model point to cover both cases + + !! sub grid from non-model input grid which encloses all grid points in this nemo process + jpimin = ref_wgts(kw)%botleft(1) + jpjmin = ref_wgts(kw)%botleft(2) + jpiwid = ref_wgts(kw)%jpiwgt + jpjwid = ref_wgts(kw)%jpjwgt + + !! when reading in, expand this sub-grid by one halo point all the way round for calculating gradients + rec1(1) = MAX( jpimin-1, 1 ) + rec1(2) = MAX( jpjmin-1, 1 ) + rec1(3) = 1 + recn(1) = MIN( jpiwid+2, ref_wgts(kw)%ddims(1)-rec1(1)+1 ) + recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 ) + recn(3) = kk + + !! where we need to put it in the non-nemo grid fly_dta + !! note that jpi1 and jpj1 only differ from 1 when jpimin and jpjmin are 1 + !! (ie at the extreme west or south of the whole input grid) and similarly for jpi2 and jpj2 + jpi1 = 2 + rec1(1) - jpimin + jpj1 = 2 + rec1(2) - jpjmin + jpi2 = jpi1 + recn(1) - 1 + jpj2 = jpj1 + recn(2) - 1 + + + IF( LEN_TRIM(lsmfile) > 0 ) THEN + !! indeces for ztmp_fly_dta + ! -------------------------- + rec1_lsm(1)=MAX(rec1(1)-nn_lsm,1) ! starting index for enlarged external data, x direction + rec1_lsm(2)=MAX(rec1(2)-nn_lsm,1) ! starting index for enlarged external data, y direction + rec1_lsm(3) = 1 ! vertical dimension + recn_lsm(1)=MIN(rec1(1)-rec1_lsm(1)+recn(1)+nn_lsm,ref_wgts(kw)%ddims(1)-rec1_lsm(1)) ! n points in x direction + recn_lsm(2)=MIN(rec1(2)-rec1_lsm(2)+recn(2)+nn_lsm,ref_wgts(kw)%ddims(2)-rec1_lsm(2)) ! n points in y direction + recn_lsm(3) = kk ! number of vertical levels in the input file + + ! Avoid out of bound + jpimin_lsm = MAX( rec1_lsm(1)+1, 1 ) + jpjmin_lsm = MAX( rec1_lsm(2)+1, 1 ) + jpiwid_lsm = MIN( recn_lsm(1)-2,ref_wgts(kw)%ddims(1)-rec1(1)+1) + jpjwid_lsm = MIN( recn_lsm(2)-2,ref_wgts(kw)%ddims(2)-rec1(2)+1) + + jpi1_lsm = 2+rec1_lsm(1)-jpimin_lsm + jpj1_lsm = 2+rec1_lsm(2)-jpjmin_lsm + jpi2_lsm = jpi1_lsm + recn_lsm(1) - 1 + jpj2_lsm = jpj1_lsm + recn_lsm(2) - 1 + + + itmpi=jpi2_lsm-jpi1_lsm+1 + itmpj=jpj2_lsm-jpj1_lsm+1 + itmpz=kk + ALLOCATE(ztmp_fly_dta(itmpi,itmpj,itmpz)) + ztmp_fly_dta(:,:,:) = 0.0 + SELECT CASE( SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),3) ) + CASE(1) + CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), & + & nrec, kstart = rec1_lsm, kcount = recn_lsm) + CASE DEFAULT + CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & + & nrec, kstart = rec1_lsm, kcount = recn_lsm) + END SELECT + CALL apply_seaoverland(lsmfile,ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & + & jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm, & + & itmpi,itmpj,itmpz,rec1_lsm,recn_lsm) + + + ! Relative indeces for remapping + ii_lsm1 = (rec1(1)-rec1_lsm(1))+1 + ii_lsm2 = (ii_lsm1+recn(1))-1 + ij_lsm1 = (rec1(2)-rec1_lsm(2))+1 + ij_lsm2 = (ij_lsm1+recn(2))-1 + + ref_wgts(kw)%fly_dta(:,:,:) = 0.0 + ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:) = ztmp_fly_dta(ii_lsm1:ii_lsm2,ij_lsm1:ij_lsm2,:) + DEALLOCATE(ztmp_fly_dta) + + ELSE + + ref_wgts(kw)%fly_dta(:,:,:) = 0.0 + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn) + ENDIF + + + !! first four weights common to both bilinear and bicubic + !! data_jpi, data_jpj have already been shifted to (1,1) corresponding to botleft + !! note that we have to offset by 1 into fly_dta array because of halo added to fly_dta (rec1 definition) + dta(:,:,:) = 0._wp + DO jn = 1,4 + DO jk = 1, ipk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + 1 + nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + 1 + dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn) * ref_wgts(kw)%fly_dta(ni,nj,jk) + END DO ; END DO ; END DO + END DO + + IF(ref_wgts(kw)%numwgt .EQ. 16) THEN + + !! fix up halo points that we couldnt read from file + IF( jpi1 == 2 ) THEN + ref_wgts(kw)%fly_dta(jpi1-1,:,:) = ref_wgts(kw)%fly_dta(jpi1,:,:) + ENDIF + IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN + ref_wgts(kw)%fly_dta(jpi2+1,:,:) = ref_wgts(kw)%fly_dta(jpi2,:,:) + ENDIF + IF( jpj1 == 2 ) THEN + ref_wgts(kw)%fly_dta(:,jpj1-1,:) = ref_wgts(kw)%fly_dta(:,jpj1,:) + ENDIF + IF( jpj2 + jpjmin - 1 == ref_wgts(kw)%ddims(2)+1 .AND. jpj2 .LT. jpjwid+2 ) THEN + ref_wgts(kw)%fly_dta(:,jpj2+1,:) = 2.0*ref_wgts(kw)%fly_dta(:,jpj2,:) - ref_wgts(kw)%fly_dta(:,jpj2-1,:) + ENDIF + + !! if data grid is cyclic we can do better on east-west edges + !! but have to allow for whether first and last columns are coincident + IF( ref_wgts(kw)%cyclic ) THEN + rec1(2) = MAX( jpjmin-1, 1 ) + recn(1) = 1 + recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 ) + jpj1 = 2 + rec1(2) - jpjmin + jpj2 = jpj1 + recn(2) - 1 + IF( jpi1 == 2 ) THEN + rec1(1) = ref_wgts(kw)%ddims(1) - ref_wgts(kw)%overlap + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn) + ref_wgts(kw)%fly_dta(jpi1-1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:) + ENDIF + IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN + rec1(1) = 1 + ref_wgts(kw)%overlap + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn) + ref_wgts(kw)%fly_dta(jpi2+1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:) + ENDIF + ENDIF + ! +!!$ DO jn = 1,4 +!!$ DO jk = 1, ipk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) +!!$ ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + 1 +!!$ nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + 1 +!!$ dta(ji,jj,jk) = dta(ji,jj,jk) & +!!$ ! gradient in the i direction +!!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * & +!!$ & (ref_wgts(kw)%fly_dta(ni+1,nj ,jk) - ref_wgts(kw)%fly_dta(ni-1,nj ,jk)) & +!!$ ! gradient in the j direction +!!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+8) * 0.5_wp * & +!!$ & (ref_wgts(kw)%fly_dta(ni ,nj+1,jk) - ref_wgts(kw)%fly_dta(ni ,nj-1,jk)) & +!!$ ! gradient in the ij direction +!!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+12) * 0.25_wp * & +!!$ & ((ref_wgts(kw)%fly_dta(ni+1,nj+1,jk) - ref_wgts(kw)%fly_dta(ni-1,nj+1,jk)) - & +!!$ & (ref_wgts(kw)%fly_dta(ni+1,nj-1,jk) - ref_wgts(kw)%fly_dta(ni-1,nj-1,jk))) +!!$ END DO ; END DO ; END DO +!!$ END DO + ! + DO jn = 1,4 + DO jk = 1, ipk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + ! gradient in the i direction + dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * & + & (ref_wgts(kw)%fly_dta(ni+2,nj+1,jk) - ref_wgts(kw)%fly_dta(ni ,nj+1,jk)) + END DO ; END DO ; END DO + END DO + DO jn = 1,4 + DO jk = 1, ipk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + ! gradient in the j direction + dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+8) * 0.5_wp * & + & (ref_wgts(kw)%fly_dta(ni+1,nj+2,jk) - ref_wgts(kw)%fly_dta(ni+1,nj ,jk)) + END DO ; END DO ; END DO + END DO + DO jn = 1,4 + DO jk = 1, ipk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + ! gradient in the ij direction + dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+12) * 0.25_wp * ( & + & (ref_wgts(kw)%fly_dta(ni+2,nj+2,jk) - ref_wgts(kw)%fly_dta(ni ,nj+2,jk)) - & + & (ref_wgts(kw)%fly_dta(ni+2,nj ,jk) - ref_wgts(kw)%fly_dta(ni ,nj ,jk))) + END DO ; END DO ; END DO + END DO + ! + ENDIF + ! + END SUBROUTINE fld_interp + + + FUNCTION fld_filename( sdjf, kday, kmonth, kyear ) + !!--------------------------------------------------------------------- + !! *** FUNCTION fld_filename *** + !! + !! ** Purpose : define the filename according to a given date + !!--------------------------------------------------------------------- + TYPE(FLD), INTENT(in) :: sdjf ! input field related variables + INTEGER , INTENT(in) :: kday, kmonth, kyear + ! + CHARACTER(len = 256) :: clname, fld_filename + !!--------------------------------------------------------------------- + + + ! build the new filename if not climatological data + clname=TRIM(sdjf%clrootname) + ! + ! note that sdjf%ln_clim is is only acting on the presence of the year in the file name + IF( .NOT. sdjf%ln_clim ) THEN + WRITE(clname, '(a,"_y",i4.4)' ) TRIM( sdjf%clrootname ), kyear ! add year + IF( sdjf%clftyp /= 'yearly' ) WRITE(clname, '(a, "m",i2.2)' ) TRIM( clname ), kmonth ! add month + ELSE + ! build the new filename if climatological data + IF( sdjf%clftyp /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( sdjf%clrootname ), kmonth ! add month + ENDIF + IF( sdjf%clftyp == 'daily' .OR. sdjf%clftyp(1:4) == 'week' ) & + & WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname ), kday ! add day + + fld_filename = clname + + END FUNCTION fld_filename + + + FUNCTION ksec_week( cdday ) + !!--------------------------------------------------------------------- + !! *** FUNCTION ksec_week *** + !! + !! ** Purpose : seconds between 00h of the beginning of the week and half of the current time step + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdday ! first 3 letters of the first day of the weekly file + !! + INTEGER :: ksec_week ! output variable + INTEGER :: ijul, ishift ! local integer + CHARACTER(len=3),DIMENSION(7) :: cl_week + !!---------------------------------------------------------------------- + cl_week = (/"sun","sat","fri","thu","wed","tue","mon"/) + DO ijul = 1, 7 + IF( cl_week(ijul) == TRIM(cdday) ) EXIT + END DO + IF( ijul .GT. 7 ) CALL ctl_stop( 'ksec_week: wrong day for sdjf%clftyp(6:8): '//TRIM(cdday) ) + ! + ishift = ijul * NINT(rday) + ! + ksec_week = nsec_monday + ishift + ksec_week = MOD( ksec_week, 7*NINT(rday) ) + ! + END FUNCTION ksec_week + + !!====================================================================== +END MODULE fldread diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flo4rk.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flo4rk.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2370cadfbec84e051cf234311c41aa9bd0daf8da --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flo4rk.f90 @@ -0,0 +1,475 @@ + + + + + + + + + + + + + +MODULE flo4rk + !!====================================================================== + !! *** MODULE flo4rk *** + !! Ocean floats : trajectory computation using a 4th order Runge-Kutta + !!====================================================================== + !! + !!---------------------------------------------------------------------- + !! flo_4rk : Compute the geographical position of floats + !! flo_interp : interpolation + !!---------------------------------------------------------------------- + USE flo_oce ! ocean drifting floats + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_4rk ! routine called by floats.F90 + + ! ! RK4 and Lagrange interpolation coefficients + REAL(wp), DIMENSION (4) :: tcoef1 = (/ 1.0 , 0.5 , 0.5 , 0.0 /) ! + REAL(wp), DIMENSION (4) :: tcoef2 = (/ 0.0 , 0.5 , 0.5 , 1.0 /) ! + REAL(wp), DIMENSION (4) :: scoef2 = (/ 1.0 , 2.0 , 2.0 , 1.0 /) ! + REAL(wp), DIMENSION (4) :: rcoef = (/-1./6. , 1./2. ,-1./2. , 1./6. /) ! + REAL(wp), DIMENSION (3) :: scoef1 = (/ 0.5 , 0.5 , 1.0 /) ! + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: flo4rk.F90 13237 2020-07-03 09:12:53Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_4rk( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE flo_4rk *** + !! + !! ** Purpose : Compute the geographical position (lat,lon,depth) + !! of each float at each time step. + !! + !! ** Method : The position of a float is computed with a 4th order + !! Runge-Kutta scheme and and Lagrange interpolation. + !! We need to know the velocity field, the old positions of the + !! floats and the grid defined on the domain. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + !! + INTEGER :: jfl, jind ! dummy loop indices + INTEGER :: ierror ! error value + + REAL(wp), DIMENSION(jpnfl) :: zgifl , zgjfl , zgkfl ! index RK positions + REAL(wp), DIMENSION(jpnfl) :: zufl , zvfl , zwfl ! interpolated velocity at the float position + REAL(wp), DIMENSION(jpnfl,4) :: zrkxfl, zrkyfl, zrkzfl ! RK coefficients + !!--------------------------------------------------------------------- + ! + IF( ierror /= 0 ) THEN + WRITE(numout,*) 'flo_4rk: allocation of workspace arrays failed' + ENDIF + + + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'flo_4rk : compute Runge Kutta trajectories for floats ' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + + ! Verification of the floats positions. If one of them leave the domain + ! domain we replace the float near the border. + DO jfl = 1, jpnfl + ! i-direction + IF( tpifl(jfl) <= 1.5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the WEST border.' + tpifl(jfl) = tpifl(jfl) + 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at i=',tpifl(jfl) + ENDIF + + IF( tpifl(jfl) >= jpi-.5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the EAST border.' + tpifl(jfl) = tpifl(jfl) - 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at i=', tpifl(jfl) + ENDIF + ! j-direction + IF( tpjfl(jfl) <= 1.5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the SOUTH border.' + tpjfl(jfl) = tpjfl(jfl) + 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at j=', tpjfl(jfl) + ENDIF + + IF( tpjfl(jfl) >= jpj-.5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the NORTH border.' + tpjfl(jfl) = tpjfl(jfl) - 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at j=', tpjfl(jfl) + ENDIF + ! k-direction + IF( tpkfl(jfl) <= .5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the TOP border.' + tpkfl(jfl) = tpkfl(jfl) + 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at k=', tpkfl(jfl) + ENDIF + + IF( tpkfl(jfl) >= jpk-.5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the BOTTOM border.' + tpkfl(jfl) = tpkfl(jfl) - 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at k=', tpkfl(jfl) + ENDIF + END DO + + ! 4 steps of Runge-Kutta algorithme + ! initialisation of the positions + + DO jfl = 1, jpnfl + zgifl(jfl) = tpifl(jfl) + zgjfl(jfl) = tpjfl(jfl) + zgkfl(jfl) = tpkfl(jfl) + END DO + + DO jind = 1, 4 + + ! for each step we compute the compute the velocity with Lagrange interpolation + CALL flo_interp( Kbb, Kmm, zgifl, zgjfl, zgkfl, zufl, zvfl, zwfl, jind ) + + ! computation of Runge-Kutta factor + DO jfl = 1, jpnfl + zrkxfl(jfl,jind) = rn_Dt*zufl(jfl) + zrkyfl(jfl,jind) = rn_Dt*zvfl(jfl) + zrkzfl(jfl,jind) = rn_Dt*zwfl(jfl) + END DO + IF( jind /= 4 ) THEN + DO jfl = 1, jpnfl + zgifl(jfl) = (tpifl(jfl)) + scoef1(jind)*zrkxfl(jfl,jind) + zgjfl(jfl) = (tpjfl(jfl)) + scoef1(jind)*zrkyfl(jfl,jind) + zgkfl(jfl) = (tpkfl(jfl)) + scoef1(jind)*zrkzfl(jfl,jind) + END DO + ENDIF + END DO + DO jind = 1, 4 + DO jfl = 1, jpnfl + tpifl(jfl) = tpifl(jfl) + scoef2(jind)*zrkxfl(jfl,jind)/6. + tpjfl(jfl) = tpjfl(jfl) + scoef2(jind)*zrkyfl(jfl,jind)/6. + tpkfl(jfl) = tpkfl(jfl) + scoef2(jind)*zrkzfl(jfl,jind)/6. + END DO + END DO + ! + ! + END SUBROUTINE flo_4rk + + + SUBROUTINE flo_interp( Kbb, Kmm, & + & pxt , pyt , pzt , & + & pufl, pvfl, pwfl, ki ) + !!---------------------------------------------------------------------- + !! *** ROUTINE flointerp *** + !! + !! ** Purpose : Interpolation of the velocity on the float position + !! + !! ** Method : Lagrange interpolation with the 64 neighboring + !! points. This routine is call 4 time at each time step to + !! compute velocity at the date and the position we need to + !! integrated with RK method. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp) , DIMENSION(jpnfl), INTENT(in ) :: pxt , pyt , pzt ! position of the float + REAL(wp) , DIMENSION(jpnfl), INTENT( out) :: pufl, pvfl, pwfl ! velocity at this position + INTEGER , INTENT(in ) :: ki ! + !! + INTEGER :: jfl, jind1, jind2, jind3 ! dummy loop indices + REAL(wp) :: zsumu, zsumv, zsumw ! local scalar + INTEGER , DIMENSION(jpnfl) :: iilu, ijlu, iklu ! nearest neighbour INDEX-u + INTEGER , DIMENSION(jpnfl) :: iilv, ijlv, iklv ! nearest neighbour INDEX-v + INTEGER , DIMENSION(jpnfl) :: iilw, ijlw, iklw ! nearest neighbour INDEX-w + INTEGER , DIMENSION(jpnfl,4) :: iidu, ijdu, ikdu ! 64 nearest neighbour INDEX-u + INTEGER , DIMENSION(jpnfl,4) :: iidv, ijdv, ikdv ! 64 nearest neighbour INDEX-v + INTEGER , DIMENSION(jpnfl,4) :: iidw, ijdw, ikdw ! 64 nearest neighbour INDEX-w + REAL(wp) , DIMENSION(jpnfl,4) :: zlagxu, zlagyu, zlagzu ! Lagrange coefficients + REAL(wp) , DIMENSION(jpnfl,4) :: zlagxv, zlagyv, zlagzv ! - - + REAL(wp) , DIMENSION(jpnfl,4) :: zlagxw, zlagyw, zlagzw ! - - + REAL(wp) , DIMENSION(jpnfl,4,4,4) :: ztufl , ztvfl , ztwfl ! velocity at choosen time step + !!--------------------------------------------------------------------- + + ! Interpolation of U velocity + + ! nearest neightboring point for computation of u + DO jfl = 1, jpnfl + iilu(jfl) = INT(pxt(jfl)-.5) + ijlu(jfl) = INT(pyt(jfl)-.5) + iklu(jfl) = INT(pzt(jfl)) + END DO + + ! 64 neightboring points for computation of u + DO jind1 = 1, 4 + DO jfl = 1, jpnfl + ! i-direction + IF( iilu(jfl) <= 2 ) THEN ; iidu(jfl,jind1) = jind1 + ELSE + IF( iilu(jfl) >= jpi-1 ) THEN ; iidu(jfl,jind1) = jpi + jind1 - 4 + ELSE ; iidu(jfl,jind1) = iilu(jfl) + jind1 - 2 + ENDIF + ENDIF + ! j-direction + IF( ijlu(jfl) <= 2 ) THEN ; ijdu(jfl,jind1) = jind1 + ELSE + IF( ijlu(jfl) >= jpj-1 ) THEN ; ijdu(jfl,jind1) = jpj + jind1 - 4 + ELSE ; ijdu(jfl,jind1) = ijlu(jfl) + jind1 - 2 + ENDIF + ENDIF + ! k-direction + IF( iklu(jfl) <= 2 ) THEN ; ikdu(jfl,jind1) = jind1 + ELSE + IF( iklu(jfl) >= jpk-1 ) THEN ; ikdu(jfl,jind1) = jpk + jind1 - 4 + ELSE ; ikdu(jfl,jind1) = iklu(jfl) + jind1 - 2 + ENDIF + ENDIF + END DO + END DO + + ! Lagrange coefficients + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + zlagxu(jfl,jind1) = 1. + zlagyu(jfl,jind1) = 1. + zlagzu(jfl,jind1) = 1. + END DO + END DO + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jfl= 1, jpnfl + IF( jind1 /= jind2 ) THEN + zlagxu(jfl,jind1) = zlagxu(jfl,jind1) * ( pxt(jfl)-(float(iidu(jfl,jind2))+.5) ) + zlagyu(jfl,jind1) = zlagyu(jfl,jind1) * ( pyt(jfl)-(float(ijdu(jfl,jind2))) ) + zlagzu(jfl,jind1) = zlagzu(jfl,jind1) * ( pzt(jfl)-(float(ikdu(jfl,jind2))) ) + ENDIF + END DO + END DO + END DO + + ! velocity when we compute at middle time step + + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1, 4 + ztufl(jfl,jind1,jind2,jind3) = & + & ( tcoef1(ki) * uu(iidu(jfl,jind1),ijdu(jfl,jind2),ikdu(jfl,jind3),Kbb) + & + & tcoef2(ki) * uu(iidu(jfl,jind1),ijdu(jfl,jind2),ikdu(jfl,jind3),Kmm) ) & + & / e1u(iidu(jfl,jind1),ijdu(jfl,jind2)) + END DO + END DO + END DO + + zsumu = 0. + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1, 4 + zsumu = zsumu + ztufl(jfl,jind1,jind2,jind3) * zlagxu(jfl,jind1) * zlagyu(jfl,jind2) & + & * zlagzu(jfl,jind3) * rcoef(jind1)*rcoef(jind2)*rcoef(jind3) + END DO + END DO + END DO + pufl(jfl) = zsumu + END DO + + ! Interpolation of V velocity + + ! nearest neightboring point for computation of v + DO jfl = 1, jpnfl + iilv(jfl) = INT(pxt(jfl)-.5) + ijlv(jfl) = INT(pyt(jfl)-.5) + iklv(jfl) = INT(pzt(jfl)) + END DO + + ! 64 neightboring points for computation of v + DO jind1 = 1, 4 + DO jfl = 1, jpnfl + ! i-direction + IF( iilv(jfl) <= 2 ) THEN ; iidv(jfl,jind1) = jind1 + ELSE + IF( iilv(jfl) >= jpi-1 ) THEN ; iidv(jfl,jind1) = jpi + jind1 - 4 + ELSE ; iidv(jfl,jind1) = iilv(jfl) + jind1 - 2 + ENDIF + ENDIF + ! j-direction + IF( ijlv(jfl) <= 2 ) THEN ; ijdv(jfl,jind1) = jind1 + ELSE + IF( ijlv(jfl) >= jpj-1 ) THEN ; ijdv(jfl,jind1) = jpj + jind1 - 4 + ELSE ; ijdv(jfl,jind1) = ijlv(jfl) + jind1 - 2 + ENDIF + ENDIF + ! k-direction + IF( iklv(jfl) <= 2 ) THEN ; ikdv(jfl,jind1) = jind1 + ELSE + IF( iklv(jfl) >= jpk-1 ) THEN ; ikdv(jfl,jind1) = jpk + jind1 - 4 + ELSE ; ikdv(jfl,jind1) = iklv(jfl) + jind1 - 2 + ENDIF + ENDIF + END DO + END DO + + ! Lagrange coefficients + + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + zlagxv(jfl,jind1) = 1. + zlagyv(jfl,jind1) = 1. + zlagzv(jfl,jind1) = 1. + END DO + END DO + + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jfl = 1, jpnfl + IF( jind1 /= jind2 ) THEN + zlagxv(jfl,jind1)= zlagxv(jfl,jind1)*(pxt(jfl) - (float(iidv(jfl,jind2)) ) ) + zlagyv(jfl,jind1)= zlagyv(jfl,jind1)*(pyt(jfl) - (float(ijdv(jfl,jind2))+.5) ) + zlagzv(jfl,jind1)= zlagzv(jfl,jind1)*(pzt(jfl) - (float(ikdv(jfl,jind2)) ) ) + ENDIF + END DO + END DO + END DO + + ! velocity when we compute at middle time step + + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1 ,4 + ztvfl(jfl,jind1,jind2,jind3)= & + & ( tcoef1(ki) * vv(iidv(jfl,jind1),ijdv(jfl,jind2),ikdv(jfl,jind3),Kbb) + & + & tcoef2(ki) * vv(iidv(jfl,jind1),ijdv(jfl,jind2),ikdv(jfl,jind3),Kmm) ) & + & / e2v(iidv(jfl,jind1),ijdv(jfl,jind2)) + END DO + END DO + END DO + + zsumv=0. + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1, 4 + zsumv = zsumv + ztvfl(jfl,jind1,jind2,jind3) * zlagxv(jfl,jind1) * zlagyv(jfl,jind2) & + & * zlagzv(jfl,jind3) * rcoef(jind1)*rcoef(jind2)*rcoef(jind3) + END DO + END DO + END DO + pvfl(jfl) = zsumv + END DO + + ! Interpolation of W velocity + + ! nearest neightboring point for computation of w + DO jfl = 1, jpnfl + iilw(jfl) = INT( pxt(jfl) ) + ijlw(jfl) = INT( pyt(jfl) ) + iklw(jfl) = INT( pzt(jfl)+.5) + END DO + + ! 64 neightboring points for computation of w + DO jind1 = 1, 4 + DO jfl = 1, jpnfl + ! i-direction + IF( iilw(jfl) <= 2 ) THEN ; iidw(jfl,jind1) = jind1 + ELSE + IF( iilw(jfl) >= jpi-1 ) THEN ; iidw(jfl,jind1) = jpi + jind1 - 4 + ELSE ; iidw(jfl,jind1) = iilw(jfl) + jind1 - 2 + ENDIF + ENDIF + ! j-direction + IF( ijlw(jfl) <= 2 ) THEN ; ijdw(jfl,jind1) = jind1 + ELSE + IF( ijlw(jfl) >= jpj-1 ) THEN ; ijdw(jfl,jind1) = jpj + jind1 - 4 + ELSE ; ijdw(jfl,jind1) = ijlw(jfl) + jind1 - 2 + ENDIF + ENDIF + ! k-direction + IF( iklw(jfl) <= 2 ) THEN ; ikdw(jfl,jind1) = jind1 + ELSE + IF( iklw(jfl) >= jpk-1 ) THEN ; ikdw(jfl,jind1) = jpk + jind1 - 4 + ELSE ; ikdw(jfl,jind1) = iklw(jfl) + jind1 - 2 + ENDIF + ENDIF + END DO + END DO + DO jind1 = 1, 4 + DO jfl = 1, jpnfl + IF( iklw(jfl) <= 2 ) THEN ; ikdw(jfl,jind1) = jind1 + ELSE + IF( iklw(jfl) >= jpk-1 ) THEN ; ikdw(jfl,jind1) = jpk + jind1 - 4 + ELSE ; ikdw(jfl,jind1) = iklw(jfl) + jind1 - 2 + ENDIF + ENDIF + END DO + END DO + + ! Lagrange coefficients for w interpolation + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + zlagxw(jfl,jind1) = 1. + zlagyw(jfl,jind1) = 1. + zlagzw(jfl,jind1) = 1. + END DO + END DO + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jfl = 1, jpnfl + IF( jind1 /= jind2 ) THEN + zlagxw(jfl,jind1) = zlagxw(jfl,jind1) * (pxt(jfl) - (float(iidw(jfl,jind2)) ) ) + zlagyw(jfl,jind1) = zlagyw(jfl,jind1) * (pyt(jfl) - (float(ijdw(jfl,jind2)) ) ) + zlagzw(jfl,jind1) = zlagzw(jfl,jind1) * (pzt(jfl) - (float(ikdw(jfl,jind2))-.5) ) + ENDIF + END DO + END DO + END DO + + ! velocity w when we compute at middle time step + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1, 4 + ztwfl(jfl,jind1,jind2,jind3)= & + & ( tcoef1(ki) * wb(iidw(jfl,jind1),ijdw(jfl,jind2),ikdw(jfl,jind3))+ & + & tcoef2(ki) * ww(iidw(jfl,jind1),ijdw(jfl,jind2),ikdw(jfl,jind3)) ) & + & / (e3w_0(iidw(jfl,jind1),ijdw(jfl,jind2),ikdw(jfl,jind3))*(1._wp+r3t(iidw(jfl,jind1),ijdw(jfl,jind2),Kmm))) + END DO + END DO + END DO + + zsumw = 0.e0 + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1, 4 + zsumw = zsumw + ztwfl(jfl,jind1,jind2,jind3) * zlagxw(jfl,jind1) * zlagyw(jfl,jind2) & + & * zlagzw(jfl,jind3) * rcoef(jind1)*rcoef(jind2)*rcoef(jind3) + END DO + END DO + END DO + pwfl(jfl) = zsumw + END DO + ! + ! + END SUBROUTINE flo_interp + + !!====================================================================== +END MODULE flo4rk diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flo_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flo_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3f1b6a275d47212b6048c81e3926bdd130c7bce0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flo_oce.f90 @@ -0,0 +1,79 @@ + + + + + + + + + + + + + +MODULE flo_oce + !!====================================================================== + !! *** MODULE flo_oce *** + !! lagrangian floats : define in memory all floats parameters and variables + !!====================================================================== + !! History : OPA ! 1999-10 (CLIPPER projet) + !! NEMO 1.0 ! 2002-11 (G. Madec, A. Bozec) F90: Free form and module + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PUBLIC + + PUBLIC flo_oce_alloc ! Routine called in floats.F90 + + !! float parameters + !! ---------------- + LOGICAL, PUBLIC :: ln_floats !: Activate floats or not + INTEGER, PUBLIC :: jpnfl = 0 !: total number of floats during the run + INTEGER, PUBLIC :: jpnnewflo !: number of floats added in a new run + INTEGER, PUBLIC :: jpnrstflo !: number of floats for the restart + + !! float variables + !! --------------- + INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: nisobfl !: =0 for a isobar float , =1 for a float following the w velocity + INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: ngrpfl !: number to identify searcher group + INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: nfloat !: number to identify searcher group + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: flxx , flyy , flzz !: long, lat, depth of float (decimal degree, m >0) + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: tpifl, tpjfl, tpkfl !: (i,j,k) indices of float position + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wb !: vertical velocity at previous time step (m s-1). + + ! !! * namelist namflo : langrangian floats * + LOGICAL, PUBLIC :: ln_rstflo !: T/F float restart + LOGICAL, PUBLIC :: ln_argo !: T/F argo type floats + LOGICAL, PUBLIC :: ln_flork4 !: T/F 4th order Runge-Kutta + LOGICAL, PUBLIC :: ln_ariane !: handle ariane input/output convention + LOGICAL, PUBLIC :: ln_flo_ascii !: write in ascii (T) or in Netcdf (F) + + INTEGER, PUBLIC :: nn_writefl !: frequency of float output file + INTEGER, PUBLIC :: nn_stockfl !: frequency of float restart file + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: flo_oce.F90 13558 2020-10-02 15:30:22Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION flo_oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION flo_oce_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( wb(jpi,jpj,jpk) , nfloat(jpnfl) , nisobfl(jpnfl) , ngrpfl(jpnfl) , & + & flxx(jpnfl) , flyy(jpnfl) , flzz(jpnfl) , & + & tpifl(jpnfl) , tpjfl(jpnfl) , tpkfl(jpnfl) , STAT=flo_oce_alloc ) + ! + CALL mpp_sum ( 'flo_oce', flo_oce_alloc ) + IF( flo_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'flo_oce_alloc: failed to allocate arrays' ) + END FUNCTION flo_oce_alloc + + !!====================================================================== +END MODULE flo_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/floats.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/floats.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5673dcda3e0c47a9e61528efdd93d888fc24c186 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/floats.f90 @@ -0,0 +1,154 @@ + + + + + + + + + + + + + +MODULE floats + !!====================================================================== + !! *** MODULE floats *** + !! Ocean floats : floats + !!====================================================================== + !! History : OPA ! (CLIPPER) original Code + !! NEMO 1.0 ! 2002-06 (A. Bozec) F90, Free form and module + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + !! flo_stp : float trajectories computation + !! flo_init : initialization of float trajectories computation + !!---------------------------------------------------------------------- + USE oce ! ocean variables + USE flo_oce ! floats variables + USE lib_mpp ! distributed memory computing + USE flodom ! initialisation Module + USE flowri ! float output (flo_wri routine) + USE florst ! float restart (flo_rst routine) + USE flo4rk ! Trajectories, Runge Kutta scheme (flo_4rk routine) + USE floblk ! Trajectories, Blanke scheme (flo_blk routine) + ! + USE in_out_manager ! I/O manager + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_stp ! routine called by step.F90 + PUBLIC flo_init ! routine called by nemogcm.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: floats.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_stp( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE flo_stp *** + !! + !! ** Purpose : Compute the geographical position (lat., long., depth) + !! of each float at each time step with one of the algorithm. + !! + !! ** Method : The position of a float is computed with Bruno Blanke + !! algorithm by default and with a 4th order Runge-Kutta scheme + !! if ln_flork4 =T + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time step + INTEGER, INTENT( in ) :: Kbb, Kmm ! ocean time level indices + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('flo_stp') + ! + IF( ln_flork4 ) THEN ; CALL flo_4rk( kt, Kbb, Kmm ) ! Trajectories using a 4th order Runge Kutta scheme + ELSE ; CALL flo_blk( kt, Kbb, Kmm ) ! Trajectories using Blanke' algorithme + ENDIF + ! + IF( lk_mpp ) CALL mppsync ! synchronization of all the processor + ! + CALL flo_wri( kt, Kmm ) ! trajectories ouput + ! + CALL flo_rst( kt ) ! trajectories restart + ! + wb(:,:,:) = ww(:,:,:) ! Save the old vertical velocity field + ! + IF( ln_timing ) CALL timing_stop('flo_stp') + ! + END SUBROUTINE flo_stp + + + SUBROUTINE flo_init( Kmm ) + !!---------------------------------------------------------------- + !! *** ROUTINE flo_init *** + !! + !! ** Purpose : Read the namelist of floats + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: jfl + INTEGER :: ios ! Local integer output status for namelist read + ! + NAMELIST/namflo/ ln_floats, jpnfl, jpnnewflo, ln_rstflo, nn_writefl, nn_stockfl, ln_argo, ln_flork4, ln_ariane, ln_flo_ascii + !!--------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'flo_stp : call floats routine ' + IF(lwp) WRITE(numout,*) '~~~~~~~' + + READ ( numnam_ref, namflo, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namflo in reference namelist' ) + + READ ( numnam_cfg, namflo, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namflo in configuration namelist' ) + IF(lwm) WRITE ( numond, namflo ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' Namelist floats :' + WRITE(numout,*) ' Activate floats or not ln_floats = ', ln_floats + WRITE(numout,*) ' number of floats jpnfl = ', jpnfl + WRITE(numout,*) ' number of new floats jpnflnewflo = ', jpnnewflo + WRITE(numout,*) ' restart ln_rstflo = ', ln_rstflo + WRITE(numout,*) ' frequency of float output file nn_writefl = ', nn_writefl + WRITE(numout,*) ' frequency of float restart file nn_stockfl = ', nn_stockfl + WRITE(numout,*) ' Argo type floats ln_argo = ', ln_argo + WRITE(numout,*) ' Computation of T trajectories ln_flork4 = ', ln_flork4 + WRITE(numout,*) ' Use of ariane convention ln_ariane = ', ln_ariane + WRITE(numout,*) ' ascii output (T) or netcdf output (F) ln_flo_ascii = ', ln_flo_ascii + + ENDIF + ! + IF( ln_floats ) THEN + ! ! allocate floats arrays + IF( flo_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) + ! + ! ! allocate flodom arrays + IF( flo_dom_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_dom : unable to allocate arrays' ) + ! + ! ! allocate flowri arrays + IF( flo_wri_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) + ! + ! ! allocate florst arrays + IF( flo_rst_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_rst : unable to allocate arrays' ) + ! + jpnrstflo = jpnfl-jpnnewflo ! memory allocation + ! + DO jfl = 1, jpnfl ! vertical axe for netcdf IOM ouput + nfloat(jfl) = jfl + END DO + ! + CALL flo_dom( Kmm ) ! compute/read initial position of floats + ! + wb(:,:,:) = ww(:,:,:) ! set wb for computation of floats trajectories at the first time step + ! + ENDIF + END SUBROUTINE flo_init + + !!====================================================================== + END MODULE floats diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/floblk.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/floblk.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0c4f2502591883f0c8e04d0affdd669fc46d973b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/floblk.f90 @@ -0,0 +1,402 @@ + + + + + + + + + + + + + +MODULE floblk + !!====================================================================== + !! *** MODULE floblk *** + !! Ocean floats : trajectory computation + !!====================================================================== + !! + !!---------------------------------------------------------------------- + !! flotblk : compute float trajectories with Blanke algorithme + !!---------------------------------------------------------------------- + USE flo_oce ! ocean drifting floats + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_blk ! routine called by floats.F90 + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: floblk.F90 14229 2020-12-20 12:45:55Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_blk( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE flo_blk *** + !! + !! ** Purpose : Compute the geographical position,latitude, longitude + !! and depth of each float at each time step. + !! + !! ** Method : The position of a float is computed with Bruno Blanke + !! algorithm. We need to know the velocity field, the old positions + !! of the floats and the grid defined on the domain. + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time step + INTEGER, INTENT( in ) :: Kbb, Kmm ! ocean time level indices + !! + +!RB super quick fix to compile with agrif + + INTEGER :: jfl ! dummy loop arguments + INTEGER :: ind, ifin, iloop + REAL(wp) :: & + zuinfl,zvinfl,zwinfl, & ! transport across the input face + zuoutfl,zvoutfl,zwoutfl, & ! transport across the ouput face + zvol, & ! volume of the mesh + zsurfz, & ! surface of the face of the mesh + zind + + REAL(wp), DIMENSION ( 2 ) :: zsurfx, zsurfy ! surface of the face of the mesh + + INTEGER , DIMENSION ( jpnfl ) :: iil, ijl, ikl ! index of nearest mesh + INTEGER , DIMENSION ( jpnfl ) :: iiloc , ijloc + INTEGER , DIMENSION ( jpnfl ) :: iiinfl, ijinfl, ikinfl ! index of input mesh of the float. + INTEGER , DIMENSION ( jpnfl ) :: iioutfl, ijoutfl, ikoutfl ! index of output mesh of the float. + REAL(wp) , DIMENSION ( jpnfl ) :: zgifl, zgjfl, zgkfl ! position of floats, index on + ! ! velocity mesh. + REAL(wp) , DIMENSION ( jpnfl ) :: ztxfl, ztyfl, ztzfl ! time for a float to quit the mesh + ! ! across one of the face x,y and z + REAL(wp) , DIMENSION ( jpnfl ) :: zttfl ! time for a float to quit the mesh + REAL(wp) , DIMENSION ( jpnfl ) :: zagefl ! time during which, trajectorie of + ! ! the float has been computed + REAL(wp) , DIMENSION ( jpnfl ) :: zagenewfl ! new age of float after calculation + ! ! of new position + REAL(wp) , DIMENSION ( jpnfl ) :: zufl, zvfl, zwfl ! interpolated vel. at float position + REAL(wp) , DIMENSION ( jpnfl ) :: zudfl, zvdfl, zwdfl ! velocity diff input/output of mesh + REAL(wp) , DIMENSION ( jpnfl ) :: zgidfl, zgjdfl, zgkdfl ! direction index of float + !!--------------------------------------------------------------------- + + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'flo_blk : compute Blanke trajectories for floats ' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + + ! Initialisation of parameters + + DO jfl = 1, jpnfl + ! ages of floats are put at zero + zagefl(jfl) = 0. + ! index on the velocity grid + ! We considere k coordinate negative, with this transformation + ! the computation in the 3 direction is the same. + zgifl(jfl) = tpifl(jfl) - 0.5 + zgjfl(jfl) = tpjfl(jfl) - 0.5 + zgkfl(jfl) = MIN(-1.,-(tpkfl(jfl))) + ! surface drift every 10 days + IF( ln_argo ) THEN + IF( MOD(kt,150) >= 146 .OR. MOD(kt,150) == 0 ) zgkfl(jfl) = -1. + ENDIF + ! index of T mesh + iil(jfl) = 1 + INT(zgifl(jfl)) + ijl(jfl) = 1 + INT(zgjfl(jfl)) + ikl(jfl) = INT(zgkfl(jfl)) + END DO + + iloop = 0 +222 DO jfl = 1, jpnfl + IF( iil(jfl) >= mig(Nis0) .AND. iil(jfl) <= mig(Nie0) .AND. & + ijl(jfl) >= mjg(Njs0) .AND. ijl(jfl) <= mjg(Nje0) ) THEN + iiloc(jfl) = iil(jfl) - mig(1) + 1 + ijloc(jfl) = ijl(jfl) - mjg(1) + 1 + + ! compute the transport across the mesh where the float is. +!!bug (gm) change e3t into e3. but never checked + zsurfx(1) = & + & e2u(iiloc(jfl)-1,ijloc(jfl) ) & + & * (e3u_0(iiloc(jfl)-1,ijloc(jfl) ,-ikl(jfl))*(1._wp+r3u(iiloc(jfl)-1,ijloc(jfl) ,Kmm)*umask(iiloc(jfl)-1,ijloc(jfl) ,-ikl(jfl)))) + zsurfx(2) = & + & e2u(iiloc(jfl) ,ijloc(jfl) ) & + & * (e3u_0(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl))*(1._wp+r3u(iiloc(jfl) ,ijloc(jfl) ,Kmm)*umask(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl)))) + zsurfy(1) = & + & e1v(iiloc(jfl) ,ijloc(jfl)-1) & + & * (e3v_0(iiloc(jfl) ,ijloc(jfl)-1,-ikl(jfl))*(1._wp+r3v(iiloc(jfl) ,ijloc(jfl)-1,Kmm)*vmask(iiloc(jfl) ,ijloc(jfl)-1,-ikl(jfl)))) + zsurfy(2) = & + & e1v(iiloc(jfl) ,ijloc(jfl) ) & + & * (e3v_0(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl))*(1._wp+r3v(iiloc(jfl) ,ijloc(jfl) ,Kmm)*vmask(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl)))) + + ! for a isobar float zsurfz is put to zero. The vertical velocity will be zero too. + zsurfz = e1e2t(iiloc(jfl),ijloc(jfl)) + zvol = zsurfz * (e3t_0(iiloc(jfl),ijloc(jfl),-ikl(jfl))*(1._wp+r3t(iiloc(jfl),ijloc(jfl),Kmm)*tmask(iiloc(jfl),ijloc(jfl),-ikl(jfl)))) + + ! + zuinfl =( uu(iiloc(jfl)-1,ijloc(jfl),-ikl(jfl),Kbb) + uu(iiloc(jfl)-1,ijloc(jfl),-ikl(jfl),Kmm) )/2.*zsurfx(1) + zuoutfl=( uu(iiloc(jfl) ,ijloc(jfl),-ikl(jfl),Kbb) + uu(iiloc(jfl) ,ijloc(jfl),-ikl(jfl),Kmm) )/2.*zsurfx(2) + zvinfl =( vv(iiloc(jfl),ijloc(jfl)-1,-ikl(jfl),Kbb) + vv(iiloc(jfl),ijloc(jfl)-1,-ikl(jfl),Kmm) )/2.*zsurfy(1) + zvoutfl=( vv(iiloc(jfl),ijloc(jfl) ,-ikl(jfl),Kbb) + vv(iiloc(jfl),ijloc(jfl) ,-ikl(jfl),Kmm) )/2.*zsurfy(2) + zwinfl =-(wb(iiloc(jfl),ijloc(jfl),-(ikl(jfl)-1)) & + & + ww(iiloc(jfl),ijloc(jfl),-(ikl(jfl)-1)) )/2. * zsurfz*nisobfl(jfl) + zwoutfl=-(wb(iiloc(jfl),ijloc(jfl),- ikl(jfl) ) & + & + ww(iiloc(jfl),ijloc(jfl),- ikl(jfl) ) )/2. * zsurfz*nisobfl(jfl) + + ! interpolation of velocity field on the float initial position + zufl(jfl)= zuinfl + ( zgifl(jfl) - float(iil(jfl)-1) ) * ( zuoutfl - zuinfl) + zvfl(jfl)= zvinfl + ( zgjfl(jfl) - float(ijl(jfl)-1) ) * ( zvoutfl - zvinfl) + zwfl(jfl)= zwinfl + ( zgkfl(jfl) - float(ikl(jfl)-1) ) * ( zwoutfl - zwinfl) + + ! faces of input and output + ! u-direction + IF( zufl(jfl) < 0. ) THEN + iioutfl(jfl) = iil(jfl) - 1. + iiinfl (jfl) = iil(jfl) + zind = zuinfl + zuinfl = zuoutfl + zuoutfl= zind + ELSE + iioutfl(jfl) = iil(jfl) + iiinfl (jfl) = iil(jfl) - 1 + ENDIF + ! v-direction + IF( zvfl(jfl) < 0. ) THEN + ijoutfl(jfl) = ijl(jfl) - 1. + ijinfl (jfl) = ijl(jfl) + zind = zvinfl + zvinfl = zvoutfl + zvoutfl = zind + ELSE + ijoutfl(jfl) = ijl(jfl) + ijinfl (jfl) = ijl(jfl) - 1. + ENDIF + ! w-direction + IF( zwfl(jfl) < 0. ) THEN + ikoutfl(jfl) = ikl(jfl) - 1. + ikinfl (jfl) = ikl(jfl) + zind = zwinfl + zwinfl = zwoutfl + zwoutfl = zind + ELSE + ikoutfl(jfl) = ikl(jfl) + ikinfl (jfl) = ikl(jfl) - 1. + ENDIF + + ! compute the time to go out the mesh across a face + ! u-direction + zudfl (jfl) = zuoutfl - zuinfl + zgidfl(jfl) = float(iioutfl(jfl) - iiinfl(jfl)) + IF( zufl(jfl)*zuoutfl <= 0. ) THEN + ztxfl(jfl) = HUGE(1._wp) + ELSE + IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN + ztxfl(jfl)= zgidfl(jfl)/zudfl(jfl) * LOG(zuoutfl/zufl (jfl)) + ELSE + ztxfl(jfl)=(float(iioutfl(jfl))-zgifl(jfl))/zufl(jfl) + ENDIF + IF( (ABS(zgifl(jfl)-float(iiinfl (jfl))) <= 1.E-7) .OR. & + (ABS(zgifl(jfl)-float(iioutfl(jfl))) <= 1.E-7) ) THEN + ztxfl(jfl)=(zgidfl(jfl))/zufl(jfl) + ENDIF + ENDIF + ! v-direction + zvdfl (jfl) = zvoutfl - zvinfl + zgjdfl(jfl) = float(ijoutfl(jfl)-ijinfl(jfl)) + IF( zvfl(jfl)*zvoutfl <= 0. ) THEN + ztyfl(jfl) = HUGE(1._wp) + ELSE + IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN + ztyfl(jfl) = zgjdfl(jfl)/zvdfl(jfl) * LOG(zvoutfl/zvfl (jfl)) + ELSE + ztyfl(jfl) = (float(ijoutfl(jfl)) - zgjfl(jfl))/zvfl(jfl) + ENDIF + IF( (ABS(zgjfl(jfl)-float(ijinfl (jfl))) <= 1.E-7) .OR. & + (ABS(zgjfl(jfl)-float(ijoutfl(jfl))) <= 1.E-7) ) THEN + ztyfl(jfl) = (zgjdfl(jfl)) / zvfl(jfl) + ENDIF + ENDIF + ! w-direction + IF( nisobfl(jfl) == 1. ) THEN + zwdfl (jfl) = zwoutfl - zwinfl + zgkdfl(jfl) = float(ikoutfl(jfl) - ikinfl(jfl)) + IF( zwfl(jfl)*zwoutfl <= 0. ) THEN + ztzfl(jfl) = HUGE(1._wp) + ELSE + IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN + ztzfl(jfl) = zgkdfl(jfl)/zwdfl(jfl) * LOG(zwoutfl/zwfl (jfl)) + ELSE + ztzfl(jfl) = (float(ikoutfl(jfl)) - zgkfl(jfl))/zwfl(jfl) + ENDIF + IF( (ABS(zgkfl(jfl)-float(ikinfl (jfl))) <= 1.E-7) .OR. & + (ABS(zgkfl(jfl)-float(ikoutfl(jfl))) <= 1.E-7) ) THEN + ztzfl(jfl) = (zgkdfl(jfl)) / zwfl(jfl) + ENDIF + ENDIF + ENDIF + + ! the time to go leave the mesh is the smallest time + + IF( nisobfl(jfl) == 1. ) THEN + zttfl(jfl) = MIN(ztxfl(jfl),ztyfl(jfl),ztzfl(jfl)) + ELSE + zttfl(jfl) = MIN(ztxfl(jfl),ztyfl(jfl)) + ENDIF + ! new age of the FLOAT + zagenewfl(jfl) = zagefl(jfl) + zttfl(jfl)*zvol + ! test to know if the "age" of the float is not bigger than the + ! time step + IF( zagenewfl(jfl) > rn_Dt ) THEN + zttfl(jfl) = (rn_Dt-zagefl(jfl)) / zvol + zagenewfl(jfl) = rn_Dt + ENDIF + + ! In the "minimal" direction we compute the index of new mesh + ! on i-direction + IF( ztxfl(jfl) <= zttfl(jfl) ) THEN + zgifl(jfl) = float(iioutfl(jfl)) + ind = iioutfl(jfl) + IF( iioutfl(jfl) >= iiinfl(jfl) ) THEN + iioutfl(jfl) = iioutfl(jfl) + 1 + ELSE + iioutfl(jfl) = iioutfl(jfl) - 1 + ENDIF + iiinfl(jfl) = ind + ELSE + IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN + zgifl(jfl) = zgifl(jfl) + zgidfl(jfl)*zufl(jfl) & + & * ( EXP( zudfl(jfl)/zgidfl(jfl)*zttfl(jfl) ) - 1. ) / zudfl(jfl) + ELSE + zgifl(jfl) = zgifl(jfl) + zufl(jfl) * zttfl(jfl) + ENDIF + ENDIF + ! on j-direction + IF( ztyfl(jfl) <= zttfl(jfl) ) THEN + zgjfl(jfl) = float(ijoutfl(jfl)) + ind = ijoutfl(jfl) + IF( ijoutfl(jfl) >= ijinfl(jfl) ) THEN + ijoutfl(jfl) = ijoutfl(jfl) + 1 + ELSE + ijoutfl(jfl) = ijoutfl(jfl) - 1 + ENDIF + ijinfl(jfl) = ind + ELSE + IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN + zgjfl(jfl) = zgjfl(jfl)+zgjdfl(jfl)*zvfl(jfl) & + & * ( EXP(zvdfl(jfl)/zgjdfl(jfl)*zttfl(jfl)) - 1. ) / zvdfl(jfl) + ELSE + zgjfl(jfl) = zgjfl(jfl)+zvfl(jfl)*zttfl(jfl) + ENDIF + ENDIF + ! on k-direction + IF( nisobfl(jfl) == 1. ) THEN + IF( ztzfl(jfl) <= zttfl(jfl) ) THEN + zgkfl(jfl) = float(ikoutfl(jfl)) + ind = ikoutfl(jfl) + IF( ikoutfl(jfl) >= ikinfl(jfl) ) THEN + ikoutfl(jfl) = ikoutfl(jfl)+1 + ELSE + ikoutfl(jfl) = ikoutfl(jfl)-1 + ENDIF + ikinfl(jfl) = ind + ELSE + IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN + zgkfl(jfl) = zgkfl(jfl)+zgkdfl(jfl)*zwfl(jfl) & + & * ( EXP(zwdfl(jfl)/zgkdfl(jfl)*zttfl(jfl)) - 1. ) / zwdfl(jfl) + ELSE + zgkfl(jfl) = zgkfl(jfl)+zwfl(jfl)*zttfl(jfl) + ENDIF + ENDIF + ENDIF + + ! coordinate of the new point on the temperature grid + + iil(jfl) = MAX(iiinfl(jfl),iioutfl(jfl)) + ijl(jfl) = MAX(ijinfl(jfl),ijoutfl(jfl)) + IF( nisobfl(jfl) == 1 ) ikl(jfl) = MAX(ikinfl(jfl),ikoutfl(jfl)) +!!Alexcadm write(*,*)'PE ',narea, +!!Alexcadm . iiinfl(jfl),iioutfl(jfl),ijinfl(jfl) +!!Alexcadm . ,ijoutfl(jfl),ikinfl(jfl), +!!Alexcadm . ikoutfl(jfl),ztxfl(jfl),ztyfl(jfl) +!!Alexcadm . ,ztzfl(jfl),zgifl(jfl), +!!Alexcadm . zgjfl(jfl) +!!Alexcadm IF (jfl == 910) write(*,*)'Flotteur 910', +!!Alexcadm . iiinfl(jfl),iioutfl(jfl),ijinfl(jfl) +!!Alexcadm . ,ijoutfl(jfl),ikinfl(jfl), +!!Alexcadm . ikoutfl(jfl),ztxfl(jfl),ztyfl(jfl) +!!Alexcadm . ,ztzfl(jfl),zgifl(jfl), +!!Alexcadm . zgjfl(jfl) + ! reinitialisation of the age of FLOAT + zagefl(jfl) = zagenewfl(jfl) + ELSE + ! we put zgifl, zgjfl, zgkfl, zagefl + zgifl (jfl) = 0. + zgjfl (jfl) = 0. + zgkfl (jfl) = 0. + zagefl(jfl) = 0. + iil(jfl) = 0 + ijl(jfl) = 0 + ENDIF + END DO + + ! synchronisation + CALL mpp_sum( 'floblk', zgifl , jpnfl ) ! sums over the global domain + CALL mpp_sum( 'floblk', zgjfl , jpnfl ) + CALL mpp_sum( 'floblk', zgkfl , jpnfl ) + CALL mpp_sum( 'floblk', zagefl, jpnfl ) + CALL mpp_sum( 'floblk', iil , jpnfl ) + CALL mpp_sum( 'floblk', ijl , jpnfl ) + + ! Test to know if a float hasn't integrated enought time + IF( ln_argo ) THEN + ifin = 1 + DO jfl = 1, jpnfl + IF( zagefl(jfl) < rn_Dt ) ifin = 0 + tpifl(jfl) = zgifl(jfl) + 0.5 + tpjfl(jfl) = zgjfl(jfl) + 0.5 + END DO + ELSE + ifin = 1 + DO jfl = 1, jpnfl + IF( zagefl(jfl) < rn_Dt ) ifin = 0 + tpifl(jfl) = zgifl(jfl) + 0.5 + tpjfl(jfl) = zgjfl(jfl) + 0.5 + IF( nisobfl(jfl) == 1 ) tpkfl(jfl) = -(zgkfl(jfl)) + END DO + ENDIF +!!Alexcadm IF (lwp) write(numout,*) '---------' +!!Alexcadm IF (lwp) write(numout,*) 'before Erika:',tpifl(880),tpjfl(880), +!!Alexcadm . tpkfl(880),zufl(880),zvfl(880),zwfl(880) +!!Alexcadm IF (lwp) write(numout,*) 'first Erika:',tpifl(900),tpjfl(900), +!!Alexcadm . tpkfl(900),zufl(900),zvfl(900),zwfl(900) +!!Alexcadm IF (lwp) write(numout,*) 'last Erika:',tpifl(jpnfl),tpjfl(jpnfl), +!!Alexcadm . tpkfl(jpnfl),zufl(jpnfl),zvfl(jpnfl),zwfl(jpnfl) + IF( ifin == 0 ) THEN + iloop = iloop + 1 + GO TO 222 + ENDIF + ! + ! + END SUBROUTINE flo_blk + + !!====================================================================== +END MODULE floblk diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flodom.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flodom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..86a5c478860de9e55ea6cfa77e265567d902a6a7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flodom.f90 @@ -0,0 +1,487 @@ + + + + + + + + + + + + + +MODULE flodom + !!====================================================================== + !! *** MODULE flodom *** + !! Ocean floats : domain + !!====================================================================== + !! History : OPA ! 1998-07 (Y.Drillet, CLIPPER) Original code + !! NEMO 3.3 ! 2011-09 (C.Bricaud,S.Law-Chune Mercator-Ocean): add ARIANE convention + comsecitc changes + !!---------------------------------------------------------------------- + !! flo_dom : initialization of floats + !! add_new_floats : add new floats (long/lat/depth) + !! add_new_ariane_floats : add new floats with araine convention (i/j/k) + !! findmesh : compute index of position + !! dstnce : compute distance between face mesh and floats + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE flo_oce ! ocean drifting floats + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_dom ! routine called by floats.F90 + PUBLIC flo_dom_alloc ! Routine called in floats.F90 + + CHARACTER (len=21) :: clname1 = 'init_float' ! floats initialisation filename + CHARACTER (len=21) :: clname2 = 'init_float_ariane' ! ariane floats initialisation filename + + + INTEGER , ALLOCATABLE, DIMENSION(:) :: iimfl, ijmfl, ikmfl ! index mesh of floats + INTEGER , ALLOCATABLE, DIMENSION(:) :: idomfl, ivtest, ihtest ! - + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zgifl, zgjfl, zgkfl ! distances in indexes + + !! * Substitutions +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: flodom.F90 15235 2021-09-08 14:07:36Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_dom( Kmm ) + !! --------------------------------------------------------------------- + !! *** ROUTINE flo_dom *** + !! + !! ** Purpose : Initialisation of floats + !! + !! ** Method : We put the floats in the domain with the latitude, + !! the longitude (degree) and the depth (m). + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: jfl ! dummy loop + INTEGER :: inum ! logical unit for file read + !!--------------------------------------------------------------------- + + ! Initialisation with the geographical position or restart + + IF(lwp) WRITE(numout,*) 'flo_dom : compute initial position of floats' + IF(lwp) WRITE(numout,*) '~~~~~~~~' + IF(lwp) WRITE(numout,*) ' jpnfl = ',jpnfl + + !-------------------------! + ! FLOAT RESTART FILE READ ! + !-------------------------! + IF( ln_rstflo )THEN + + IF(lwp) WRITE(numout,*) ' float restart file read' + + ! open the restart file + !---------------------- + CALL ctl_opn( inum, 'restart_float', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + + ! read of the restart file + READ(inum,*) ( tpifl (jfl), jfl=1, jpnrstflo), & + ( tpjfl (jfl), jfl=1, jpnrstflo), & + ( tpkfl (jfl), jfl=1, jpnrstflo), & + ( nisobfl(jfl), jfl=1, jpnrstflo), & + ( ngrpfl (jfl), jfl=1, jpnrstflo) + CLOSE(inum) + + ! if we want a surface drift ( like PROVOR floats ) + IF( ln_argo ) nisobfl(1:jpnrstflo) = 0 + + ! It is possible to add new floats. + !--------------------------------- + IF( jpnfl > jpnrstflo )THEN + + IF(lwp) WRITE(numout,*) ' add new floats' + + IF( ln_ariane )THEN !Add new floats with ariane convention + CALL flo_add_new_ariane_floats(jpnrstflo+1,jpnfl) + ELSE !Add new floats with long/lat convention + CALL flo_add_new_floats(Kmm,jpnrstflo+1,jpnfl) + ENDIF + ENDIF + + !--------------------------------------! + ! FLOAT INITILISATION: NO RESTART FILE ! + !--------------------------------------! + ELSE !ln_rstflo + + IF( ln_ariane )THEN !Add new floats with ariane convention + CALL flo_add_new_ariane_floats(1,jpnfl) + ELSE !Add new floats with long/lat convention + CALL flo_add_new_floats(Kmm,1,jpnfl) + ENDIF + + ENDIF + + END SUBROUTINE flo_dom + + SUBROUTINE flo_add_new_floats(Kmm, kfl_start, kfl_end) + !! ------------------------------------------------------------- + !! *** SUBROUTINE add_new_arianefloats *** + !! + !! ** Purpose : + !! + !! First initialisation of floats + !! the initials positions of floats are written in a file + !! with a variable to know if it is a isobar float a number + !! to identified who want the trajectories of this float and + !! an index for the number of the float + !! open the init file + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm + INTEGER, INTENT(in) :: kfl_start, kfl_end + !! + INTEGER :: inum ! file unit + INTEGER :: jfl,ji, jj, jk ! dummy loop indices + INTEGER :: itrash ! trash var for reading + INTEGER :: ifl ! number of floats to read + REAL(wp) :: zdxab, zdyad + LOGICAL :: llinmesh + CHARACTER(len=80) :: cltmp + !!--------------------------------------------------------------------- + ifl = kfl_end-kfl_start+1 + + ! we get the init values + !----------------------- + CALL ctl_opn( inum , clname1, 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + DO jfl = kfl_start,kfl_end + READ(inum,*) flxx(jfl),flyy(jfl),flzz(jfl), nisobfl(jfl),ngrpfl(jfl),itrash + if(lwp)write(numout,*)'read:',jfl,flxx(jfl),flyy(jfl),flzz(jfl), nisobfl(jfl),ngrpfl(jfl),itrash ; call flush(numout) + END DO + CLOSE(inum) + + ! Test to find the grid point coordonate with the geographical position + !---------------------------------------------------------------------- + DO jfl = kfl_start,kfl_end + ihtest(jfl) = 0 + ivtest(jfl) = 0 + ikmfl(jfl) = 0 + DO ji = MAX(Nis0,2), Nie0 + DO jj = MAX(Njs0,2), Nje0 ! NO vector opt. + ! For each float we find the indexes of the mesh + CALL flo_findmesh(glamf(ji-1,jj-1),gphif(ji-1,jj-1), & + glamf(ji-1,jj ),gphif(ji-1,jj ), & + glamf(ji ,jj ),gphif(ji ,jj ), & + glamf(ji ,jj-1),gphif(ji ,jj-1), & + flxx(jfl) ,flyy(jfl) , & + glamt(ji ,jj ),gphit(ji ,jj ), llinmesh) + IF( llinmesh )THEN + iimfl(jfl) = ji + ijmfl(jfl) = jj + ihtest(jfl) = ihtest(jfl)+1 + DO jk = 1, jpk-1 + IF( ((gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) <= flzz(jfl)) .AND. ((gdepw_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) > flzz(jfl)) ) THEN + ikmfl(jfl) = jk + ivtest(jfl) = ivtest(jfl) + 1 + ENDIF + END DO + ENDIF + END DO + END DO + + ! If the float is in a mesh computed by an other processor we put iimfl=ijmfl=-1 + IF( ihtest(jfl) == 0 ) THEN + iimfl(jfl) = -1 + ijmfl(jfl) = -1 + ENDIF + END DO + + !Test if each float is in one and only one proc + !---------------------------------------------- + IF( lk_mpp ) THEN + CALL mpp_sum('flodom', ihtest,jpnfl) + CALL mpp_sum('flodom', ivtest,jpnfl) + ENDIF + DO jfl = kfl_start,kfl_end + + IF( (ihtest(jfl) > 1 ) .OR. ( ivtest(jfl) > 1) ) THEN + WRITE(cltmp,'(A10,i4.4,A20)' )'THE FLOAT',jfl,' IS NOT IN ONLY ONE MESH' + CALL ctl_stop('STOP',TRIM(cltmp) ) + ENDIF + IF( (ihtest(jfl) == 0) ) THEN + WRITE(cltmp,'(A10,i4.4,A20)' )'THE FLOAT',jfl,' IS IN NO MESH' + CALL ctl_stop('STOP',TRIM(cltmp) ) + ENDIF + END DO + + ! We compute the distance between the float and the face of the mesh + !------------------------------------------------------------------- + DO jfl = kfl_start,kfl_end + + ! Made only if the float is in the domain of the processor + IF( (iimfl(jfl) >= 0) .AND. (ijmfl(jfl) >= 0) ) THEN + + ! TEST TO KNOW IF THE FLOAT IS NOT INITIALISED IN THE COAST + idomfl(jfl) = 0 + IF( tmask(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)) == 0. ) idomfl(jfl) = 1 + + ! Computation of the distance between the float and the faces of the mesh + ! zdxab + ! . + ! B----.---------C + ! | . | + ! |<------>flo | + ! | ^ | + ! | |.....|....zdyad + ! | | | + ! A--------|-----D + ! + zdxab = flo_dstnce( flxx(jfl), flyy(jfl), glamf(iimfl(jfl)-1,ijmfl(jfl)-1), flyy(jfl) ) + zdyad = flo_dstnce( flxx(jfl), flyy(jfl), flxx(jfl), gphif(iimfl(jfl)-1,ijmfl(jfl)-1) ) + + ! Translation of this distances (in meter) in indexes + zgifl(jfl)= (iimfl(jfl)-0.5) + zdxab/e1u(iimfl(jfl)-1,ijmfl(jfl)) + (mig(1)-1) + zgjfl(jfl)= (ijmfl(jfl)-0.5) + zdyad/e2v(iimfl(jfl),ijmfl(jfl)-1) + (mjg(1)-1) + zgkfl(jfl) = (( (gdepw_0(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1)*(1._wp+r3t(iimfl(jfl),ijmfl(jfl),Kmm))) - flzz(jfl) )* ikmfl(jfl)) & + & / ( (gdepw_0(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1)*(1._wp+r3t(iimfl(jfl),ijmfl(jfl),Kmm))) & + & - (gdepw_0(iimfl(jfl),ijmfl(jfl),ikmfl(jfl) )*(1._wp+r3t(iimfl(jfl),ijmfl(jfl),Kmm))) ) & + & + (( flzz(jfl)-(gdepw_0(iimfl(jfl),ijmfl(jfl),ikmfl(jfl))*(1._wp+r3t(iimfl(jfl),ijmfl(jfl),Kmm))) ) *(ikmfl(jfl)+1)) & + & / ( (gdepw_0(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1)*(1._wp+r3t(iimfl(jfl),ijmfl(jfl),Kmm))) & + & - (gdepw_0(iimfl(jfl),ijmfl(jfl),ikmfl(jfl))*(1._wp+r3t(iimfl(jfl),ijmfl(jfl),Kmm))) ) + ELSE + zgifl(jfl) = 0.e0 + zgjfl(jfl) = 0.e0 + zgkfl(jfl) = 0.e0 + ENDIF + + END DO + + ! The sum of all the arrays zgifl, zgjfl, zgkfl give 3 arrays with the positions of all the floats. + IF( lk_mpp ) THEN + CALL mpp_sum( 'flodom', zgjfl, ifl ) ! sums over the global domain + CALL mpp_sum( 'flodom', zgkfl, ifl ) + ENDIF + + DO jfl = kfl_start,kfl_end + tpifl(jfl) = zgifl(jfl) + tpjfl(jfl) = zgjfl(jfl) + tpkfl(jfl) = zgkfl(jfl) + END DO + + ! WARNING : initial position not in the sea + IF( .NOT. ln_rstflo ) THEN + DO jfl = kfl_start,kfl_end + IF( idomfl(jfl) == 1 ) THEN + IF(lwp) WRITE(numout,*)'*****************************' + IF(lwp) WRITE(numout,*)'!!!!!!! WARNING !!!!!!!!!!' + IF(lwp) WRITE(numout,*)'*****************************' + IF(lwp) WRITE(numout,*)'The float number',jfl,'is out of the sea.' + IF(lwp) WRITE(numout,*)'geographical position',flxx(jfl),flyy(jfl),flzz(jfl) + IF(lwp) WRITE(numout,*)'index position',tpifl(jfl),tpjfl(jfl),tpkfl(jfl) + ENDIF + END DO + ENDIF + + END SUBROUTINE flo_add_new_floats + + SUBROUTINE flo_add_new_ariane_floats(kfl_start, kfl_end) + !! ------------------------------------------------------------- + !! *** SUBROUTINE add_new_arianefloats *** + !! + !! ** Purpose : + !! First initialisation of floats with ariane convention + !! + !! The indexes are read directly from file (warning ariane + !! convention, are refered to + !! U,V,W grids - and not T-) + !! The isobar advection is managed with the sign of tpkfl ( >0 -> 3D + !! advection, <0 -> 2D) + !! Some variables are not read, as - gl : time index; 4th + !! column + !! - transport : transport ; 5th + !! column + !! and paste in the jtrash var + !! At the end, ones need to replace the indexes on T grid + !! RMQ : there is no float groups identification ! + !! + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kfl_start, kfl_end + !! + INTEGER :: inum ! file unit + INTEGER :: ierr, ifl + INTEGER :: jfl, jfl1 ! dummy loop indices + INTEGER :: itrash ! trash var for reading + CHARACTER(len=80) :: cltmp + + !!---------------------------------------------------------------------- + nisobfl(kfl_start:kfl_end) = 1 ! we assume that by default we want 3D advection + + ifl = kfl_end - kfl_start + 1 ! number of floats to read + + ! we check that the number of floats in the init_file are consistant with the namelist + IF( lwp ) THEN + + jfl1=0 + ierr=0 + CALL ctl_opn( inum, clname2, 'OLD', 'FORMATTED', 'SEQUENTIAL', 1, numout, .TRUE., 1 ) + DO WHILE (ierr .EQ. 0) + jfl1=jfl1+1 + READ(inum,*, iostat=ierr) + END DO + CLOSE(inum) + IF( (jfl1-1) .NE. ifl )THEN + WRITE(cltmp,'(A25,A20,A3,i4.4,A10,i4.4)')"the number of floats in ",TRIM(clname2), & + " = ",jfl1," is not equal to jfl= ",ifl + CALL ctl_stop('STOP',TRIM(cltmp) ) + ENDIF + + ENDIF + + ! we get the init values + CALL ctl_opn( inum, clname2, 'OLD', 'FORMATTED', 'SEQUENTIAL', 1, numout, .TRUE., 1 ) + DO jfl = kfl_start, kfl_end + READ(inum,*) tpifl(jfl),tpjfl(jfl),tpkfl(jfl),itrash, itrash + + IF ( tpkfl(jfl) .LT. 0. ) nisobfl(jfl) = 0 !set the 2D advection according to init_float + ngrpfl(jfl)=jfl + END DO + + ! conversion from ariane index to T grid index + tpkfl(kfl_start:kfl_end) = abs(tpkfl)-0.5 ! reversed vertical axis + tpifl(kfl_start:kfl_end) = tpifl+0.5 + tpjfl(kfl_start:kfl_end) = tpjfl+0.5 + + + END SUBROUTINE flo_add_new_ariane_floats + + + SUBROUTINE flo_findmesh( pax, pay, pbx, pby, & + pcx, pcy, pdx, pdy, & + px ,py ,ptx, pty, ldinmesh ) + !! ------------------------------------------------------------- + !! *** ROUTINE findmesh *** + !! + !! ** Purpose : Find the index of mesh for the point spx spy + !! + !! ** Method : + !!---------------------------------------------------------------------- + REAL(wp) :: & + pax, pay, pbx, pby, & ! ??? + pcx, pcy, pdx, pdy, & ! ??? + px, py, & ! longitude and latitude + ptx, pty ! ??? + LOGICAL :: ldinmesh ! ??? + !! + REAL(wp) :: zabt, zbct, zcdt, zdat, zabpt, zbcpt, zcdpt, zdapt + !!--------------------------------------------------------------------- + + ! 4 semi plane defined by the 4 points and including the T point + zabt = fsline(pax,pay,pbx,pby,ptx,pty) + zbct = fsline(pbx,pby,pcx,pcy,ptx,pty) + zcdt = fsline(pcx,pcy,pdx,pdy,ptx,pty) + zdat = fsline(pdx,pdy,pax,pay,ptx,pty) + + ! 4 semi plane defined by the 4 points and including the extrememity + zabpt = fsline(pax,pay,pbx,pby,px,py) + zbcpt = fsline(pbx,pby,pcx,pcy,px,py) + zcdpt = fsline(pcx,pcy,pdx,pdy,px,py) + zdapt = fsline(pdx,pdy,pax,pay,px,py) + + ! We compare the semi plane T with the semi plane including the point + ! to know if it is in this mesh. + ! For numerical reasons it is possible that for a point which is on + ! the line we don't have exactly zero with fsline function. We want + ! that a point can't be in 2 mesh in the same time, so we put the + ! coefficient to zero if it is smaller than 1.E-12 + + IF( ABS(zabpt) <= 1.E-12 ) zabpt = 0. + IF( ABS(zbcpt) <= 1.E-12 ) zbcpt = 0. + IF( ABS(zcdpt) <= 1.E-12 ) zcdpt = 0. + IF( ABS(zdapt) <= 1.E-12 ) zdapt = 0. + IF( (zabt*zabpt > 0.) .AND. (zbct*zbcpt >= 0. ) .AND. ( zcdt*zcdpt >= 0. ) .AND. ( zdat*zdapt > 0. ) & + .AND. ( px <= MAX(pcx,pdx) ) .AND. ( px >= MIN(pax,pbx) ) & + .AND. ( py <= MAX(pby,pcy) ) .AND. ( py >= MIN(pay,pdy) ) ) THEN + ldinmesh=.TRUE. + ELSE + ldinmesh=.FALSE. + ENDIF + ! + END SUBROUTINE flo_findmesh + + FUNCTION fsline( psax, psay, psbx, psby, psx, psy ) + !! --------------------------------------------------------------------- + !! *** Function fsline *** + !! + !! ** Purpose : + !! ** Method : + !!---------------------------------------------------------------------- + REAL(wp) :: fsline + REAL(wp), INTENT(in) :: psax, psay, psbx, psby, psx, psy + !!--------------------------------------------------------------------- + fsline = psy * ( psbx - psax ) & + & - psx * ( psby - psay ) & + & + psax * psby - psay * psbx + ! + END FUNCTION fsline + + FUNCTION flo_dstnce( pla1, phi1, pla2, phi2 ) + !! ------------------------------------------------------------- + !! *** Function dstnce *** + !! + !! ** Purpose : returns distance (in m) between two geographical + !! points + !! ** Method : + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pla1, phi1, pla2, phi2 ! ??? + !! + REAL(wp) :: dly1, dly2, dlx1, dlx2, dlx, dls, dld, dpi + REAL(wp) :: flo_dstnce + !!--------------------------------------------------------------------- + ! + dpi = 2._wp * ASIN(1._wp) + dls = dpi / 180._wp + dly1 = phi1 * dls + dly2 = phi2 * dls + dlx1 = pla1 * dls + dlx2 = pla2 * dls + ! + dlx = SIN(dly1) * SIN(dly2) + COS(dly1) * COS(dly2) * COS(dlx2-dlx1) + ! + IF( ABS(dlx) > 1.0_wp ) dlx = 1.0_wp + ! + dld = ATAN(SQRT( 1._wp * ( 1._wp-dlx )/( 1._wp+dlx ) )) * 222.24_wp / dls + flo_dstnce = dld * 1000._wp + ! + END FUNCTION flo_dstnce + + INTEGER FUNCTION flo_dom_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION flo_dom_alloc *** + !!---------------------------------------------------------------------- + + ALLOCATE( iimfl(jpnfl) , ijmfl(jpnfl) , ikmfl(jpnfl) , & + idomfl(jpnfl), ivtest(jpnfl), ihtest(jpnfl), & + zgifl(jpnfl) , zgjfl(jpnfl) , zgkfl(jpnfl) , STAT=flo_dom_alloc ) + ! + CALL mpp_sum ( 'flodom', flo_dom_alloc ) + IF( flo_dom_alloc /= 0 ) CALL ctl_stop( 'STOP', 'flo_dom_alloc: failed to allocate arrays' ) + END FUNCTION flo_dom_alloc + + !!====================================================================== +END MODULE flodom diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/florst.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/florst.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c7f1aa0ed6f3431e11a53166f5a98f9ac24d7bdd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/florst.f90 @@ -0,0 +1,137 @@ + + + + + + + + + + + + + +MODULE florst + !!====================================================================== + !! *** MODULE florst *** + !! Ocean floats : write floats restart files + !!====================================================================== + !! History : OPA ! 1999-09 (Y. Drillet) : Original code + !! - ! 2000-06 (J.-M. Molines) : Profiling floats for CLS + !! NEMO 1.0 ! 2002-10 (A. Bozec) F90 : Free form and module + !! 3.2 ! 2010-08 (slaw, cbricaud): netcdf outputs and others + !!---------------------------------------------------------------------- + USE flo_oce ! ocean drifting floats + USE dom_oce ! ocean space and time domain + USE lib_mpp ! distribued memory computing library + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_rst ! routine called by floats.F90 + PUBLIC flo_rst_alloc ! routine called by floats.F90 + + INTEGER, ALLOCATABLE, DIMENSION(:) :: iperproc ! 1D workspace + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: florst.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION flo_rst_alloc() + !!------------------------------------------------------------------- + !! *** FUNCTION flo_rst_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( iperproc(jpnij), STAT=flo_rst_alloc ) + ! + CALL mpp_sum ( 'florst', flo_rst_alloc ) + IF( flo_rst_alloc /= 0 ) CALL ctl_stop( 'STOP', 'flo_rst_alloc: failed to allocate arrays.' ) + END FUNCTION flo_rst_alloc + + + SUBROUTINE flo_rst( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE flo_rst *** + !! + !! ** Purpose : + !! + !! + !! ** Method : The frequency of ??? is nwritefl + !! + !!---------------------------------------------------------------------- + INTEGER :: kt ! time step + ! + CHARACTER (len=80) :: clname ! restart filename + INTEGER :: ic , jc , jpn ,jfl ! temporary integer + INTEGER :: inum ! temporary logical unit for restart file + !!---------------------------------------------------------------------- + + IF( ( MOD(kt,nn_stockfl) == 0 ) .OR. ( kt == nitend ) )THEN + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'flo_rst : write in restart_float file ' + WRITE(numout,*) '~~~~~~~ ' + ENDIF + + ! file is opened and closed every time it is used. + + clname = 'restart.float.' + ic = 1 + DO jc = 1, 16 + IF( cexper(jc:jc) /= ' ' ) ic = jc + END DO + clname = clname(1:14)//cexper(1:ic) + ic = 1 + DO jc = 1, 48 + IF( clname(jc:jc) /= ' ' ) ic = jc + END DO + + inum=0 + IF( lwp )THEN + CALL ctl_opn( inum, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + REWIND inum + ENDIF + ! + DO jpn = 1, jpnij + iperproc(jpn) = 0 + END DO + ! + IF(lwp) THEN + REWIND(inum) + WRITE (inum,*) tpifl,tpjfl,tpkfl,nisobfl,ngrpfl + CLOSE (inum) + ENDIF + ! + ! Compute the number of trajectories for each processor + ! + IF( lk_mpp ) THEN + DO jfl = 1, jpnfl + IF( (INT(tpifl(jfl)) >= mig(Nis0)) .AND. & + &(INT(tpifl(jfl)) <= mig(Nie0)) .AND. & + &(INT(tpjfl(jfl)) >= mjg(Njs0)) .AND. & + &(INT(tpjfl(jfl)) <= mjg(Nje0)) ) THEN + iperproc(narea) = iperproc(narea)+1 + ENDIF + END DO + CALL mpp_sum( 'florst', iperproc, jpnij ) + ! + IF(lwp) THEN + WRITE(numout,*) 'DATE',adatrj + DO jpn = 1, jpnij + IF( iperproc(jpn) /= 0 ) THEN + WRITE(numout,*)'PROCESSOR',jpn-1,'compute',iperproc(jpn), 'trajectories.' + ENDIF + END DO + ENDIF + ENDIF + ! + ENDIF + ! + END SUBROUTINE flo_rst + + !!======================================================================= +END MODULE florst diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flowri.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flowri.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4d2c8f7423ccad922b8cf2554d9eb54881c05e19 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/flowri.f90 @@ -0,0 +1,240 @@ + + + + + + + + + + + + + +MODULE flowri + !!====================================================================== + !! *** MODULE flowri *** + !! + !! Ocean floats: write floats trajectory in ascii ln_flo_ascii = T + !! or in netcdf ( IOM or IOSPSL ) ln_flo_ascii = F + !!====================================================================== + !! History : OPA ! 1999-09 (Y. Drillet) : Original code + !! - ! 2000-06 (J.-M. Molines) : Profiling floats for CLS + !! NEMO 1.0 ! 2002-10 (A. Bozec) F90 : Free form and module + !! 3.2 ! 2010-08 (slaw, cbricaud): netcdf outputs and others + !!---------------------------------------------------------------------- + USE flo_oce ! ocean drifting floats + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE lib_mpp ! distribued memory computing library + USE in_out_manager ! I/O manager + USE phycst ! physic constants + USE dianam ! build name of file (routine) + USE ioipsl + USE iom ! I/O library + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_wri ! routine called by floats.F90 + PUBLIC flo_wri_alloc ! routine called by floats.F90 + + INTEGER :: jfl ! number of floats + CHARACTER (len=80) :: clname ! netcdf output filename + + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zlon , zlat, zdep ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:) :: ztem , zsal, zrho ! 2D workspace + + !! * Substitutions +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: flowri.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION flo_wri_alloc() + !!------------------------------------------------------------------- + !! *** FUNCTION flo_wri_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( ztem(jpnfl) , zsal(jpnfl) , zrho(jpnfl) , & + zlon(jpnfl) , zlat(jpnfl) , zdep(jpnfl) , STAT=flo_wri_alloc) + ! + CALL mpp_sum ( 'flowri', flo_wri_alloc ) + IF( flo_wri_alloc /= 0 ) CALL ctl_stop( 'STOP', 'flo_wri_alloc: failed to allocate arrays.' ) + END FUNCTION flo_wri_alloc + + SUBROUTINE flo_wri( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE flo_wri *** + !! + !! ** Purpose : Write position of floats in "trajec_float.nc",according + !! to ARIANE TOOLS (http://stockage.univ-brest.fr/~grima/Ariane/ ) n + !! nomenclature + !! + !! + !! ** Method : The frequency of ??? is nwritefl + !! + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(in) :: kt ! time step + INTEGER, INTENT(in) :: Kmm ! time level index + + !! * Local declarations + INTEGER :: iafl , ibfl , icfl ! temporary integer + INTEGER :: ia1fl, ib1fl, ic1fl ! " + INTEGER :: iafloc,ibfloc,ia1floc,ib1floc ! " + INTEGER :: irec, irecflo + + REAL(wp) :: zafl,zbfl,zcfl ! temporary real + REAL(wp) :: ztime ! " + + INTEGER, DIMENSION(2) :: icount + INTEGER, DIMENSION(2) :: istart + INTEGER, DIMENSION(1) :: ish + INTEGER, DIMENSION(2) :: ish2 + !!---------------------------------------------------------------------- + + !----------------------------------------------------- + ! I- Save positions, temperature, salinty and density + !----------------------------------------------------- + zlon(:)=0.0 ; zlat(:)=0.0 ; zdep(:)=0.0 + ztem(:)=0.0 ; zsal(:)=0.0 ; zrho(:)=0.0 + + DO jfl = 1, jpnfl + + iafl = INT (tpifl(jfl)) ! I-index of the nearest point before + ibfl = INT (tpjfl(jfl)) ! J-index of the nearest point before + icfl = INT (tpkfl(jfl)) ! K-index of the nearest point before + ia1fl = iafl + 1 ! I-index of the nearest point after + ib1fl = ibfl + 1 ! J-index of the nearest point after + ic1fl = icfl + 1 ! K-index of the nearest point after + zafl = tpifl(jfl) - REAL(iafl,wp) ! distance ????? + zbfl = tpjfl(jfl) - REAL(ibfl,wp) ! distance ????? + zcfl = tpkfl(jfl) - REAL(icfl,wp) ! distance ????? + + IF( lk_mpp ) THEN + + iafloc = mi1( iafl ) + ibfloc = mj1( ibfl ) + + IF( Nis0 <= iafloc .AND. iafloc <= Nie0 .AND. & + & Njs0 <= ibfloc .AND. ibfloc <= Nje0 ) THEN + + !the float is inside of current proc's area + ia1floc = iafloc + 1 + ib1floc = ibfloc + 1 + + !save position of the float + zlat(jfl) = (1.-zafl)*(1.-zbfl)*gphit(iafloc ,ibfloc ) + (1.-zafl) * zbfl * gphit(iafloc ,ib1floc) & + + zafl *(1.-zbfl)*gphit(ia1floc,ibfloc ) + zafl * zbfl * gphit(ia1floc,ib1floc) + zlon(jfl) = (1.-zafl)*(1.-zbfl)*glamt(iafloc ,ibfloc ) + (1.-zafl) * zbfl * glamt(iafloc ,ib1floc) & + + zafl *(1.-zbfl)*glamt(ia1floc,ibfloc ) + zafl * zbfl * glamt(ia1floc,ib1floc) + zdep(jfl) = (1.-zcfl)*(gdepw_0(iafloc,ibfloc,icfl )*(1._wp+r3t(iafloc,ibfloc,Kmm))) + zcfl * (gdepw_0(iafloc,ibfloc,ic1fl)*(1._wp+r3t(iafloc,ibfloc,Kmm))) + + !save temperature, salinity and density at this position + ztem(jfl) = ts(iafloc,ibfloc,icfl,jp_tem,Kmm) + zsal (jfl) = ts(iafloc,ibfloc,icfl,jp_sal,Kmm) + zrho (jfl) = (rhd(iafloc,ibfloc,icfl)+1)*rho0 + + ENDIF + + ELSE ! mono proc case + + iafloc = iafl + ibfloc = ibfl + ia1floc = iafloc + 1 + ib1floc = ibfloc + 1 + + !save position of the float + zlat(jfl) = (1.-zafl)*(1.-zbfl)*gphit(iafloc ,ibfloc ) + (1.-zafl) * zbfl * gphit(iafloc ,ib1floc) & + + zafl *(1.-zbfl)*gphit(ia1floc,ibfloc ) + zafl * zbfl * gphit(ia1floc,ib1floc) + zlon(jfl) = (1.-zafl)*(1.-zbfl)*glamt(iafloc ,ibfloc ) + (1.-zafl) * zbfl * glamt(iafloc ,ib1floc) & + + zafl *(1.-zbfl)*glamt(ia1floc,ibfloc ) + zafl * zbfl * glamt(ia1floc,ib1floc) + zdep(jfl) = (1.-zcfl)*(gdepw_0(iafloc,ibfloc,icfl )*(1._wp+r3t(iafloc,ibfloc,Kmm))) + zcfl * (gdepw_0(iafloc,ibfloc,ic1fl)*(1._wp+r3t(iafloc,ibfloc,Kmm))) + + ztem(jfl) = ts(iafloc,ibfloc,icfl,jp_tem,Kmm) + zsal(jfl) = ts(iafloc,ibfloc,icfl,jp_sal,Kmm) + zrho(jfl) = (rhd(iafloc,ibfloc,icfl)+1)*rho0 + + ENDIF + + END DO ! loop on float + + !Only proc 0 writes all positions : SUM of positions on all procs + IF( lk_mpp ) THEN + CALL mpp_sum( 'flowri', zlon, jpnfl ) ! sums over the global domain + CALL mpp_sum( 'flowri', zlat, jpnfl ) ! sums over the global domain + CALL mpp_sum( 'flowri', zdep, jpnfl ) ! sums over the global domain + CALL mpp_sum( 'flowri', ztem, jpnfl ) ! sums over the global domain + CALL mpp_sum( 'flowri', zsal, jpnfl ) ! sums over the global domain + CALL mpp_sum( 'flowri', zrho, jpnfl ) ! sums over the global domain + ENDIF + + + !-------------------------------------! + ! II- WRITE WRITE WRITE WRITE WRITE ! + !-------------------------------------! + + !--------------------------! + ! II-1 Write in ascii file ! + !--------------------------! + + IF( ln_flo_ascii )THEN + + IF( ( kt == nn_it000 .OR. MOD( kt,nn_writefl)== 0 ) .AND. lwp )THEN + + !II-1-a Open ascii file + !---------------------- + IF( kt == nn_it000 ) THEN + CALL ctl_opn( numflo, 'trajec_float', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + irecflo = NINT( (nitend-nn_it000) / FLOAT(nn_writefl) ) + WRITE(numflo,*) cexper, irecflo, jpnfl, nn_writefl + ENDIF + + !II-1-b Write in ascii file + !----------------------------- + WRITE(numflo,*) zlon,zlat,zdep,nisobfl,ngrpfl,ztem,zsal, FLOAT(ndastp) + + + !II-1-c Close netcdf file + !------------------------- + IF( kt == nitend ) CLOSE( numflo ) + + ENDIF + + !----------------------------------------------------- + ! II-2 Write in netcdf file + !----------------------------------------------------- + + ELSE + + !II-2-a Write with IOM + !---------------------- + + CALL iom_put( "traj_lon" , zlon ) + CALL iom_put( "traj_lat" , zlat ) + CALL iom_put( "traj_dep" , zdep ) + CALL iom_put( "traj_temp" , ztem ) + CALL iom_put( "traj_salt" , zsal ) + CALL iom_put( "traj_dens" , zrho ) + CALL iom_put( "traj_group" , REAL(ngrpfl,wp) ) + ENDIF ! netcdf writing + + END SUBROUTINE flo_wri + + !!======================================================================= +END MODULE flowri diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/geo2ocean.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/geo2ocean.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7ef8954fd8e207ff29806a5056e6c3a9b10be4b0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/geo2ocean.f90 @@ -0,0 +1,479 @@ + + + + + + + + + + + + + +MODULE geo2ocean + !!====================================================================== + !! *** MODULE geo2ocean *** + !! Ocean mesh : ??? + !!====================================================================== + !! History : OPA ! 07-1996 (O. Marti) Original code + !! NEMO 1.0 ! 06-2006 (G. Madec ) Free form, F90 + opt. + !! ! 04-2007 (S. Masson) angle: Add T, F points and bugfix in cos lateral boundary + !! 3.0 ! 07-2008 (G. Madec) geo2oce suppress lon/lat agruments + !! 3.7 ! 11-2015 (G. Madec) remove the unused repere and repcmo routines + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! rot_rep : Rotate the Repere: geographic grid <==> stretched coordinates grid + !! angle : + !! geo2oce : + !! oce2geo : + !!---------------------------------------------------------------------- + USE dom_oce ! mesh and scale factors + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC rot_rep ! called in sbccpl, fldread, and cyclone + PUBLIC geo2oce ! called in sbccpl + PUBLIC oce2geo ! called in sbccpl + PUBLIC obs_rot ! called in obs_rot_vel and obs_write + + ! ! cos/sin between model grid lines and NP direction + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsint, gcost ! at T point + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinu, gcosu ! at U point + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinv, gcosv ! at V point + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinf, gcosf ! at F point + + LOGICAL , SAVE, DIMENSION(4) :: linit = .FALSE. + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gsinlon, gcoslon, gsinlat, gcoslat + + LOGICAL :: lmust_init = .TRUE. !: used to initialize the cos/sin variables (see above) + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: geo2ocean.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE rot_rep ( pxin, pyin, cd_type, cdtodo, prot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rot_rep *** + !! + !! ** Purpose : Rotate the Repere: Change vector componantes between + !! geographic grid <--> stretched coordinates grid. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxin, pyin ! vector componantes + CHARACTER(len=1), INTENT(in ) :: cd_type ! define the nature of pt2d array grid-points + CHARACTER(len=5), INTENT(in ) :: cdtodo ! type of transpormation: + ! ! 'en->i' = east-north to i-component + ! ! 'en->j' = east-north to j-component + ! ! 'ij->e' = (i,j) components to east + ! ! 'ij->n' = (i,j) components to north + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: prot + !!---------------------------------------------------------------------- + ! + IF( lmust_init ) THEN ! at 1st call only: set gsin. & gcos. + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' rot_rep: coordinate transformation : geographic <==> model (i,j)-components' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~ ' + ! + CALL angle( glamt, gphit, glamu, gphiu, glamv, gphiv, glamf, gphif ) ! initialization of the transformation + lmust_init = .FALSE. + ENDIF + ! + SELECT CASE( cdtodo ) ! type of rotation + ! + CASE( 'en->i' ) ! east-north to i-component + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) + pyin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pxin(:,:) * gcosu(:,:) + pyin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pxin(:,:) * gcosv(:,:) + pyin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pxin(:,:) * gcosf(:,:) + pyin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE ('en->j') ! east-north to j-component + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) - pxin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pyin(:,:) * gcosu(:,:) - pxin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pyin(:,:) * gcosv(:,:) - pxin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pyin(:,:) * gcosf(:,:) - pxin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE ('ij->e') ! (i,j)-components to east + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) - pyin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pxin(:,:) * gcosu(:,:) - pyin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pxin(:,:) * gcosv(:,:) - pyin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pxin(:,:) * gcosf(:,:) - pyin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE ('ij->n') ! (i,j)-components to north + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) + pxin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pyin(:,:) * gcosu(:,:) + pxin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pyin(:,:) * gcosv(:,:) + pxin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pyin(:,:) * gcosf(:,:) + pxin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE DEFAULT ; CALL ctl_stop( 'rot_rep: Syntax Error in the definition of cdtodo' ) + ! + END SELECT + ! + END SUBROUTINE rot_rep + + + SUBROUTINE angle( plamt, pphit, plamu, pphiu, plamv, pphiv, plamf, pphif ) + !!---------------------------------------------------------------------- + !! *** ROUTINE angle *** + !! + !! ** Purpose : Compute angles between model grid lines and the North direction + !! + !! ** Method : sinus and cosinus of the angle between the north-south axe + !! and the j-direction at t, u, v and f-points + !! dot and cross products are used to obtain cos and sin, resp. + !! + !! ** Action : - gsint, gcost, gsinu, gcosu, gsinv, gcosv, gsinf, gcosf + !!---------------------------------------------------------------------- + ! WARNING: for an unexplained reason, we need to pass all glam, gphi arrays as input parameters in + ! order to get AGRIF working with -03 compilation option + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: plamt, pphit, plamu, pphiu, plamv, pphiv, plamf, pphif + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zlam, zphi ! local scalars + REAL(wp) :: zlan, zphh ! - - + REAL(wp) :: zxnpt, zynpt, znnpt ! x,y components and norm of the vector: T point to North Pole + REAL(wp) :: zxnpu, zynpu, znnpu ! x,y components and norm of the vector: U point to North Pole + REAL(wp) :: zxnpv, zynpv, znnpv ! x,y components and norm of the vector: V point to North Pole + REAL(wp) :: zxnpf, zynpf, znnpf ! x,y components and norm of the vector: F point to North Pole + REAL(wp) :: zxvvt, zyvvt, znvvt ! x,y components and norm of the vector: between V points below and above a T point + REAL(wp) :: zxffu, zyffu, znffu ! x,y components and norm of the vector: between F points below and above a U point + REAL(wp) :: zxffv, zyffv, znffv ! x,y components and norm of the vector: between F points left and right a V point + REAL(wp) :: zxuuf, zyuuf, znuuf ! x,y components and norm of the vector: between U points below and above a F point + !!---------------------------------------------------------------------- + ! + ALLOCATE( gsint(jpi,jpj), gcost(jpi,jpj), & + & gsinu(jpi,jpj), gcosu(jpi,jpj), & + & gsinv(jpi,jpj), gcosv(jpi,jpj), & + & gsinf(jpi,jpj), gcosf(jpi,jpj), STAT=ierr ) + CALL mpp_sum( 'geo2ocean', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'angle: unable to allocate arrays' ) + ! + ! ============================= ! + ! Compute the cosinus and sinus ! + ! ============================= ! + ! (computation done on the north stereographic polar plane) + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 1) + ! + zlam = plamt(ji,jj) ! north pole direction & modulous (at t-point) + zphi = pphit(ji,jj) + zxnpt = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + zynpt = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + znnpt = zxnpt*zxnpt + zynpt*zynpt + ! + zlam = plamu(ji,jj) ! north pole direction & modulous (at u-point) + zphi = pphiu(ji,jj) + zxnpu = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + zynpu = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + znnpu = zxnpu*zxnpu + zynpu*zynpu + ! + zlam = plamv(ji,jj) ! north pole direction & modulous (at v-point) + zphi = pphiv(ji,jj) + zxnpv = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + zynpv = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + znnpv = zxnpv*zxnpv + zynpv*zynpv + ! + zlam = plamf(ji,jj) ! north pole direction & modulous (at f-point) + zphi = pphif(ji,jj) + zxnpf = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + zynpf = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + znnpf = zxnpf*zxnpf + zynpf*zynpf + ! + zlam = plamv(ji,jj ) ! j-direction: v-point segment direction (around t-point) + zphi = pphiv(ji,jj ) + zlan = plamv(ji,jj-1) + zphh = pphiv(ji,jj-1) + zxvvt = 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + zyvvt = 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + znvvt = SQRT( znnpt * ( zxvvt*zxvvt + zyvvt*zyvvt ) ) + znvvt = MAX( znvvt, 1.e-14 ) + ! + zlam = plamf(ji,jj ) ! j-direction: f-point segment direction (around u-point) + zphi = pphif(ji,jj ) + zlan = plamf(ji,jj-1) + zphh = pphif(ji,jj-1) + zxffu = 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + zyffu = 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + znffu = SQRT( znnpu * ( zxffu*zxffu + zyffu*zyffu ) ) + znffu = MAX( znffu, 1.e-14 ) + ! + zlam = plamf(ji ,jj) ! i-direction: f-point segment direction (around v-point) + zphi = pphif(ji ,jj) + zlan = plamf(ji-1,jj) + zphh = pphif(ji-1,jj) + zxffv = 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + zyffv = 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + znffv = SQRT( znnpv * ( zxffv*zxffv + zyffv*zyffv ) ) + znffv = MAX( znffv, 1.e-14 ) + ! + zlam = plamu(ji,jj+1) ! j-direction: u-point segment direction (around f-point) + zphi = pphiu(ji,jj+1) + zlan = plamu(ji,jj ) + zphh = pphiu(ji,jj ) + zxuuf = 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + zyuuf = 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + znuuf = SQRT( znnpf * ( zxuuf*zxuuf + zyuuf*zyuuf ) ) + znuuf = MAX( znuuf, 1.e-14 ) + ! + ! ! cosinus and sinus using dot and cross products + gsint(ji,jj) = ( zxnpt*zyvvt - zynpt*zxvvt ) / znvvt + gcost(ji,jj) = ( zxnpt*zxvvt + zynpt*zyvvt ) / znvvt + ! + gsinu(ji,jj) = ( zxnpu*zyffu - zynpu*zxffu ) / znffu + gcosu(ji,jj) = ( zxnpu*zxffu + zynpu*zyffu ) / znffu + ! + gsinf(ji,jj) = ( zxnpf*zyuuf - zynpf*zxuuf ) / znuuf + gcosf(ji,jj) = ( zxnpf*zxuuf + zynpf*zyuuf ) / znuuf + ! + gsinv(ji,jj) = ( zxnpv*zxffv + zynpv*zyffv ) / znffv + gcosv(ji,jj) =-( zxnpv*zyffv - zynpv*zxffv ) / znffv ! (caution, rotation of 90 degres) + ! + END DO ; END DO + + ! =============== ! + ! Geographic mesh ! + ! =============== ! + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 1) + IF( MOD( ABS( plamv(ji,jj) - plamv(ji,jj-1) ), 360. ) < 1.e-8 ) THEN + gsint(ji,jj) = 0. + gcost(ji,jj) = 1. + ENDIF + IF( MOD( ABS( plamf(ji,jj) - plamf(ji,jj-1) ), 360. ) < 1.e-8 ) THEN + gsinu(ji,jj) = 0. + gcosu(ji,jj) = 1. + ENDIF + IF( ABS( pphif(ji,jj) - pphif(ji-1,jj) ) < 1.e-8 ) THEN + gsinv(ji,jj) = 0. + gcosv(ji,jj) = 1. + ENDIF + IF( MOD( ABS( plamu(ji,jj) - plamu(ji,jj+1) ), 360. ) < 1.e-8 ) THEN + gsinf(ji,jj) = 0. + gcosf(ji,jj) = 1. + ENDIF + END DO ; END DO + + ! =========================== ! + ! Lateral boundary conditions ! + ! =========================== ! + ! ! lateral boundary cond.: T-, U-, V-, F-pts, sgn + CALL lbc_lnk( 'geo2ocean', gcost, 'T', -1.0_wp, gsint, 'T', -1.0_wp, gcosu, 'U', -1.0_wp, gsinu, 'U', -1.0_wp, & + & gcosv, 'V', -1.0_wp, gsinv, 'V', -1.0_wp, gcosf, 'F', -1.0_wp, gsinf, 'F', -1.0_wp ) + ! + END SUBROUTINE angle + + + SUBROUTINE geo2oce ( pxx, pyy, pzz, cgrid, pte, ptn ) + !!---------------------------------------------------------------------- + !! *** ROUTINE geo2oce *** + !! + !! ** Purpose : + !! + !! ** Method : Change a vector from geocentric to east/north + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxx, pyy, pzz + CHARACTER(len=1) , INTENT(in ) :: cgrid + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pte, ptn + ! + REAL(wp), PARAMETER :: rpi = 3.141592653e0 + REAL(wp), PARAMETER :: rad = rpi / 180.e0 + INTEGER :: ig ! + INTEGER :: ierr ! local integer + !!---------------------------------------------------------------------- + ! + IF( .NOT. ALLOCATED( gsinlon ) ) THEN + ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) , & + & gsinlat(jpi,jpj,4) , gcoslat(jpi,jpj,4) , STAT=ierr ) + CALL mpp_sum( 'geo2ocean', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('geo2oce: unable to allocate arrays' ) + ENDIF + ! + SELECT CASE( cgrid) + CASE ( 'T' ) + ig = 1 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamt(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamt(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphit(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphit(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'U' ) + ig = 2 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamu(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamu(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiu(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiu(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'V' ) + ig = 3 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamv(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamv(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiv(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiv(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'F' ) + ig = 4 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamf(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamf(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphif(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphif(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE default + WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid + CALL ctl_stop( ctmp1 ) + END SELECT + ! + pte = - gsinlon(:,:,ig) * pxx + gcoslon(:,:,ig) * pyy + ptn = - gcoslon(:,:,ig) * gsinlat(:,:,ig) * pxx & + & - gsinlon(:,:,ig) * gsinlat(:,:,ig) * pyy & + & + gcoslat(:,:,ig) * pzz + ! + END SUBROUTINE geo2oce + + + SUBROUTINE oce2geo ( pte, ptn, cgrid, pxx , pyy , pzz ) + !!---------------------------------------------------------------------- + !! *** ROUTINE oce2geo *** + !! + !! ** Purpose : + !! + !! ** Method : Change vector from east/north to geocentric + !! + !! History : ! (A. Caubel) oce2geo - Original code + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( IN ) :: pte, ptn + CHARACTER(len=1) , INTENT( IN ) :: cgrid + REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT ) :: pxx , pyy , pzz + !! + REAL(wp), PARAMETER :: rpi = 3.141592653E0 + REAL(wp), PARAMETER :: rad = rpi / 180.e0 + INTEGER :: ig ! + INTEGER :: ierr ! local integer + !!---------------------------------------------------------------------- + + IF( .NOT. ALLOCATED( gsinlon ) ) THEN + ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) , & + & gsinlat(jpi,jpj,4) , gcoslat(jpi,jpj,4) , STAT=ierr ) + CALL mpp_sum( 'geo2ocean', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('oce2geo: unable to allocate arrays' ) + ENDIF + + SELECT CASE( cgrid) + CASE ( 'T' ) + ig = 1 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamt(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamt(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphit(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphit(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'U' ) + ig = 2 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamu(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamu(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiu(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiu(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'V' ) + ig = 3 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamv(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamv(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiv(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiv(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'F' ) + ig = 4 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamf(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamf(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphif(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphif(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE default + WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid + CALL ctl_stop( ctmp1 ) + END SELECT + ! + pxx = - gsinlon(:,:,ig) * pte - gcoslon(:,:,ig) * gsinlat(:,:,ig) * ptn + pyy = gcoslon(:,:,ig) * pte - gsinlon(:,:,ig) * gsinlat(:,:,ig) * ptn + pzz = gcoslat(:,:,ig) * ptn + ! + END SUBROUTINE oce2geo + + + SUBROUTINE obs_rot( psinu, pcosu, psinv, pcosv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_rot *** + !! + !! ** Purpose : Copy gsinu, gcosu, gsinv and gsinv + !! to input data for rotations of + !! current at observation points + !! + !! History : 9.2 ! 09-02 (K. Mogensen) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT ):: psinu, pcosu, psinv, pcosv ! copy of data + !!---------------------------------------------------------------------- + ! + ! Initialization of gsin* and gcos* at first call + ! ----------------------------------------------- + IF( lmust_init ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' obs_rot : geographic <--> stretched' + IF(lwp) WRITE(numout,*) ' ~~~~~~~ coordinate transformation' + CALL angle( glamt, gphit, glamu, gphiu, glamv, gphiv, glamf, gphif ) ! initialization of the transformation + lmust_init = .FALSE. + ENDIF + ! + psinu(:,:) = gsinu(:,:) + pcosu(:,:) = gcosu(:,:) + psinv(:,:) = gsinv(:,:) + pcosv(:,:) = gcosv(:,:) + ! + END SUBROUTINE obs_rot + + !!====================================================================== +END MODULE geo2ocean diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/halo_mng.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/halo_mng.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3a25af4a9875e53470b3fcac74e232c449b885fb --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/halo_mng.f90 @@ -0,0 +1,207 @@ + + + + + + + + + + + + + +MODULE halo_mng + !!====================================================================== + !! *** MODULE halo_mng *** + !! Ocean numerics: massively parallel processing library + !!===================================================================== + !! History : OPA ! 1994 (M. Guyon, J. Escobar, M. Imbard) + !Original code + !! 4.0 ! 2019 (CMCC - ASC) initial version of halo management module + !in_out_manager + !!---------------------------------------------------------------------- + + USE dom_oce ! ocean space and time domain + USE lbclnk ! ocean lateral boundary condition (or mpp link) + + IMPLICIT NONE + PRIVATE + + INTERFACE halo_mng_resize + MODULE PROCEDURE halo_mng_resize_2D, halo_mng_resize_3D, halo_mng_resize_4D, halo_mng_resize_5D + END INTERFACE + + PUBLIC halo_mng_resize + PUBLIC halo_mng_init + PUBLIC halo_mng_set + + INTEGER :: jpi_1, jpj_1 + INTEGER :: jpimax_1, jpjmax_1 + INTEGER :: Nis0_1, Njs0_1 + INTEGER :: Nie0_1, Nje0_1 +CONTAINS + + SUBROUTINE halo_mng_init( ) + + jpi_1 = jpi + jpj_1 = jpj + + Nis0_1 = Nis0 + Njs0_1 = Njs0 + + Nie0_1 = Nie0 + Nje0_1 = Nje0 + + jpimax_1 = jpimax + jpjmax_1 = jpjmax + + END SUBROUTINE halo_mng_init + + SUBROUTINE halo_mng_set( khls ) + + INTEGER, INTENT(in ) :: khls + + nn_hls = khls + + jpi = jpi_1 + 2*khls -2 + jpj = jpj_1 + 2*khls -2 + + jpi = jpi_1 + 2*khls -2 + jpj = jpj_1 + 2*khls -2 + + jpimax = jpimax_1 + 2*khls -2 + jpjmax = jpjmax_1 + 2*khls -2 + + Nis0 = Nis0_1 + khls - 1 + Njs0 = Njs0_1 + khls - 1 + + Nie0 = Nie0_1 + khls - 1 + Nje0 = Nje0_1 + khls - 1 + + END SUBROUTINE halo_mng_set + + SUBROUTINE halo_mng_resize_2D(pta, cdna, psgn, fillval) + + REAL(wp), POINTER, DIMENSION(:,:) :: pta + CHARACTER(len=1), INTENT(in) :: cdna + REAL(wp), INTENT(in) :: psgn + REAL(wp), OPTIONAL, INTENT(in ) :: fillval + REAL(wp), POINTER, DIMENSION(:,:) :: zpta + INTEGER :: offset + INTEGER :: pta_size_i, pta_size_j + + pta_size_i = SIZE(pta,1) + pta_size_j = SIZE(pta,2) + + ! check if the current size of pta is equal to the current expected dimension + IF (pta_size_i .ne. jpi) THEN + ALLOCATE (zpta(jpi, jpj)) + offset = abs((jpi - pta_size_i) / 2) + + IF (pta_size_i .lt. jpi) THEN + zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j) = pta + ELSE + zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj) + END IF + CALL lbc_lnk( 'halo_mng_resize_2D', zpta, cdna, psgn, pfillval=fillval) + DEALLOCATE(pta) + pta => zpta + END IF + + END SUBROUTINE halo_mng_resize_2D + + SUBROUTINE halo_mng_resize_3D(pta, cdna, psgn, fillval) + + REAL(wp), POINTER, DIMENSION(:,:,:) :: pta + CHARACTER(len=1), INTENT(in) :: cdna + REAL(wp), INTENT(in) :: psgn + REAL(wp), OPTIONAL, INTENT(in ) :: fillval + REAL(wp), POINTER, DIMENSION(:,:,:) :: zpta + INTEGER :: offset + INTEGER :: pta_size_i, pta_size_j + + pta_size_i = SIZE(pta,1) + pta_size_j = SIZE(pta,2) + + ! check if the current size of pta is equal to the current expected dimension + IF (pta_size_i .ne. jpi) THEN + ALLOCATE (zpta(jpi, jpj, jpk)) + offset = abs((jpi - pta_size_i) / 2) + + IF (pta_size_i .lt. jpi) THEN + zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j, :) = pta + ELSE + zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :) + END IF + CALL lbc_lnk( 'halo_mng_resize_3D', zpta, cdna, psgn, pfillval=fillval) + DEALLOCATE(pta) + pta => zpta + END IF + + END SUBROUTINE halo_mng_resize_3D + + SUBROUTINE halo_mng_resize_4D(pta, cdna, psgn, fillval, fjpt) + + REAL(wp), POINTER, DIMENSION(:,:,:,:) :: pta + CHARACTER(len=1), INTENT(in) :: cdna + REAL(wp), INTENT(in) :: psgn + REAL(wp), OPTIONAL, INTENT(in) :: fillval + INTEGER , INTENT(in) :: fjpt + REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zpta + INTEGER :: offset + INTEGER :: pta_size_i, pta_size_j + + pta_size_i = SIZE(pta,1) + pta_size_j = SIZE(pta,2) + + ! check if the current size of pta is equal to the current expected dimension + IF (pta_size_i .ne. jpi) THEN + ALLOCATE (zpta(jpi, jpj, jpk, jpt)) + offset = abs((jpi - pta_size_i) / 2) + + IF (pta_size_i .lt. jpi) THEN + zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j, :, :) = pta + ELSE + zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :, :) + END IF + CALL lbc_lnk( 'halo_mng_resize_4D', zpta(:,:,:,fjpt), cdna, psgn, pfillval=fillval) + DEALLOCATE(pta) + pta => zpta + END IF + + END SUBROUTINE halo_mng_resize_4D + + SUBROUTINE halo_mng_resize_5D(pta, cdna, psgn, fillval, kjpt, fjpt) + + REAL(wp), POINTER, DIMENSION(:,:,:,:,:) :: pta + CHARACTER(len=1), INTENT(in) :: cdna + REAL(wp), INTENT(in) :: psgn + REAL(wp), OPTIONAL, INTENT(in) :: fillval + INTEGER , OPTIONAL, INTENT(in) :: kjpt ! number of tracers + INTEGER , INTENT(in) :: fjpt + REAL(wp), POINTER, DIMENSION(:,:,:,:,:) :: zpta + INTEGER :: offset + INTEGER :: pta_size_i, pta_size_j + + pta_size_i = SIZE(pta,1) + pta_size_j = SIZE(pta,2) + + ! check if the current size of pta is equal to the current expected dimension + IF (pta_size_i .ne. jpi) THEN + ALLOCATE (zpta(jpi, jpj, jpk, kjpt, jpt)) + offset = abs((jpi - pta_size_i) / 2) + + IF (pta_size_i .lt. jpi) THEN + zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j, :, :, :) = pta + ELSE + zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :, :, :) + END IF + CALL lbc_lnk( 'halo_mng_resize_5D', zpta(:,:,:,:,fjpt), cdna, psgn, pfillval=fillval) + DEALLOCATE(pta) + pta => zpta + END IF + + END SUBROUTINE halo_mng_resize_5D + +END MODULE diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icb_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icb_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a27bfc4040fa0ed1cb747702678e85b184559f3d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icb_oce.f90 @@ -0,0 +1,220 @@ + + + + + + + + + + + + + +MODULE icb_oce + !!====================================================================== + !! *** MODULE icb_oce *** + !! Icebergs: declare variables for iceberg tracking + !!====================================================================== + !! History : 3.3 ! 2010-01 (T. Martin & A. Adcroft) Original code + !! - ! 2011-03 (G. Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (S. Alderson) Extensive rewrite ; Split into separate modules + !!---------------------------------------------------------------------- + !! + !! Track Icebergs as Lagrangian objects within the model domain + !! Interaction with the other model variables through 'icebergs_gridded' + !! + !! A single iceberg is held as an instance of type 'iceberg' + !! This type defines a linked list, so each instance contains a pointer + !! to the previous and next icebergs in the list + !! + !! Type 'icebergs' is a convenience container for all relevant arrays + !! It contains one pointer to an 'iceberg' instance representing all icebergs in the processor + !! + !! Each iceberg has a position represented as a real cartesian coordinate which is + !! fractional grid cell, centred on T-points; so an iceberg position of (1.0,1.0) lies + !! exactly on the first T-point and the T-cell spans 0.5 to 1.5 in each direction + !! + !! Each iceberg is assigned a unique id even in MPI + !! This consists of an array of integers: the first element is used to label, the second + !! and subsequent elements are used to count the number of times the first element wraps + !! around all possible values within the valid size for this datatype. + !! Labelling is done by starting the first label in each processor (even when only one) + !! as narea, and then incrementing by jpnij (i.e. the total number of processors. + !! This means that the source processor for each iceberg can be identified by arithmetic + !! modulo jpnij. + !! + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE lib_mpp ! MPP library + + IMPLICIT NONE + PUBLIC + + PUBLIC icb_alloc ! routine called by icb_init in icbini.F90 module + + INTEGER, PUBLIC, PARAMETER :: nclasses = 10 !: Number of icebergs classes + INTEGER, PUBLIC, PARAMETER :: nkounts = 3 !: Number of integers combined for unique naming + + TYPE, PUBLIC :: icebergs_gridded !: various icebergs properties on model grid + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: calving ! Calving mass rate (into stored ice) [kg/s] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: calving_hflx ! Calving heat flux [heat content of calving] [W/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: floating_melt ! Net melting rate to icebergs + bits [kg/s/m^2] + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: maxclass ! maximum class number at calving source point + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: tmp ! Temporary work space + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: stored_ice ! Accumulated ice mass flux at calving locations [kg] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: stored_heat ! Heat content of stored ice [J] + END TYPE icebergs_gridded + + TYPE, PUBLIC :: point !: properties of an individual iceberg (position, mass, size, etc...) + INTEGER :: year + REAL(wp) :: xi , yj , zk ! iceberg coordinates in the (i,j) referential (global) and deepest level affected + REAL(wp) :: e1 , e2 ! horizontal scale factors at the iceberg position + REAL(wp) :: lon, lat, day ! geographic position + REAL(wp) :: mass, thickness, width, length, uvel, vvel ! iceberg physical properties + REAL(wp) :: ssu, ssv, ui, vi, ua, va, ssh_x, ssh_y, sst, sss, cn, hi ! properties of iceberg environment + REAL(wp) :: mass_of_bits, heat_density + INTEGER :: kb ! icb bottom level + END TYPE point + + TYPE, PUBLIC :: iceberg !: linked list defining all the icebergs present in the model domain + TYPE(iceberg), POINTER :: prev=>NULL(), next=>NULL() ! pointers to previous and next unique icebergs in linked list + INTEGER, DIMENSION(nkounts) :: number ! variables which do not change for this iceberg + REAL(wp) :: mass_scaling ! - - - - + TYPE(point), POINTER :: current_point => NULL() ! variables which change with time are held in a separate type + END TYPE iceberg + + + TYPE(icebergs_gridded), POINTER :: berg_grid !: master instance of gridded iceberg type + TYPE(iceberg) , POINTER :: first_berg => NULL() !: master instance of linked list iceberg type + + ! !!! parameters controlling iceberg characteristics and modelling + REAL(wp) :: berg_dt !: Time-step between iceberg CALLs (should make adaptive?) + REAL(wp), DIMENSION(:), ALLOCATABLE :: first_width, first_length !: + LOGICAL :: l_restarted_bergs=.FALSE. ! Indicate whether we read state from a restart or not + ! ! arbitrary numbers for diawri entry + REAL(wp), DIMENSION(nclasses), PUBLIC :: class_num=(/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 /) + + ! Extra arrays with bigger halo, needed when interpolating forcing onto iceberg position + ! particularly for MPP when iceberg can lie inside T grid but outside U, V, or f grid + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssu_e, ssv_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: sst_e, sss_e, fr_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ua_e, va_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssh_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: tmask_e, umask_e, vmask_e + REAl(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: rlon_e, rlat_e, ff_e + REAl(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: uoce_e, voce_e, toce_e, e3t_e + ! + + !!gm almost all those PARAM ARE defined in NEMO + REAL(wp), PUBLIC, PARAMETER :: pp_rho_ice = 916.7_wp !: Density of fresh ice @ 0oC [kg/m^3] + REAL(wp), PUBLIC, PARAMETER :: pp_rho_water = 999.8_wp !: Density of fresh water @ 0oC [kg/m^3] + REAL(wp), PUBLIC, PARAMETER :: pp_rho_air = 1.1_wp !: Density of air @ 0oC [kg/m^3] + REAL(wp), PUBLIC, PARAMETER :: pp_rho_seawater = 1025._wp !: Approx. density of surface sea water @ 0oC [kg/m^3] + !!gm end + REAL(wp), PUBLIC, PARAMETER :: pp_Cd_av = 1.3_wp !: (Vertical) Drag coefficient between bergs and atmos + REAL(wp), PUBLIC, PARAMETER :: pp_Cd_ah = 0.0055_wp !: (lateral ) Drag coefficient between bergs and atmos + REAL(wp), PUBLIC, PARAMETER :: pp_Cd_wv = 0.9_wp !: (Vertical) Drag coefficient between bergs and ocean + REAL(wp), PUBLIC, PARAMETER :: pp_Cd_wh = 0.0012_wp !: (lateral ) Drag coefficient between bergs and ocean + REAL(wp), PUBLIC, PARAMETER :: pp_Cd_iv = 0.9_wp !: (Vertical) Drag coefficient between bergs and sea-ice +!TOM> no horizontal drag for sea ice! real, PARAMETER :: pp_Cd_ih=0.0012 ! (lateral) Drag coeff. between bergs and sea-ice + + ! !!* namberg namelist parameters (and defaults) ** + LOGICAL , PUBLIC :: ln_bergdia !: Calculate budgets + INTEGER , PUBLIC :: nn_verbose_level !: Turn on debugging when level > 0 + INTEGER , PUBLIC :: nn_test_icebergs !: Create icebergs in absence of a restart file from the supplied class nb + REAL(wp), PUBLIC, DIMENSION(4) :: rn_test_box !: lon1,lon2,lat1,lat2 box to create them in + LOGICAL , PUBLIC :: ln_use_calving !: Force use of calving data even with nn_test_icebergs > 0 + ! (default is not to use calving data with test bergs) + INTEGER , PUBLIC :: nn_sample_rate !: Timesteps between sampling of position for trajectory storage + INTEGER , PUBLIC :: nn_verbose_write !: timesteps between verbose messages + REAL(wp), PUBLIC :: rn_rho_bergs !: Density of icebergs + REAL(wp), PUBLIC :: rho_berg_1_oce !: convertion factor (thickness to draft) (rn_rho_bergs/pp_rho_seawater) + REAL(wp), PUBLIC :: rn_LoW_ratio !: Initial ratio L/W for newly calved icebergs + REAL(wp), PUBLIC :: rn_bits_erosion_fraction !: Fraction of erosion melt flux to divert to bergy bits + REAL(wp), PUBLIC :: rn_sicn_shift !: Shift of sea-ice concentration in erosion flux modulation (0 0 ) CALL ctl_warn('icb_alloc: allocation of arrays failed') + ! + END FUNCTION icb_alloc + + !!====================================================================== +END MODULE icb_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbclv.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbclv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8819f33de6e7b0ce56542adf5b673047016ef278 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbclv.f90 @@ -0,0 +1,195 @@ + + + + + + + + + + + + + +MODULE icbclv + !!====================================================================== + !! *** MODULE icbclv *** + !! Icebergs: calving routines for iceberg calving + !!====================================================================== + !! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) budgets into separate module + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_clv_flx : transfer input flux of ice into iceberg classes + !! icb_clv : calve icebergs from stored ice + !!---------------------------------------------------------------------- + USE par_oce ! NEMO parameters + USE dom_oce ! NEMO ocean domain + USE phycst ! NEMO physical constants + USE lib_mpp ! NEMO MPI library, lk_mpp in particular + USE lbclnk ! NEMO boundary exchanges for gridded data + + USE icbdia ! iceberg diagnostics + USE icbutl ! iceberg utility routines + USE icb_oce ! iceberg parameters + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_clv_flx ! routine called in icbstp.F90 module + PUBLIC icb_clv ! routine called in icbstp.F90 module + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbclv.F90 15088 2021-07-06 13:03:34Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_clv_flx( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_clv_flx *** + !! + !! ** Purpose : accumulate ice available for calving into class arrays + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + ! + REAL(wp) :: zcalving_used, zdist, zfact + INTEGER :: jn, ji, jj ! loop counters + INTEGER :: imx ! temporary integer for max berg class + LOGICAL, SAVE :: ll_first_call = .TRUE. + !!---------------------------------------------------------------------- + ! + ! Adapt calving flux and calving heat flux from coupler for use here + ! Use interior mask: so no bergs in overlap areas and convert from km^3/year to kg/s + ! this assumes that input is given as equivalent water flux so that pure water density is appropriate + + zfact = ( (1000._wp)**3 / ( NINT(rday) * nyear_len(1) ) ) * rn_rho_bergs + berg_grid%calving(:,:) = src_calving(:,:) * zfact * tmask_i(:,:) * tmask(:,:,1) + + ! Heat in units of W/m2, and mask (just in case) + berg_grid%calving_hflx(:,:) = src_calving_hflx(:,:) * tmask_i(:,:) * tmask(:,:,1) + + IF( ll_first_call .AND. .NOT. l_restarted_bergs ) THEN ! This is a hack to simplify initialization + ll_first_call = .FALSE. + !do jn=1, nclasses + ! where (berg_grid%calving==0.) berg_grid%stored_ice(:,:,jn)=0. + !end do + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + IF( berg_grid%calving(ji,jj) /= 0._wp ) & ! Need units of J + berg_grid%stored_heat(ji,jj) = SUM( berg_grid%stored_ice(ji,jj,:) ) * & ! initial stored ice in kg + & berg_grid%calving_hflx(ji,jj) * e1e2t(ji,jj) / berg_grid%calving(ji,jj) ! J/s/m2 x m^2 + ! ! = J/s/calving in kg/s + END DO ; END DO + ENDIF + + ! assume that all calving flux must be distributed even if distribution array does not sum + ! to one - this may not be what is intended, but it's what you've got + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + imx = berg_grid%maxclass(ji,jj) + zdist = SUM( rn_distribution(1:nclasses) ) / SUM( rn_distribution(1:imx) ) + DO jn = 1, imx + berg_grid%stored_ice(ji,jj,jn) = berg_grid%stored_ice(ji,jj,jn) & + & + berg_dt * berg_grid%calving(ji,jj) * rn_distribution(jn) * zdist + END DO + END DO ; END DO + + ! before changing the calving, save the amount we're about to use and do budget + zcalving_used = SUM( berg_grid%calving(:,:) ) + berg_grid%tmp(:,:) = berg_dt * berg_grid%calving_hflx(:,:) * e1e2t(:,:) * tmask_i(:,:) + berg_grid%stored_heat (:,:) = berg_grid%stored_heat (:,:) + berg_grid%tmp(:,:) + CALL icb_dia_income( kt, zcalving_used, berg_grid%tmp ) + ! + END SUBROUTINE icb_clv_flx + + + SUBROUTINE icb_clv( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_clv *** + !! + !! ** Purpose : This routine takes a stored ice field and calves to the ocean, + !! so the gridded array stored_ice has only non-zero entries at selected + !! wet points adjacent to known land based calving points + !! + !! ** method : - Look at each grid point and see if there's enough for each size class to calve + !! If there is, a new iceberg is calved. This happens in the order determined by + !! the class definition arrays (which in the default case is smallest first) + !! Note that only the non-overlapping part of the processor where icebergs are allowed + !! is considered + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER :: ji, jj, jn ! dummy loop indices + INTEGER :: icnt, icntmax + TYPE(iceberg) :: newberg + TYPE(point) :: newpt + REAL(wp) :: zday, zcalved_to_berg, zheat_to_berg + !!---------------------------------------------------------------------- + ! + icntmax = 0 + zday = REAL(nday_year,wp) + REAL(nsec_day,wp)/86400.0_wp + ! + DO jn = 1, nclasses + DO jj = nicbdj, nicbej + DO ji = nicbdi, nicbei + ! + icnt = 0 + ! + DO WHILE (berg_grid%stored_ice(ji,jj,jn) >= rn_initial_mass(jn) * rn_mass_scaling(jn) ) + ! + newpt%lon = glamt(ji,jj) ! at t-point (centre of the cell) + newpt%lat = gphit(ji,jj) + newpt%xi = REAL( mig(ji), wp ) - ( nn_hls - 1 ) + newpt%yj = REAL( mjg(jj), wp ) - ( nn_hls - 1 ) + ! + newpt%uvel = 0._wp ! initially at rest + newpt%vvel = 0._wp + ! ! set berg characteristics + newpt%mass = rn_initial_mass (jn) + newpt%thickness = rn_initial_thickness(jn) + newpt%kb = 1 ! compute correctly in icbthm if needed + newpt%width = first_width (jn) + newpt%length = first_length (jn) + newberg%mass_scaling = rn_mass_scaling (jn) + newpt%mass_of_bits = 0._wp ! no bergy + ! + newpt%year = nyear + newpt%day = zday + newpt%heat_density = berg_grid%stored_heat(ji,jj) / berg_grid%stored_ice(ji,jj,jn) ! This is in J/kg + ! + CALL icb_utl_incr() + newberg%number(:) = num_bergs(:) + ! + CALL icb_utl_add( newberg, newpt ) + ! + zcalved_to_berg = rn_initial_mass(jn) * rn_mass_scaling(jn) ! Units of kg + ! ! Heat content + zheat_to_berg = zcalved_to_berg * newpt%heat_density ! Units of J + berg_grid%stored_heat(ji,jj) = berg_grid%stored_heat(ji,jj) - zheat_to_berg + ! ! Stored mass + berg_grid%stored_ice(ji,jj,jn) = berg_grid%stored_ice(ji,jj,jn) - zcalved_to_berg + ! + icnt = icnt + 1 + ! + CALL icb_dia_calve(ji, jj, jn, zcalved_to_berg, zheat_to_berg ) + END DO + icntmax = MAX( icntmax, icnt ) + END DO + END DO + END DO + ! + IF( nn_verbose_level > 0 .AND. icntmax > 1 ) WRITE(numicb,*) 'icb_clv: icnt=', icnt,' on', narea + ! + END SUBROUTINE icb_clv + + !!====================================================================== +END MODULE icbclv diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbdia.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbdia.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6ac3aa2c98912e05283c1269a1178f648137238f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbdia.f90 @@ -0,0 +1,634 @@ + + + + + + + + + + + + + +MODULE icbdia + !!====================================================================== + !! *** MODULE icbdia *** + !! Icebergs: initialise variables for iceberg budgets and diagnostics + !!====================================================================== + !! History : 3.3 ! 2010-01 (Martin, Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) Budgets are now all here with lots + !! - ! of silly routines to call to get values in + !! - ! from the right points in the code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_dia_init : initialise iceberg budgeting + !! icb_dia : global iceberg diagnostics + !! icb_dia_step : reset at the beginning of each timestep + !! icb_dia_put : output (via iom_put) iceberg fields + !! icb_dia_calve : + !! icb_dia_income: + !! icb_dia_size : + !! icb_dia_speed : + !! icb_dia_melt : + !! report_state : + !! report_consistant : + !! report_budget : + !! report_istate : + !! report_ibudget: + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE dom_oce ! ocean domain + USE in_out_manager ! nemo IO + USE lib_mpp ! MPP library + USE iom ! I/O library + USE icb_oce ! iceberg variables + USE icbutl ! iceberg utility routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_dia_init ! routine called in icbini.F90 module + PUBLIC icb_dia ! routine called in icbstp.F90 module + PUBLIC icb_dia_step ! routine called in icbstp.F90 module + PUBLIC icb_dia_put ! routine called in icbstp.F90 module + PUBLIC icb_dia_melt ! routine called in icbthm.F90 module + PUBLIC icb_dia_size ! routine called in icbthm.F90 module + PUBLIC icb_dia_speed ! routine called in icbdyn.F90 module + PUBLIC icb_dia_calve ! routine called in icbclv.F90 module + PUBLIC icb_dia_income ! routine called in icbclv.F90 module + + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_melt ! Melting+erosion rate of icebergs [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_melt_hcflx ! Heat flux to ocean due to heat content of melting icebergs [J/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_melt_qlat ! Heat flux to ocean due to latent heat of melting icebergs [J/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: buoy_melt ! Buoyancy component of melting rate [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: eros_melt ! Erosion component of melting rate [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: conv_melt ! Convective component of melting rate [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: bits_src ! Mass flux from berg erosion into bergy bits [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: bits_melt ! Melting rate of bergy bits [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: bits_mass ! Mass distribution of bergy bits [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: virtual_area ! Virtual surface coverage by icebergs [m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_mass ! Mass distribution [kg/m2] + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PUBLIC :: real_calving ! Calving rate into iceberg class at + ! ! calving locations [kg/s] + + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: tmpc ! Temporary work space + REAL(wp), DIMENSION(:) , ALLOCATABLE :: rsumbuf ! Temporary work space to reduce mpp exchanges + INTEGER , DIMENSION(:) , ALLOCATABLE :: nsumbuf ! Temporary work space to reduce mpp exchanges + + REAL(wp) :: berg_melt_net + REAL(wp) :: bits_src_net + REAL(wp) :: bits_melt_net + REAL(wp) :: bits_mass_start , bits_mass_end + REAL(wp) :: floating_heat_start , floating_heat_end + REAL(wp) :: floating_mass_start , floating_mass_end + REAL(wp) :: bergs_mass_start , bergs_mass_end + REAL(wp) :: stored_start , stored_heat_start + REAL(wp) :: stored_end , stored_heat_end + REAL(wp) :: calving_src_net , calving_out_net + REAL(wp) :: calving_src_heat_net, calving_out_heat_net + REAL(wp) :: calving_src_heat_used_net + REAL(wp) :: calving_rcv_net , calving_ret_net , calving_used_net + REAL(wp) :: heat_to_bergs_net, heat_to_ocean_net, melt_net + REAL(wp) :: calving_to_bergs_net + + INTEGER :: nbergs_start, nbergs_end, nbergs_calved + INTEGER :: nbergs_melted + INTEGER :: nspeeding_tickets, nspeeding_tickets_all + INTEGER , DIMENSION(nclasses) :: nbergs_calved_by_class + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbdia.F90 14773 2021-04-30 10:23:51Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_dia_init( ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + + ALLOCATE( berg_melt (jpi,jpj) ) ; berg_melt (:,:) = 0._wp + ALLOCATE( berg_melt_hcflx(jpi,jpj) ) ; berg_melt_hcflx(:,:) = 0._wp + ALLOCATE( berg_melt_qlat(jpi,jpj) ) ; berg_melt_qlat(:,:) = 0._wp + ALLOCATE( buoy_melt (jpi,jpj) ) ; buoy_melt (:,:) = 0._wp + ALLOCATE( eros_melt (jpi,jpj) ) ; eros_melt (:,:) = 0._wp + ALLOCATE( conv_melt (jpi,jpj) ) ; conv_melt (:,:) = 0._wp + ALLOCATE( bits_src (jpi,jpj) ) ; bits_src (:,:) = 0._wp + ALLOCATE( bits_melt (jpi,jpj) ) ; bits_melt (:,:) = 0._wp + ALLOCATE( bits_mass (jpi,jpj) ) ; bits_mass (:,:) = 0._wp + ALLOCATE( virtual_area (jpi,jpj) ) ; virtual_area(:,:) = 0._wp + ALLOCATE( berg_mass (jpi,jpj) ) ; berg_mass (:,:) = 0._wp + ALLOCATE( real_calving (jpi,jpj,nclasses) ) ; real_calving(:,:,:) = 0._wp + ALLOCATE( tmpc(jpi,jpj) ) ; tmpc (:,:) = 0._wp + + nbergs_start = 0 + nbergs_end = 0 + stored_end = 0._wp + nbergs_start = 0._wp + stored_start = 0._wp + nbergs_melted = 0 + nbergs_calved = 0 + nbergs_calved_by_class(:) = 0 + nspeeding_tickets = 0 + nspeeding_tickets_all = 0 + stored_heat_end = 0._wp + floating_heat_end = 0._wp + floating_mass_end = 0._wp + bergs_mass_end = 0._wp + bits_mass_end = 0._wp + stored_heat_start = 0._wp + floating_heat_start = 0._wp + floating_mass_start = 0._wp + bergs_mass_start = 0._wp + bits_mass_start = 0._wp + bits_mass_end = 0._wp + calving_used_net = 0._wp + calving_to_bergs_net = 0._wp + heat_to_bergs_net = 0._wp + heat_to_ocean_net = 0._wp + calving_rcv_net = 0._wp + calving_ret_net = 0._wp + calving_src_net = 0._wp + calving_out_net = 0._wp + calving_src_heat_net = 0._wp + calving_src_heat_used_net = 0._wp + calving_out_heat_net = 0._wp + melt_net = 0._wp + berg_melt_net = 0._wp + bits_melt_net = 0._wp + bits_src_net = 0._wp + + floating_mass_start = icb_utl_mass( first_berg ) + bergs_mass_start = icb_utl_mass( first_berg, justbergs=.TRUE. ) + bits_mass_start = icb_utl_mass( first_berg, justbits =.TRUE. ) + IF( lk_mpp ) THEN + ALLOCATE( rsumbuf(23) ) ; rsumbuf(:) = 0._wp + ALLOCATE( nsumbuf(4+nclasses) ) ; nsumbuf(:) = 0 + rsumbuf(1) = floating_mass_start + rsumbuf(2) = bergs_mass_start + rsumbuf(3) = bits_mass_start + CALL mpp_sum( 'icbdia', rsumbuf(1:3), 3 ) + floating_mass_start = rsumbuf(1) + bergs_mass_start = rsumbuf(2) + bits_mass_start = rsumbuf(3) + ENDIF + ! + END SUBROUTINE icb_dia_init + + + SUBROUTINE icb_dia( ld_budge ) + !!---------------------------------------------------------------------- + !! sum all the things we've accumulated so far in the current processor + !! in MPP case then add these sums across all processors + !! for this we pack variables into buffer so we only need one mpp_sum + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in) :: ld_budge ! + ! + INTEGER :: ik + REAL(wp):: zunused_calving, ztmpsum, zgrdd_berg_mass, zgrdd_bits_mass + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + + zunused_calving = SUM( berg_grid%calving(:,:) ) + ztmpsum = SUM( berg_grid%floating_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + melt_net = melt_net + ztmpsum * berg_dt + calving_out_net = calving_out_net + ( zunused_calving + ztmpsum ) * berg_dt + ztmpsum = SUM( berg_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + berg_melt_net = berg_melt_net + ztmpsum * berg_dt + ztmpsum = SUM( bits_src(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + bits_src_net = bits_src_net + ztmpsum * berg_dt + ztmpsum = SUM( bits_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + bits_melt_net = bits_melt_net + ztmpsum * berg_dt + ztmpsum = SUM( src_calving(:,:) * tmask_i(:,:) ) + calving_ret_net = calving_ret_net + ztmpsum * berg_dt + ztmpsum = SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + calving_out_heat_net = calving_out_heat_net + ztmpsum * berg_dt ! Units of J + ! + IF( ld_budge ) THEN + stored_end = SUM( berg_grid%stored_ice(:,:,:) ) + stored_heat_end = SUM( berg_grid%stored_heat(:,:) ) + floating_mass_end = icb_utl_mass( first_berg ) + bergs_mass_end = icb_utl_mass( first_berg,justbergs=.TRUE. ) + bits_mass_end = icb_utl_mass( first_berg,justbits =.TRUE. ) + floating_heat_end = icb_utl_heat( first_berg ) + ! + nbergs_end = icb_utl_count() + zgrdd_berg_mass = SUM( berg_mass(:,:)*e1e2t(:,:)*tmask_i(:,:) ) + zgrdd_bits_mass = SUM( bits_mass(:,:)*e1e2t(:,:)*tmask_i(:,:) ) + ! + IF( lk_mpp ) THEN + rsumbuf( 1) = stored_end + rsumbuf( 2) = stored_heat_end + rsumbuf( 3) = floating_mass_end + rsumbuf( 4) = bergs_mass_end + rsumbuf( 5) = bits_mass_end + rsumbuf( 6) = floating_heat_end + rsumbuf( 7) = calving_ret_net + rsumbuf( 8) = calving_out_net + rsumbuf( 9) = calving_rcv_net + rsumbuf(10) = calving_src_net + rsumbuf(11) = calving_src_heat_net + rsumbuf(12) = calving_src_heat_used_net + rsumbuf(13) = calving_out_heat_net + rsumbuf(14) = calving_used_net + rsumbuf(15) = calving_to_bergs_net + rsumbuf(16) = heat_to_bergs_net + rsumbuf(17) = heat_to_ocean_net + rsumbuf(18) = melt_net + rsumbuf(19) = berg_melt_net + rsumbuf(20) = bits_src_net + rsumbuf(21) = bits_melt_net + rsumbuf(22) = zgrdd_berg_mass + rsumbuf(23) = zgrdd_bits_mass + ! + CALL mpp_sum( 'icbdia', rsumbuf(1:23), 23) + ! + stored_end = rsumbuf( 1) + stored_heat_end = rsumbuf( 2) + floating_mass_end = rsumbuf( 3) + bergs_mass_end = rsumbuf( 4) + bits_mass_end = rsumbuf( 5) + floating_heat_end = rsumbuf( 6) + calving_ret_net = rsumbuf( 7) + calving_out_net = rsumbuf( 8) + calving_rcv_net = rsumbuf( 9) + calving_src_net = rsumbuf(10) + calving_src_heat_net = rsumbuf(11) + calving_src_heat_used_net = rsumbuf(12) + calving_out_heat_net = rsumbuf(13) + calving_used_net = rsumbuf(14) + calving_to_bergs_net = rsumbuf(15) + heat_to_bergs_net = rsumbuf(16) + heat_to_ocean_net = rsumbuf(17) + melt_net = rsumbuf(18) + berg_melt_net = rsumbuf(19) + bits_src_net = rsumbuf(20) + bits_melt_net = rsumbuf(21) + zgrdd_berg_mass = rsumbuf(22) + zgrdd_bits_mass = rsumbuf(23) + ! + nsumbuf(1) = nbergs_end + nsumbuf(2) = nbergs_calved + nsumbuf(3) = nbergs_melted + nsumbuf(4) = nspeeding_tickets + DO ik = 1, nclasses + nsumbuf(4+ik) = nbergs_calved_by_class(ik) + END DO + CALL mpp_sum( 'icbdia', nsumbuf(1:nclasses+4), nclasses+4 ) + ! + nbergs_end = nsumbuf(1) + nbergs_calved = nsumbuf(2) + nbergs_melted = nsumbuf(3) + nspeeding_tickets_all = nsumbuf(4) + DO ik = 1,nclasses + nbergs_calved_by_class(ik)= nsumbuf(4+ik) + END DO + ! + ENDIF + ! + CALL report_state ( 'stored ice','kg','',stored_start,'',stored_end,'') + CALL report_state ( 'floating','kg','',floating_mass_start,'',floating_mass_end,'',nbergs_end ) + CALL report_state ( 'icebergs','kg','',bergs_mass_start,'',bergs_mass_end,'') + CALL report_state ( 'bits','kg','',bits_mass_start,'',bits_mass_end,'') + CALL report_istate ( 'berg #','',nbergs_start,'',nbergs_end,'') + CALL report_ibudget( 'berg #','calved',nbergs_calved, & + & 'melted',nbergs_melted, & + & '#',nbergs_start,nbergs_end) + CALL report_budget( 'stored mass','kg','calving used',calving_used_net, & + & 'bergs',calving_to_bergs_net, & + & 'stored mass',stored_start,stored_end) + CALL report_budget( 'floating mass','kg','calving used',calving_to_bergs_net, & + & 'bergs',melt_net, & + & 'stored mass',floating_mass_start,floating_mass_end) + CALL report_budget( 'berg mass','kg','calving',calving_to_bergs_net, & + & 'melt+eros',berg_melt_net, & + & 'berg mass',bergs_mass_start,bergs_mass_end) + CALL report_budget( 'bits mass','kg','eros used',bits_src_net, & + & 'bergs',bits_melt_net, & + & 'stored mass',bits_mass_start,bits_mass_end) + CALL report_budget( 'net mass','kg','recvd',calving_rcv_net, & + & 'rtrnd',calving_ret_net, & + & 'net mass',stored_start+floating_mass_start, & + & stored_end+floating_mass_end) + CALL report_consistant( 'iceberg mass','kg','gridded',zgrdd_berg_mass,'bergs',bergs_mass_end) + CALL report_consistant( 'bits mass','kg','gridded',zgrdd_bits_mass,'bits',bits_mass_end) + CALL report_state( 'net heat','J','',stored_heat_start+floating_heat_start,'', & + & stored_heat_end+floating_heat_end,'') + CALL report_state( 'stored heat','J','',stored_heat_start,'',stored_heat_end,'') + CALL report_state( 'floating heat','J','',floating_heat_start,'',floating_heat_end,'') + CALL report_budget( 'net heat','J','net heat',calving_src_heat_net, & + & 'net heat',calving_out_heat_net, & + & 'net heat',stored_heat_start+floating_heat_start, & + & stored_heat_end+floating_heat_end) + CALL report_budget( 'stored heat','J','calving used',calving_src_heat_used_net, & + & 'bergs',heat_to_bergs_net, & + & 'net heat',stored_heat_start,stored_heat_end) + CALL report_budget( 'flting heat','J','calved',heat_to_bergs_net, & + & 'melt',heat_to_ocean_net, & + & 'net heat',floating_heat_start,floating_heat_end) + IF (nn_verbose_level >= 1) THEN + CALL report_consistant( 'top interface','kg','from SIS',calving_src_net, & + & 'received',calving_rcv_net) + CALL report_consistant( 'bot interface','kg','sent',calving_out_net, & + & 'returned',calving_ret_net) + ENDIF + IF (nn_verbose_level > 0) THEN + WRITE( numicb, '("calved by class = ",i6,20(",",i6))') (nbergs_calved_by_class(ik),ik=1,nclasses) + IF( nspeeding_tickets_all > 0 ) THEN + WRITE( numicb, '("speeding tickets issued (this domain) = ",i6)') nspeeding_tickets + WRITE( numicb, '("speeding tickets issued (all domains) = ",i6)') nspeeding_tickets_all + END IF + ENDIF + ! + nbergs_start = nbergs_end + stored_start = stored_end + nbergs_melted = 0 + nbergs_calved = 0 + nbergs_calved_by_class(:) = 0 + nspeeding_tickets = 0 + nspeeding_tickets_all = 0 + stored_heat_start = stored_heat_end + floating_heat_start = floating_heat_end + floating_mass_start = floating_mass_end + bergs_mass_start = bergs_mass_end + bits_mass_start = bits_mass_end + calving_used_net = 0._wp + calving_to_bergs_net = 0._wp + heat_to_bergs_net = 0._wp + heat_to_ocean_net = 0._wp + calving_rcv_net = 0._wp + calving_ret_net = 0._wp + calving_src_net = 0._wp + calving_out_net = 0._wp + calving_src_heat_net = 0._wp + calving_src_heat_used_net = 0._wp + calving_out_heat_net = 0._wp + melt_net = 0._wp + berg_melt_net = 0._wp + bits_melt_net = 0._wp + bits_src_net = 0._wp + ENDIF + ! + END SUBROUTINE icb_dia + + + SUBROUTINE icb_dia_step + !!---------------------------------------------------------------------- + !! things to reset at the beginning of each timestep + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + berg_melt (:,:) = 0._wp + berg_melt_hcflx(:,:) = 0._wp + berg_melt_qlat(:,:) = 0._wp + buoy_melt (:,:) = 0._wp + eros_melt (:,:) = 0._wp + conv_melt (:,:) = 0._wp + bits_src (:,:) = 0._wp + bits_melt (:,:) = 0._wp + bits_mass (:,:) = 0._wp + berg_mass (:,:) = 0._wp + virtual_area(:,:) = 0._wp + real_calving(:,:,:) = 0._wp + ! + END SUBROUTINE icb_dia_step + + + SUBROUTINE icb_dia_put + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN !!gm useless iom will control whether it is output or not + ! + CALL iom_put( "berg_melt" , berg_melt (:,:) ) ! Melt rate of icebergs [kg/m2/s] + !! NB. The berg_melt_hcflx field is currently always zero - see comment in icbthm.F90 + CALL iom_put( "berg_melt_hcflx" , berg_melt_hcflx(:,:)) ! Heat flux to ocean due to heat content of melting icebergs [J/m2/s] + CALL iom_put( "berg_melt_qlat" , berg_melt_qlat(:,:) ) ! Heat flux to ocean due to latent heat of melting icebergs [J/m2/s] + CALL iom_put( "berg_buoy_melt" , buoy_melt (:,:) ) ! Buoyancy component of iceberg melt rate [kg/m2/s] + CALL iom_put( "berg_eros_melt" , eros_melt (:,:) ) ! Erosion component of iceberg melt rate [kg/m2/s] + CALL iom_put( "berg_conv_melt" , conv_melt (:,:) ) ! Convective component of iceberg melt rate [kg/m2/s] + CALL iom_put( "berg_virtual_area", virtual_area(:,:) ) ! Virtual coverage by icebergs [m2] + CALL iom_put( "bits_src" , bits_src (:,:) ) ! Mass source of bergy bits [kg/m2/s] + CALL iom_put( "bits_melt" , bits_melt (:,:) ) ! Melt rate of bergy bits [kg/m2/s] + CALL iom_put( "bits_mass" , bits_mass (:,:) ) ! Bergy bit density field [kg/m2] + CALL iom_put( "berg_mass" , berg_mass (:,:) ) ! Iceberg density field [kg/m2] + CALL iom_put( "berg_real_calving", real_calving(:,:,:) ) ! Calving into iceberg class [kg/s] + ! + END SUBROUTINE icb_dia_put + + + SUBROUTINE icb_dia_calve( ki, kj, kn, pcalved, pheated ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ki, kj, kn + REAL(wp), INTENT(in) :: pcalved + REAL(wp), INTENT(in) :: pheated + !!---------------------------------------------------------------------- + ! + IF( .NOT. ln_bergdia ) RETURN + real_calving(ki,kj,kn) = real_calving(ki,kj,kn) + pcalved / berg_dt + nbergs_calved = nbergs_calved + 1 + nbergs_calved_by_class(kn) = nbergs_calved_by_class(kn) + 1 + calving_to_bergs_net = calving_to_bergs_net + pcalved + heat_to_bergs_net = heat_to_bergs_net + pheated + ! + END SUBROUTINE icb_dia_calve + + + SUBROUTINE icb_dia_income( kt, pcalving_used, pheat_used ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt + REAL(wp), INTENT(in) :: pcalving_used + REAL(wp), DIMENSION(:,:), INTENT(in) :: pheat_used + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + ! + IF( kt == nit000 ) THEN + stored_start = SUM( berg_grid%stored_ice(:,:,:) ) + CALL mpp_sum( 'icbdia', stored_start ) + ! + stored_heat_start = SUM( berg_grid%stored_heat(:,:) ) + CALL mpp_sum( 'icbdia', stored_heat_start ) + IF (nn_verbose_level > 0) THEN + WRITE(numicb,'(a,es13.6,a)') 'icb_dia_income: initial stored mass=',stored_start,' kg' + WRITE(numicb,'(a,es13.6,a)') 'icb_dia_income: initial stored heat=',stored_heat_start,' J' + ENDIF + ENDIF + ! + calving_rcv_net = calving_rcv_net + SUM( berg_grid%calving(:,:) ) * berg_dt + calving_src_net = calving_rcv_net + calving_src_heat_net = calving_src_heat_net + & + & SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) ) * berg_dt ! Units of J + calving_used_net = calving_used_net + pcalving_used * berg_dt + calving_src_heat_used_net = calving_src_heat_used_net + SUM( pheat_used(:,:) ) + ! + END SUBROUTINE icb_dia_income + + + SUBROUTINE icb_dia_size(ki, kj, pWn, pLn, pAbits, & + & pmass_scale, pMnew, pnMbits, pz1_e1e2) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ki, kj + REAL(wp), INTENT(in) :: pWn, pLn, pAbits, pmass_scale, pMnew, pnMbits, pz1_e1e2 + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + virtual_area(ki,kj) = virtual_area(ki,kj) + ( pWn * pLn + pAbits ) * pmass_scale ! m^2 + berg_mass(ki,kj) = berg_mass(ki,kj) + pMnew * pz1_e1e2 ! kg/m2 + bits_mass(ki,kj) = bits_mass(ki,kj) + pnMbits * pz1_e1e2 ! kg/m2 + ! + END SUBROUTINE icb_dia_size + + + SUBROUTINE icb_dia_speed() + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + nspeeding_tickets = nspeeding_tickets + 1 + ! + END SUBROUTINE icb_dia_speed + + + SUBROUTINE icb_dia_melt(ki, kj, pmnew, pheat_hcflux, pheat_latent, pmass_scale, & + & pdM, pdMbitsE, pdMbitsM, pdMb, pdMe, & + & pdMv, pz1_dt_e1e2, pz1_e1e2 ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ki, kj + REAL(wp), INTENT(in) :: pmnew, pheat_hcflux, pheat_latent, pmass_scale + REAL(wp), INTENT(in) :: pdM, pdMbitsE, pdMbitsM, pdMb, pdMe, pdMv, pz1_dt_e1e2, pz1_e1e2 + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + ! + berg_melt (ki,kj) = berg_melt (ki,kj) + pdM * pz1_dt_e1e2 ! kg/m2/s + berg_melt_hcflx (ki,kj) = berg_melt_hcflx (ki,kj) + pheat_hcflux * pz1_e1e2 ! W/m2 + berg_melt_qlat (ki,kj) = berg_melt_qlat (ki,kj) + pheat_latent * pz1_e1e2 ! W/m2 + bits_src (ki,kj) = bits_src (ki,kj) + pdMbitsE * pz1_dt_e1e2 ! mass flux into bergy bitskg/m2/s + bits_melt (ki,kj) = bits_melt (ki,kj) + pdMbitsM * pz1_dt_e1e2 ! melt rate of bergy bits kg/m2/s + buoy_melt (ki,kj) = buoy_melt (ki,kj) + pdMb * pz1_dt_e1e2 ! kg/m2/s + eros_melt (ki,kj) = eros_melt (ki,kj) + pdMe * pz1_dt_e1e2 ! erosion rate kg/m2/s + conv_melt (ki,kj) = conv_melt (ki,kj) + pdMv * pz1_dt_e1e2 ! kg/m2/s + heat_to_ocean_net = heat_to_ocean_net + (pheat_hcflux + pheat_latent) * pmass_scale * berg_dt ! J + IF( pmnew <= 0._wp ) nbergs_melted = nbergs_melted + 1 ! Delete the berg if completely melted + ! + END SUBROUTINE icb_dia_melt + + + SUBROUTINE report_state( cd_budgetstr, cd_budgetunits, cd_startstr, pstartval, cd_endstr, & + & pendval, cd_delstr, kbergs ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_startstr, cd_endstr, cd_delstr + REAL(wp), INTENT(in) :: pstartval, pendval + INTEGER, INTENT(in), OPTIONAL :: kbergs + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + IF( PRESENT(kbergs) ) THEN + WRITE(numicb,100) cd_budgetstr // ' state:', & + & cd_startstr // ' start', pstartval, cd_budgetunits, & + & cd_endstr // ' end', pendval, cd_budgetunits, & + & 'Delta ' // cd_delstr, pendval-pstartval, cd_budgetunits, & + & '# of bergs', kbergs + ELSE + WRITE(numicb,100) cd_budgetstr // ' state:', & + & cd_startstr // ' start', pstartval, cd_budgetunits, & + & cd_endstr // ' end', pendval, cd_budgetunits, & + & cd_delstr // 'Delta', pendval-pstartval, cd_budgetunits + ENDIF +100 FORMAT(a19,3(a18,"=",es14.7,x,a2,:,","),a12,i8) + ! + END SUBROUTINE report_state + + + SUBROUTINE report_consistant( cd_budgetstr, cd_budgetunits, cd_startstr, pstartval, cd_endstr, pendval) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_startstr, cd_endstr + REAL(wp), INTENT(in) :: pstartval, pendval + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + WRITE(numicb,200) cd_budgetstr // ' check:', & + & cd_startstr, pstartval, cd_budgetunits, & + & cd_endstr, pendval, cd_budgetunits, & + & 'error', (pendval-pstartval)/((pendval+pstartval)+1e-30), 'nd' +200 FORMAT(a19,10(a18,"=",es14.7,x,a2,:,",")) + ! + END SUBROUTINE report_consistant + + + SUBROUTINE report_budget( cd_budgetstr, cd_budgetunits, cd_instr, pinval, cd_outstr, & + & poutval, cd_delstr, pstartval, pendval) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_instr, cd_outstr, cd_delstr + REAL(wp), INTENT(in) :: pinval, poutval, pstartval, pendval + ! + REAL(wp) :: zval + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + zval = ( ( pendval - pstartval ) - ( pinval - poutval ) ) / & + & MAX( 1.e-30, MAX( ABS( pendval - pstartval ) , ABS( pinval - poutval ) ) ) + ! + WRITE(numicb,200) cd_budgetstr // ' budget:', & + & cd_instr // ' in', pinval, cd_budgetunits, & + & cd_outstr // ' out', poutval, cd_budgetunits, & + & 'Delta ' // cd_delstr, pinval-poutval, cd_budgetunits, & + & 'error', zval, 'nd' + 200 FORMAT(a19,3(a18,"=",es14.7,x,a2,:,","),a8,"=",es10.3,x,a2) + ! + END SUBROUTINE report_budget + + + SUBROUTINE report_istate( cd_budgetstr, cd_startstr, pstartval, cd_endstr, pendval, cd_delstr) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_startstr, cd_endstr, cd_delstr + INTEGER , INTENT(in) :: pstartval, pendval + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + WRITE(numicb,100) cd_budgetstr // ' state:', & + & cd_startstr // ' start', pstartval, & + & cd_endstr // ' end', pendval, & + & cd_delstr // 'Delta', pendval-pstartval + 100 FORMAT(a19,3(a18,"=",i14,x,:,",")) + ! + END SUBROUTINE report_istate + + + SUBROUTINE report_ibudget( cd_budgetstr, cd_instr, pinval, cd_outstr, poutval, & + & cd_delstr, pstartval, pendval) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_instr, cd_outstr, cd_delstr + INTEGER, INTENT(in) :: pinval, poutval, pstartval, pendval + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + WRITE(numicb,200) cd_budgetstr // ' budget:', & + & cd_instr // ' in', pinval, & + & cd_outstr // ' out', poutval, & + & 'Delta ' // cd_delstr, pinval-poutval, & + & 'error', ( ( pendval - pstartval ) - ( pinval - poutval ) ) +200 FORMAT(a19,10(a18,"=",i14,x,:,",")) + ! + END SUBROUTINE report_ibudget + + !!====================================================================== +END MODULE icbdia diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbdyn.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbdyn.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fae1d75d05510713f872b0ebfa981f4ffe885b1e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbdyn.f90 @@ -0,0 +1,452 @@ + + + + + + + + + + + + + +MODULE icbdyn + !!====================================================================== + !! *** MODULE icbdyn *** + !! Iceberg: time stepping routine for iceberg tracking + !!====================================================================== + !! History : 3.3 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) Replace broken grounding routine with one of + !! - ! Gurvan's suggestions (just like the broken one) + !!---------------------------------------------------------------------- + USE par_oce ! NEMO parameters + USE dom_oce ! NEMO ocean domain + USE phycst ! NEMO physical constants + USE in_out_manager ! IO parameters + ! + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + USE icbdia ! iceberg budget routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_dyn ! routine called in icbstp.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbdyn.F90 15088 2021-07-06 13:03:34Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_dyn( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_dyn *** + !! + !! ** Purpose : iceberg evolution. + !! + !! ** Method : - See Martin & Adcroft, Ocean Modelling 34, 2010 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! + ! + LOGICAL :: ll_bounced + REAL(wp) :: zuvel1 , zvvel1 , zu1, zv1, zax1, zay1, zxi1 , zyj1 + REAL(wp) :: zuvel2 , zvvel2 , zu2, zv2, zax2, zay2, zxi2 , zyj2 + REAL(wp) :: zuvel3 , zvvel3 , zu3, zv3, zax3, zay3, zxi3 , zyj3 + REAL(wp) :: zuvel4 , zvvel4 , zu4, zv4, zax4, zay4, zxi4 , zyj4 + REAL(wp) :: zuvel_n, zvvel_n, zxi_n , zyj_n + REAL(wp) :: zdt, zdt_2, zdt_6, ze1, ze2 + TYPE(iceberg), POINTER :: berg + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + ! + ! 4th order Runge-Kutta to solve: d/dt X = V, d/dt V = A + ! with I.C.'s: X=X1 and V=V1 + ! + ! ; A1=A(X1,V1) + ! X2 = X1+dt/2*V1 ; V2 = V1+dt/2*A1 ; A2=A(X2,V2) + ! X3 = X1+dt/2*V2 ; V3 = V1+dt/2*A2 ; A3=A(X3,V3) + ! X4 = X1+ dt*V3 ; V4 = V1+ dt*A3 ; A4=A(X4,V4) + ! + ! Xn = X1+dt*(V1+2*V2+2*V3+V4)/6 + ! Vn = V1+dt*(A1+2*A2+2*A3+A4)/6 + + ! time steps + zdt = berg_dt + zdt_2 = zdt * 0.5_wp + zdt_6 = zdt / 6._wp + + berg => first_berg ! start from the first berg + ! + DO WHILE ( ASSOCIATED(berg) ) !== loop over all bergs ==! + ! + pt => berg%current_point + + ll_bounced = .FALSE. + + + ! STEP 1 ! + ! ====== ! + zxi1 = pt%xi ; zuvel1 = pt%uvel !** X1 in (i,j) ; V1 in m/s + zyj1 = pt%yj ; zvvel1 = pt%vvel + + + ! !** A1 = A(X1,V1) + CALL icb_accel( kt, berg , zxi1, ze1, zuvel1, zuvel1, zax1, & + & zyj1, ze2, zvvel1, zvvel1, zay1, zdt_2, 0.5_wp ) + ! + zu1 = zuvel1 / ze1 !** V1 in d(i,j)/dt + zv1 = zvvel1 / ze2 + + ! STEP 2 ! + ! ====== ! + ! !** X2 = X1+dt/2*V1 ; V2 = V1+dt/2*A1 + ! position using di/dt & djdt ! V2 in m/s + zxi2 = zxi1 + zdt_2 * zu1 ; zuvel2 = zuvel1 + zdt_2 * zax1 + zyj2 = zyj1 + zdt_2 * zv1 ; zvvel2 = zvvel1 + zdt_2 * zay1 + ! + CALL icb_ground( berg, zxi2, zxi1, zu1, & + & zyj2, zyj1, zv1, ll_bounced ) + + ! !** A2 = A(X2,V2) + CALL icb_accel( kt, berg , zxi2, ze1, zuvel2, zuvel1, zax2, & + & zyj2, ze2, zvvel2, zvvel1, zay2, zdt_2, 0.5_wp ) + ! + zu2 = zuvel2 / ze1 !** V2 in d(i,j)/dt + zv2 = zvvel2 / ze2 + ! + ! STEP 3 ! + ! ====== ! + ! !** X3 = X1+dt/2*V2 ; V3 = V1+dt/2*A2; A3=A(X3) + zxi3 = zxi1 + zdt_2 * zu2 ; zuvel3 = zuvel1 + zdt_2 * zax2 + zyj3 = zyj1 + zdt_2 * zv2 ; zvvel3 = zvvel1 + zdt_2 * zay2 + ! + CALL icb_ground( berg, zxi3, zxi1, zu2, & + & zyj3, zyj1, zv2, ll_bounced ) + + ! !** A3 = A(X3,V3) + CALL icb_accel( kt, berg , zxi3, ze1, zuvel3, zuvel1, zax3, & + & zyj3, ze2, zvvel3, zvvel1, zay3, zdt, 1._wp ) + ! + zu3 = zuvel3 / ze1 !** V3 in d(i,j)/dt + zv3 = zvvel3 / ze2 + + ! STEP 4 ! + ! ====== ! + ! !** X4 = X1+dt*V3 ; V4 = V1+dt*A3 + zxi4 = zxi1 + zdt * zu3 ; zuvel4 = zuvel1 + zdt * zax3 + zyj4 = zyj1 + zdt * zv3 ; zvvel4 = zvvel1 + zdt * zay3 + + CALL icb_ground( berg, zxi4, zxi1, zu3, & + & zyj4, zyj1, zv3, ll_bounced ) + + ! !** A4 = A(X4,V4) + CALL icb_accel( kt, berg , zxi4, ze1, zuvel4, zuvel1, zax4, & + & zyj4, ze2, zvvel4, zvvel1, zay4, zdt, 1._wp ) + + zu4 = zuvel4 / ze1 !** V4 in d(i,j)/dt + zv4 = zvvel4 / ze2 + + ! FINAL STEP ! + ! ========== ! + ! !** Xn = X1+dt*(V1+2*V2+2*V3+V4)/6 + ! !** Vn = V1+dt*(A1+2*A2+2*A3+A4)/6 + zxi_n = pt%xi + zdt_6 * ( zu1 + 2.*(zu2 + zu3 ) + zu4 ) + zyj_n = pt%yj + zdt_6 * ( zv1 + 2.*(zv2 + zv3 ) + zv4 ) + zuvel_n = pt%uvel + zdt_6 * ( zax1 + 2.*(zax2 + zax3) + zax4 ) + zvvel_n = pt%vvel + zdt_6 * ( zay1 + 2.*(zay2 + zay3) + zay4 ) + + CALL icb_ground( berg, zxi_n, zxi1, zuvel_n, & + & zyj_n, zyj1, zvvel_n, ll_bounced ) + + pt%uvel = zuvel_n !** save in berg structure + pt%vvel = zvvel_n + pt%xi = zxi_n + pt%yj = zyj_n + + berg => berg%next ! switch to the next berg + ! + END DO !== end loop over all bergs ==! + ! + END SUBROUTINE icb_dyn + + + SUBROUTINE icb_ground( berg, pi, pi0, pu, & + & pj, pj0, pv, ld_bounced ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_ground *** + !! + !! ** Purpose : iceberg grounding. + !! + !! ** Method : - adjust velocity and then put iceberg back to start position + !! NB two possibilities available one of which is hard-coded here + !!---------------------------------------------------------------------- + TYPE(iceberg ), POINTER, INTENT(in ) :: berg ! berg + ! + REAL(wp), INTENT(inout) :: pi , pj ! current iceberg position + REAL(wp), INTENT(in ) :: pi0, pj0 ! previous iceberg position + REAL(wp), INTENT(inout) :: pu , pv ! current iceberg velocities + LOGICAL , INTENT( out) :: ld_bounced ! bounced indicator + ! + INTEGER :: ii, ii0 + INTEGER :: ij, ij0 + INTEGER :: ikb + INTEGER :: ibounce_method + ! + REAL(wp) :: zD + REAL(wp), DIMENSION(jpk) :: ze3t + !!---------------------------------------------------------------------- + ! + ld_bounced = .FALSE. + ! + ii0 = INT( pi0+0.5 ) + (nn_hls-1) ; ij0 = INT( pj0+0.5 ) + (nn_hls-1) ! initial gridpoint position (T-cell) + ii = INT( pi +0.5 ) + (nn_hls-1) ; ij = INT( pj +0.5 ) + (nn_hls-1) ! current - - + ! + IF( ii == ii0 .AND. ij == ij0 ) RETURN ! berg remains in the same cell + ! + ! map into current processor + ii0 = mi1( ii0 ) + ij0 = mj1( ij0 ) + ii = mi1( ii ) + ij = mj1( ij ) + ! + ! assume icb is grounded if tmask(ii,ij,1) or tmask(ii,ij,ikb), depending of the option is not 0 + IF ( ln_M2016 .AND. ln_icb_grd ) THEN + ! + ! draught (keel depth) + zD = rho_berg_1_oce * berg%current_point%thickness + ! + ! interpol needed data + CALL icb_utl_interp( pi, pj, pe3t=ze3t ) + ! + !compute bottom level + CALL icb_utl_getkb( ikb, ze3t, zD ) + ! + ! berg reach a new t-cell, but an ocean one + ! .AND. needed in case berg hit an isf (tmask(ii,ij,1) == 0 and tmask(ii,ij,ikb) /= 0) + IF( tmask(ii,ij,ikb) /= 0._wp .AND. tmask(ii,ij,1) /= 0._wp ) RETURN + ! + ELSE + IF( tmask(ii,ij,1) /= 0._wp ) RETURN ! berg reach a new t-cell, but an ocean one + END IF + ! + ! From here, berg have reach land: treat grounding/bouncing + ! ------------------------------- + ld_bounced = .TRUE. + + !! not obvious what should happen now + !! if berg tries to enter a land box, the only location we can return it to is the start + !! position (pi0,pj0), since it has to be in a wet box to do any melting; + !! first option is simply to set whole velocity to zero and move back to start point + !! second option (suggested by gm) is only to set the velocity component in the (i,j) direction + !! of travel to zero; at a coastal boundary this has the effect of sliding the berg along the coast + + ibounce_method = 2 + SELECT CASE ( ibounce_method ) + CASE ( 1 ) + pi = pi0 + pj = pj0 + pu = 0._wp + pv = 0._wp + CASE ( 2 ) + IF( ii0 /= ii ) THEN + pi = pi0 ! return back to the initial position + pu = 0._wp ! zeroing of velocity in the direction of the grounding + ENDIF + IF( ij0 /= ij ) THEN + pj = pj0 ! return back to the initial position + pv = 0._wp ! zeroing of velocity in the direction of the grounding + ENDIF + END SELECT + ! + END SUBROUTINE icb_ground + + + SUBROUTINE icb_accel( kt, berg , pxi, pe1, puvel, puvel0, pax, & + & pyj, pe2, pvvel, pvvel0, pay, pdt, pcfl_scale ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_accel *** + !! + !! ** Purpose : compute the iceberg acceleration. + !! + !! ** Method : - sum the terms in the momentum budget + !!---------------------------------------------------------------------- + TYPE(iceberg ), POINTER, INTENT(in ) :: berg ! berg + INTEGER , INTENT(in ) :: kt ! time step + REAL(wp) , INTENT(in ) :: pcfl_scale + REAL(wp) , INTENT(in ) :: pxi , pyj ! berg position in (i,j) referential + REAL(wp) , INTENT(in ) :: puvel , pvvel ! berg velocity [m/s] + REAL(wp) , INTENT(in ) :: puvel0, pvvel0 ! initial berg velocity [m/s] + REAL(wp) , INTENT( out) :: pe1, pe2 ! horizontal scale factor at (xi,yj) + REAL(wp) , INTENT(inout) :: pax, pay ! berg acceleration + REAL(wp) , INTENT(in ) :: pdt ! berg time step + ! + REAL(wp), PARAMETER :: pp_alpha = 0._wp ! + REAL(wp), PARAMETER :: pp_beta = 1._wp ! + REAL(wp), PARAMETER :: pp_vel_lim =15._wp ! max allowed berg speed + REAL(wp), PARAMETER :: pp_accel_lim = 1.e-2_wp ! max allowed berg acceleration + REAL(wp), PARAMETER :: pp_Cr0 = 0.06_wp ! + ! + INTEGER :: itloop, ikb, jk + REAL(wp) :: zuo, zssu, zui, zua, zuwave, zssh_x, zcn, zhi + REAL(wp) :: zvo, zssv, zvi, zva, zvwave, zssh_y + REAL(wp) :: zff, zT, zD, zW, zL, zM, zF + REAL(wp) :: zdrag_ocn, zdrag_atm, zdrag_ice, zwave_rad + REAL(wp) :: z_ocn, z_atm, z_ice, zdep + REAL(wp) :: zampl, zwmod, zCr, zLwavelength, zLcutoff, zLtop + REAL(wp) :: zlambda, zdetA, zA11, zA12, zaxe, zaye, zD_hi + REAL(wp) :: zuveln, zvveln, zus, zvs, zspeed, zloc_dx, zspeed_new + REAL(wp), DIMENSION(jpk) :: zuoce, zvoce, ze3t, zdepw + !!---------------------------------------------------------------------- + + ! Interpolate gridded fields to berg + nknberg = berg%number(1) + CALL icb_utl_interp( pxi, pyj, pe1=pe1, pe2=pe2, & ! scale factor + & pssu=zssu, pui=zui, pua=zua, & ! oce/ice/atm velocities + & pssv=zssv, pvi=zvi, pva=zva, & ! oce/ice/atm velocities + & pssh_i=zssh_x, pssh_j=zssh_y, & ! ssh gradient + & phi=zhi, pff=zff) ! ice thickness and coriolis + + zM = berg%current_point%mass + zT = berg%current_point%thickness ! total thickness + zD = rho_berg_1_oce * zT ! draught (keel depth) + zF = zT - zD ! freeboard + zW = berg%current_point%width + zL = berg%current_point%length + + zhi = MIN( zhi , zD ) + zD_hi = MAX( 0._wp, zD-zhi ) + + ! Wave radiation + zuwave = zua - zssu ; zvwave = zva - zssv ! Use wind speed rel. to ocean for wave model + zwmod = zuwave*zuwave + zvwave*zvwave ! The wave amplitude and length depend on the current; + ! ! wind speed relative to the ocean. Actually wmod is wmod**2 here. + zampl = 0.5_wp * 0.02025_wp * zwmod ! This is "a", the wave amplitude + zLwavelength = 0.32_wp * zwmod ! Surface wave length fitted to data in table at + ! ! http://www4.ncsu.edu/eos/users/c/ceknowle/public/chapter10/part2.html + zLcutoff = 0.125_wp * zLwavelength + zLtop = 0.25_wp * zLwavelength + zCr = pp_Cr0 * MIN( MAX( 0._wp, (zL-zLcutoff) / ((zLtop-zLcutoff)+1.e-30)) , 1._wp) ! Wave radiation coefficient + ! ! fitted to graph from Carrieres et al., POAC Drift Model. + zwave_rad = 0.5_wp * pp_rho_seawater / zM * zCr * grav * zampl * MIN( zampl,zF ) * (2._wp*zW*zL) / (zW+zL) + zwmod = SQRT( zua*zua + zva*zva ) ! Wind speed + IF( zwmod /= 0._wp ) THEN + zuwave = zua/zwmod ! Wave radiation force acts in wind direction ... !!gm this should be the wind rel. to ocean ? + zvwave = zva/zwmod + ELSE + zuwave = 0._wp ; zvwave=0._wp ; zwave_rad=0._wp ! ... and only when wind is present. !!gm wave_rad=0. is useless + ENDIF + + ! Weighted drag coefficients + z_ocn = pp_rho_seawater / zM * (0.5_wp*pp_Cd_wv*zW*(zD_hi)+pp_Cd_wh*zW*zL) + z_atm = pp_rho_air / zM * (0.5_wp*pp_Cd_av*zW*zF +pp_Cd_ah*zW*zL) + z_ice = pp_rho_ice / zM * (0.5_wp*pp_Cd_iv*zW*zhi ) + IF( abs(zui) + abs(zvi) == 0._wp ) z_ice = 0._wp + + ! lateral velocities + ! default ssu and ssv + ! ln_M2016: mean velocity along the profile + IF ( ln_M2016 ) THEN + ! interpol needed data + CALL icb_utl_interp( pxi, pyj, puoce=zuoce, pvoce=zvoce, pe3t=ze3t ) ! 3d velocities + + !compute bottom level + CALL icb_utl_getkb( ikb, ze3t, zD ) + + ! compute mean velocity + CALL icb_utl_zavg(zuo, zuoce, ze3t, zD, ikb) + CALL icb_utl_zavg(zvo, zvoce, ze3t, zD, ikb) + ELSE + zuo = zssu + zvo = zssv + END IF + + zuveln = puvel ; zvveln = pvvel ! Copy starting uvel, vvel + ! + DO itloop = 1, 2 ! Iterate on drag coefficients + ! + zus = 0.5_wp * ( zuveln + puvel ) + zvs = 0.5_wp * ( zvveln + pvvel ) + zdrag_ocn = z_ocn * SQRT( (zus-zuo)*(zus-zuo) + (zvs-zvo)*(zvs-zvo) ) + zdrag_atm = z_atm * SQRT( (zus-zua)*(zus-zua) + (zvs-zva)*(zvs-zva) ) + zdrag_ice = z_ice * SQRT( (zus-zui)*(zus-zui) + (zvs-zvi)*(zvs-zvi) ) + ! + ! Explicit accelerations + !zaxe= zff*pvvel -grav*zssh_x +zwave_rad*zuwave & + ! -zdrag_ocn*(puvel-zssu) -zdrag_atm*(puvel-zua) -zdrag_ice*(puvel-zui) + !zaye=-zff*puvel -grav*zssh_y +zwave_rad*zvwave & + ! -zdrag_ocn*(pvvel-zssv) -zdrag_atm*(pvvel-zva) -zdrag_ice*(pvvel-zvi) + zaxe = -grav * zssh_x + zwave_rad * zuwave + zaye = -grav * zssh_y + zwave_rad * zvwave + IF( pp_alpha > 0._wp ) THEN ! If implicit, use time-level (n) rather than RK4 latest + zaxe = zaxe + zff*pvvel0 + zaye = zaye - zff*puvel0 + ELSE + zaxe = zaxe + zff*pvvel + zaye = zaye - zff*puvel + ENDIF + IF( pp_beta > 0._wp ) THEN ! If implicit, use time-level (n) rather than RK4 latest + zaxe = zaxe - zdrag_ocn*(puvel0-zuo) - zdrag_atm*(puvel0-zua) -zdrag_ice*(puvel0-zui) + zaye = zaye - zdrag_ocn*(pvvel0-zvo) - zdrag_atm*(pvvel0-zva) -zdrag_ice*(pvvel0-zvi) + ELSE + zaxe = zaxe - zdrag_ocn*(puvel -zuo) - zdrag_atm*(puvel -zua) -zdrag_ice*(puvel -zui) + zaye = zaye - zdrag_ocn*(pvvel -zvo) - zdrag_atm*(pvvel -zva) -zdrag_ice*(pvvel -zvi) + ENDIF + + ! Solve for implicit accelerations + IF( pp_alpha + pp_beta > 0._wp ) THEN + zlambda = zdrag_ocn + zdrag_atm + zdrag_ice + zA11 = 1._wp + pp_beta *pdt*zlambda + zA12 = pp_alpha*pdt*zff + zdetA = 1._wp / ( zA11*zA11 + zA12*zA12 ) + pax = zdetA * ( zA11*zaxe + zA12*zaye ) + pay = zdetA * ( zA11*zaye - zA12*zaxe ) + ELSE + pax = zaxe ; pay = zaye + ENDIF + + zuveln = puvel0 + pdt*pax + zvveln = pvvel0 + pdt*pay + ! + END DO ! itloop + + IF( rn_speed_limit > 0._wp ) THEN ! Limit speed of bergs based on a CFL criteria (if asked) + zspeed = SQRT( zuveln*zuveln + zvveln*zvveln ) ! Speed of berg + IF( zspeed > 0._wp ) THEN + zloc_dx = MIN( pe1, pe2 ) ! minimum grid spacing + ! cfl scale is function of the RK4 step + zspeed_new = zloc_dx / pdt * rn_speed_limit * pcfl_scale ! Speed limit as a factor of dx / dt + IF( zspeed_new < zspeed ) THEN + zuveln = zuveln * ( zspeed_new / zspeed ) ! Scale velocity to reduce speed + zvveln = zvveln * ( zspeed_new / zspeed ) ! without changing the direction + pax = (zuveln - puvel0)/pdt + pay = (zvveln - pvvel0)/pdt + ! + ! print speeding ticket + IF (nn_verbose_level > 0) THEN + WRITE(numicb, 9200) 'icb speeding : ',kt, nknberg, zspeed, & + & pxi, pyj, zuo, zvo, zua, zva, zui, zvi + 9200 FORMAT(a,i9,i6,f9.2,1x,4(1x,2f9.2)) + END IF + ! + CALL icb_dia_speed() + ENDIF + ENDIF + ENDIF + ! ! check the speed and acceleration limits + IF (nn_verbose_level > 0) THEN + IF( ABS( zuveln ) > pp_vel_lim .OR. ABS( zvveln ) > pp_vel_lim ) & + WRITE(numicb,'("pe=",i3,x,a)') narea,'Dump triggered by excessive velocity' + IF( ABS( pax ) > pp_accel_lim .OR. ABS( pay ) > pp_accel_lim ) & + WRITE(numicb,'("pe=",i3,x,a)') narea,'Dump triggered by excessive acceleration' + ENDIF + ! + END SUBROUTINE icb_accel + + !!====================================================================== +END MODULE icbdyn diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbini.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbini.f90 new file mode 100644 index 0000000000000000000000000000000000000000..12309c009ca5c42b16a30fe0a895903faf31fbe6 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbini.f90 @@ -0,0 +1,528 @@ + + + + + + + + + + + + + +MODULE icbini + !!====================================================================== + !! *** MODULE icbini *** + !! Icebergs: initialise variables for iceberg tracking + !!====================================================================== + !! History : - ! 2010-01 (T. Martin & A. Adcroft) Original code + !! 3.3 ! 2011-03 (G. Madec) Part conversion to NEMO form ; Removal of mapping from another grid + !! - ! 2011-04 (S. Alderson) Split into separate modules ; Restore restart routines + !! - ! 2011-05 (S. Alderson) generate_test_icebergs restored ; new forcing arrays with extra halo ; + !! - ! north fold exchange arrays added + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! icb_init : initialise icebergs + !! icb_ini_gen : generate test icebergs + !! icb_nam : read iceberg namelist + !!---------------------------------------------------------------------- + USE dom_oce ! ocean domain + USE in_out_manager ! IO routines and numout in particular + USE lib_mpp ! mpi library and lk_mpp in particular + USE sbc_oce ! ocean : surface boundary condition + USE sbc_ice ! sea-ice: surface boundary condition + USE iom ! IOM library + USE fldread ! field read + USE lbclnk ! lateral boundary condition - MPP link + ! + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + USE icbrst ! iceberg restart routines + USE icbtrj ! iceberg trajectory I/O routines + USE icbdia ! iceberg budget routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_init ! routine called in nemogcm.F90 module + + CHARACTER(len=100) :: cn_dir = './' !: Root directory for location of icb files + TYPE(FLD_N) :: sn_icb !: information about the calving file to be read + TYPE(FLD), PUBLIC, ALLOCATABLE , DIMENSION(:) :: sf_icb !: structure: file information, fields read + !: used in icbini and icbstp + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbini.F90 15372 2021-10-14 15:47:24Z davestorkey $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_init( pdt, kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_init *** + !! + !! ** Purpose : iceberg initialization. + !! + !! ** Method : - read the iceberg namelist + !! - find non-overlapping processor interior since we can only + !! have one instance of a particular iceberg + !! - calculate the destinations for north fold exchanges + !! - setup either test icebergs or calving file + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pdt ! iceberg time-step (rn_Dt*nn_fsbc) + INTEGER , INTENT(in) :: kt ! time step number + ! + INTEGER :: ji, jj, jn ! dummy loop indices + INTEGER :: i1, i2, i3 ! local integers + INTEGER :: ii, inum, ivar ! - - + INTEGER :: istat1, istat2, istat3 ! - - + CHARACTER(len=300) :: cl_sdist ! local character + !!---------------------------------------------------------------------- + ! + CALL icb_nam ! Read and print namelist parameters + ! + IF( .NOT. ln_icebergs ) RETURN + ! + ALLOCATE( utau_icb(jpi,jpj), vtau_icb(jpi,jpj) ) + ! + ! ! allocate gridded fields + IF( icb_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'icb_alloc : unable to allocate arrays' ) + ! + ! ! initialised variable with extra haloes to zero + ssu_e(:,:) = 0._wp ; ssv_e(:,:) = 0._wp ; + ua_e(:,:) = 0._wp ; va_e(:,:) = 0._wp ; + ff_e(:,:) = 0._wp ; sst_e(:,:) = 0._wp ; + fr_e(:,:) = 0._wp ; sss_e(:,:) = 0._wp ; + ! + IF ( ln_M2016 ) THEN + toce_e(:,:,:) = 0._wp + uoce_e(:,:,:) = 0._wp + voce_e(:,:,:) = 0._wp + e3t_e(:,:,:) = 0._wp + END IF + ! + ssh_e(:,:) = 0._wp ; + ! + ! ! open ascii output file or files for iceberg status information + ! ! note that we choose to do this on all processors since we cannot + ! ! predict where icebergs will be ahead of time + IF( nn_verbose_level > 0) THEN + CALL ctl_opn( numicb, 'icebergs.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + ENDIF + + ! set parameters (mostly from namelist) + ! + berg_dt = pdt + first_width (:) = SQRT( rn_initial_mass(:) / ( rn_LoW_ratio * rn_rho_bergs * rn_initial_thickness(:) ) ) + first_length(:) = rn_LoW_ratio * first_width(:) + rho_berg_1_oce = rn_rho_bergs / pp_rho_seawater ! scale factor used for convertion thickness to draft + ! + ! deepest level affected by icebergs + ! can be tuned but the safest is this + ! (with z* and z~ the depth of each level change overtime, so the more robust micbkb is jpk) + micbkb = jpk + + berg_grid%calving (:,:) = 0._wp + berg_grid%calving_hflx (:,:) = 0._wp + berg_grid%stored_heat (:,:) = 0._wp + berg_grid%floating_melt(:,:) = 0._wp + berg_grid%maxclass (:,:) = nclasses + berg_grid%stored_ice (:,:,:) = 0._wp + berg_grid%tmp (:,:) = 0._wp + src_calving (:,:) = 0._wp + src_calving_hflx (:,:) = 0._wp + + ! ! domain for icebergs + IF( lk_mpp .AND. jpni == 1 ) CALL ctl_stop( 'icbinit: having ONE processor in x currently does not work' ) + ! NB: the issue here is simply that cyclic east-west boundary condition have not been coded in mpp case + ! for the north fold we work out which points communicate by asking + ! lbc_lnk to pass processor number (valid even in single processor case) + ! borrow src_calving arrays for this + ! + ! pack i and j together using a scaling of a power of 10 + nicbpack = 10000 + IF( jpiglo >= nicbpack ) CALL ctl_stop( 'icbini: processor index packing failure' ) + nicbfldproc(:) = -1 + + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + src_calving_hflx(ji,jj) = narea + src_calving (ji,jj) = nicbpack * mjg(jj) + mig(ji) + END DO ; END DO + CALL lbc_lnk( 'icbini', src_calving_hflx, 'T', 1._wp ) + CALL lbc_lnk( 'icbini', src_calving , 'T', 1._wp ) + + ! work out interior of processor from exchange array + ! first entry with narea for this processor is left hand interior index + ! last entry is right hand interior index + jj = jpj/2 + nicbdi = -1 + nicbei = -1 + DO ji = 1, jpi + i3 = INT( src_calving(ji,jj) ) + i2 = INT( i3/nicbpack ) + i1 = i3 - i2*nicbpack + i3 = INT( src_calving_hflx(ji,jj) ) + IF( i1 == mig(ji) .AND. i3 == narea ) THEN + IF( nicbdi < 0 ) THEN ; nicbdi = ji + ELSE ; nicbei = ji + ENDIF + ENDIF + END DO + ! + ! repeat for j direction + ji = jpi/2 + nicbdj = -1 + nicbej = -1 + DO jj = 1, jpj + i3 = INT( src_calving(ji,jj) ) + i2 = INT( i3/nicbpack ) + i1 = i3 - i2*nicbpack + i3 = INT( src_calving_hflx(ji,jj) ) + IF( i2 == mjg(jj) .AND. i3 == narea ) THEN + IF( nicbdj < 0 ) THEN ; nicbdj = jj + ELSE ; nicbej = jj + ENDIF + ENDIF + END DO + ! + ! special for east-west boundary exchange we save the destination index + i1 = MAX( nicbdi-1, 1) + i3 = INT( src_calving(i1,jpj/2) ) + jj = INT( i3/nicbpack ) + ricb_left = REAL( i3 - nicbpack*jj, wp ) - (nn_hls-1) + i1 = MIN( nicbei+1, jpi ) + i3 = INT( src_calving(i1,jpj/2) ) + jj = INT( i3/nicbpack ) + ricb_right = REAL( i3 - nicbpack*jj, wp ) - (nn_hls-1) + + ! north fold + IF( l_IdoNFold ) THEN + ! + ! icebergs in row nicbej+1 get passed across fold + nicbfldpts(:) = INT( src_calving(:,nicbej+1) ) + nicbflddest(:) = INT( src_calving_hflx(:,nicbej+1) ) + ! + ! work out list of unique processors to talk to + ! pack them into a fixed size array where empty slots are marked by a -1 + DO ji = nicbdi, nicbei + ii = nicbflddest(ji) + IF( ii .GT. 0 ) THEN ! Needed because land suppression can mean + ! that unused points are not set in edge haloes + DO jn = 1, jpni + ! work along array until we find an empty slot + IF( nicbfldproc(jn) == -1 ) THEN + nicbfldproc(jn) = ii + EXIT !!gm EXIT should be avoided: use DO WHILE expression instead + ENDIF + ! before we find an empty slot, we may find processor number is already here so we exit + IF( nicbfldproc(jn) == ii ) EXIT + END DO + ENDIF + END DO + ENDIF + ! + IF( nn_verbose_level > 0) THEN + WRITE(numicb,*) 'processor ', narea + WRITE(numicb,*) 'jpi, jpj ', jpi, jpj + WRITE(numicb,*) 'Nis0, Nie0 ', Nis0, Nie0 + WRITE(numicb,*) 'Njs0, Nje0 ', Njs0, Nje0 + WRITE(numicb,*) 'berg i interior ', nicbdi, nicbei + WRITE(numicb,*) 'berg j interior ', nicbdj, nicbej + WRITE(numicb,*) 'berg left ', ricb_left + WRITE(numicb,*) 'berg right ', ricb_right + jj = jpj/2 + WRITE(numicb,*) "central j line:" + WRITE(numicb,*) "i processor" + WRITE(numicb,*) (INT(src_calving_hflx(ji,jj)), ji=1,jpi) + WRITE(numicb,*) "i point" + WRITE(numicb,*) (INT(src_calving(ji,jj)), ji=1,jpi) + ji = jpi/2 + WRITE(numicb,*) "central i line:" + WRITE(numicb,*) "j processor" + WRITE(numicb,*) (INT(src_calving_hflx(ji,jj)), jj=1,jpj) + WRITE(numicb,*) "j point" + WRITE(numicb,*) (INT(src_calving(ji,jj)), jj=1,jpj) + IF( l_IdoNFold ) THEN + WRITE(numicb,*) 'north fold destination points ' + WRITE(numicb,*) nicbfldpts + WRITE(numicb,*) 'north fold destination procs ' + WRITE(numicb,*) nicbflddest + WRITE(numicb,*) 'north fold destination proclist ' + WRITE(numicb,*) nicbfldproc + ENDIF + CALL flush(numicb) + ENDIF + + src_calving (:,:) = 0._wp + src_calving_hflx(:,:) = 0._wp + + ! definition of extended surface masked needed by icb_bilin_h + tmask_e(:,:) = 0._wp ; tmask_e(1:jpi,1:jpj) = tmask(:,:,1) + umask_e(:,:) = 0._wp ; umask_e(1:jpi,1:jpj) = umask(:,:,1) + vmask_e(:,:) = 0._wp ; vmask_e(1:jpi,1:jpj) = vmask(:,:,1) + CALL lbc_lnk_icb( 'icbini', tmask_e, 'T', +1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbini', umask_e, 'U', +1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbini', vmask_e, 'V', +1._wp, 1, 1 ) + + ! definition of extended lat/lon array needed by icb_bilin_h + rlon_e(:,:) = 0._wp ; rlon_e(1:jpi,1:jpj) = glamt(:,:) + rlat_e(:,:) = 0._wp ; rlat_e(1:jpi,1:jpj) = gphit(:,:) + CALL lbc_lnk_icb( 'icbini', rlon_e, 'T', +1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbini', rlat_e, 'T', +1._wp, 1, 1 ) + ! + ! definnitionn of extennded ff_f array needed by icb_utl_interp + ff_e(:,:) = 0._wp ; ff_e(1:jpi,1:jpj) = ff_f(:,:) + CALL lbc_lnk_icb( 'icbini', ff_e, 'F', +1._wp, 1, 1 ) + + ! assign each new iceberg with a unique number constructed from the processor number + ! and incremented by the total number of processors + num_bergs(:) = 0 + num_bergs(1) = narea - jpnij + + ! when not generating test icebergs we need to setup calving file + IF( nn_test_icebergs < 0 .OR. ln_use_calving ) THEN + ! + ! maximum distribution class array does not change in time so read it once + cl_sdist = TRIM( cn_dir )//TRIM( sn_icb%clname ) + CALL iom_open ( cl_sdist, inum ) ! open file + ivar = iom_varid( inum, 'maxclass', ldstop=.FALSE. ) + IF( ivar > 0 ) THEN + CALL iom_get ( inum, jpdom_global, 'maxclass', src_calving ) ! read the max distribution array + berg_grid%maxclass(:,:) = INT( src_calving ) + src_calving(:,:) = 0._wp + ENDIF + CALL iom_close( inum ) ! close file + ! + IF( nn_verbose_level > 0) THEN + WRITE(numicb,*) + WRITE(numicb,*) ' calving read in a file' + ENDIF + ALLOCATE( sf_icb(1), STAT=istat1 ) ! Create sf_icb structure (calving) + ALLOCATE( sf_icb(1)%fnow(jpi,jpj,1), STAT=istat2 ) + ALLOCATE( sf_icb(1)%fdta(jpi,jpj,1,2), STAT=istat3 ) + IF( istat1+istat2+istat3 > 0 ) THEN + CALL ctl_stop( 'sbc_icb: unable to allocate sf_icb structure' ) ; RETURN + ENDIF + ! ! fill sf_icb with the namelist (sn_icb) and control print + CALL fld_fill( sf_icb, (/ sn_icb /), cn_dir, 'icb_init', 'read calving data', 'namicb' ) + ! + ENDIF + + IF( .NOT.ln_rstart ) THEN + IF( nn_test_icebergs > 0 ) CALL icb_ini_gen() + ELSE + IF( nn_test_icebergs > 0 ) THEN + CALL icb_ini_gen() + ELSE + CALL icb_rst_read() + l_restarted_bergs = .TRUE. + ENDIF + ENDIF + ! + IF( nn_sample_rate .GT. 0 ) CALL icb_trj_init( nitend ) + ! + CALL icb_dia_init() + ! + IF( nn_verbose_level >= 2 ) CALL icb_utl_print('icb_init, initial status', nit000-1) + ! + END SUBROUTINE icb_init + + + SUBROUTINE icb_ini_gen() + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_ini_gen *** + !! + !! ** Purpose : iceberg generation + !! + !! ** Method : - at each grid point of the test box supplied in the namelist + !! generate an iceberg in one class determined by the value of + !! parameter nn_test_icebergs + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, ibergs + TYPE(iceberg) :: localberg ! NOT a pointer but an actual local variable + TYPE(point) :: localpt + INTEGER :: iyr, imon, iday, ihr, imin, isec + INTEGER :: iberg + !!---------------------------------------------------------------------- + + ! For convenience + iberg = nn_test_icebergs + + ! call get_date(Time, iyr, imon, iday, ihr, imin, isec) + ! Convert nemo time variables from dom_oce into local versions + iyr = nyear + imon = nmonth + iday = nday + ihr = INT(nsec_day/3600) + imin = INT((nsec_day-ihr*3600)/60) + isec = nsec_day - ihr*3600 - imin*60 + + ! no overlap for icebergs since we want only one instance of each across the whole domain + ! so restrict area of interest + ! use tmask here because tmask_i has been doctored on one side of the north fold line + + DO jj = nicbdj, nicbej + DO ji = nicbdi, nicbei + IF( tmask(ji,jj,1) > 0._wp .AND. & + rn_test_box(1) < glamt(ji,jj) .AND. glamt(ji,jj) < rn_test_box(2) .AND. & + rn_test_box(3) < gphit(ji,jj) .AND. gphit(ji,jj) < rn_test_box(4) ) THEN + localberg%mass_scaling = rn_mass_scaling(iberg) + localpt%xi = REAL( mig(ji) - (nn_hls-1), wp ) + localpt%yj = REAL( mjg(jj) - (nn_hls-1), wp ) + CALL icb_utl_interp( localpt%xi, localpt%yj, plat=localpt%lat, plon=localpt%lon ) + localpt%mass = rn_initial_mass (iberg) + localpt%thickness = rn_initial_thickness(iberg) + localpt%width = first_width (iberg) + localpt%length = first_length(iberg) + localpt%year = iyr + localpt%day = REAL(iday,wp)+(REAL(ihr,wp)+REAL(imin,wp)/60._wp)/24._wp + localpt%mass_of_bits = 0._wp + localpt%heat_density = 0._wp + localpt%uvel = 0._wp + localpt%vvel = 0._wp + localpt%kb = 1 + CALL icb_utl_incr() + localberg%number(:) = num_bergs(:) + call icb_utl_add(localberg, localpt) + ENDIF + END DO + END DO + ! + ibergs = icb_utl_count() + CALL mpp_sum('icbini', ibergs) + IF( nn_verbose_level > 0) THEN + WRITE(numicb,'(a,i6,a)') 'diamonds, icb_ini_gen: ',ibergs,' were generated' + ENDIF + ! + END SUBROUTINE icb_ini_gen + + + SUBROUTINE icb_nam + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_nam *** + !! + !! ** Purpose : read iceberg namelist and print the variables. + !! + !! ** input : - namberg namelist + !!---------------------------------------------------------------------- + INTEGER :: jn ! dummy loop indices + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp) :: zfact ! local scalar + ! + NAMELIST/namberg/ ln_icebergs , ln_bergdia , nn_sample_rate , rn_initial_mass , & + & rn_distribution, rn_mass_scaling, rn_initial_thickness, nn_verbose_write , & + & rn_rho_bergs , rn_LoW_ratio , nn_verbose_level , ln_operator_splitting, & + & rn_bits_erosion_fraction , rn_sicn_shift , ln_passive_mode , & + & ln_time_average_weight , nn_test_icebergs , rn_test_box , & + & ln_use_calving , rn_speed_limit , cn_dir, sn_icb , ln_M2016 , & + & cn_icbrst_indir, cn_icbrst_in , cn_icbrst_outdir , cn_icbrst_out , & + & ln_icb_grd + !!---------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'icb_nam : iceberg initialization through namberg namelist read' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF + ! !== read namelist ==! + READ ( numnam_ref, namberg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namberg in reference namelist' ) + READ ( numnam_cfg, namberg, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namberg in configuration namelist' ) + IF(lwm) WRITE ( numond, namberg ) + ! + IF(lwp) WRITE(numout,*) + IF( ln_icebergs ) THEN + IF(lwp) WRITE(numout,*) ' ==>>> icebergs are used' + ELSE + IF(lwp) WRITE(numout,*) ' ==>>> No icebergs used' + RETURN + ENDIF + ! + IF( nn_test_icebergs > nclasses ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> Resetting of nn_test_icebergs to ', nclasses + nn_test_icebergs = nclasses + ENDIF + ! + IF( nn_test_icebergs < 0 .AND. .NOT. ln_use_calving ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> Resetting ln_use_calving to .true. since we are not using test icebergs' + ln_use_calving = .true. + ENDIF + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'icb_nam : iceberg initialization through namberg namelist read' + WRITE(numout,*) '~~~~~~~~ ' + WRITE(numout,*) ' Calculate budgets ln_bergdia = ', ln_bergdia + WRITE(numout,*) ' Period between sampling of position for trajectory storage nn_sample_rate = ', nn_sample_rate + WRITE(numout,*) ' Mass thresholds between iceberg classes (kg) rn_initial_mass =' + DO jn = 1, nclasses + WRITE(numout,'(a,f15.2)') ' ', rn_initial_mass(jn) + ENDDO + WRITE(numout,*) ' Fraction of calving to apply to this class (non-dim) rn_distribution =' + DO jn = 1, nclasses + WRITE(numout,'(a,f10.4)') ' ', rn_distribution(jn) + END DO + WRITE(numout,*) ' Ratio between effective and real iceberg mass (non-dim) rn_mass_scaling = ' + DO jn = 1, nclasses + WRITE(numout,'(a,f10.2)') ' ', rn_mass_scaling(jn) + END DO + WRITE(numout,*) ' Total thickness of newly calved bergs (m) rn_initial_thickness = ' + DO jn = 1, nclasses + WRITE(numout,'(a,f10.2)') ' ', rn_initial_thickness(jn) + END DO + WRITE(numout,*) ' Timesteps between verbose messages nn_verbose_write = ', nn_verbose_write + + WRITE(numout,*) ' Density of icebergs rn_rho_bergs = ', rn_rho_bergs + WRITE(numout,*) ' Initial ratio L/W for newly calved icebergs rn_LoW_ratio = ', rn_LoW_ratio + WRITE(numout,*) ' Turn on more verbose output level = ', nn_verbose_level + WRITE(numout,*) ' Use first order operator splitting for thermodynamics ', & + & 'use_operator_splitting = ', ln_operator_splitting + WRITE(numout,*) ' Fraction of erosion melt flux to divert to bergy bits ', & + & 'bits_erosion_fraction = ', rn_bits_erosion_fraction + + WRITE(numout,*) ' Use icb module modification from Merino et al. (2016) : ln_M2016 = ', ln_M2016 + WRITE(numout,*) ' ground icebergs if icb bottom lvl hit the oce bottom level : ln_icb_grd = ', ln_icb_grd + + WRITE(numout,*) ' Shift of sea-ice concentration in erosion flux modulation ', & + & '(0 0 ln_use_calving = ', ln_use_calving + WRITE(numout,*) ' CFL speed limit for a berg speed_limit = ', rn_speed_limit + WRITE(numout,*) ' Writing Iceberg status information to icebergs.stat file ' + ENDIF + ! + ! ensure that the sum of berg input distribution is equal to one + zfact = SUM( rn_distribution ) + IF( zfact /= 1._wp .AND. 0_wp /= zfact ) THEN + rn_distribution(:) = rn_distribution(:) / zfact + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> CAUTION: sum of berg input distribution = ', zfact + WRITE(numout,*) ' ******* redistribution has been rescaled' + WRITE(numout,*) ' updated berg distribution is :' + DO jn = 1, nclasses + WRITE(numout,'(a,f10.4)') ' ',rn_distribution(jn) + END DO + ENDIF + ENDIF + IF( MINVAL( rn_distribution(:) ) < 0._wp ) THEN + CALL ctl_stop( 'icb_nam: a negative rn_distribution value encountered ==>> change your namelist namberg' ) + ENDIF + ! + END SUBROUTINE icb_nam + + !!====================================================================== +END MODULE icbini diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icblbc.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icblbc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..626f107867729b66d75d18980ce651329e771481 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icblbc.f90 @@ -0,0 +1,833 @@ + + + + + + + + + + + + + +MODULE icblbc + !!====================================================================== + !! *** MODULE icblbc *** + !! Ocean physics: routines to handle boundary exchanges for icebergs + !!====================================================================== + !! History : 3.3 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) MPP exchanges written based on lib_mpp + !! - ! 2011-05 (Alderson) MPP and single processor boundary conditions added + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_lbc : - Pass icebergs across cyclic boundaries + !! icb_lbc_mpp : - In MPP pass icebergs from linked list between processors + !! as they advect around + !! - Lagrangian processes cannot be handled by existing NEMO MPP + !! routines because they do not lie on regular jpi,jpj grids + !! - Processor exchanges are handled as in lib_mpp whenever icebergs step + !! across boundary of interior domain (nicbdi-nicbei, nicbdj-nicbej) + !! so that iceberg does not exist in more than one processor + !! - North fold exchanges controlled by three arrays: + !! nicbflddest - unique processor numbers that current one exchanges with + !! nicbfldproc - processor number that current grid point exchanges with + !! nicbfldpts - packed i,j point in exchanging processor + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE dom_oce ! ocean domain + USE in_out_manager ! IO parameters + USE lib_mpp ! MPI code and lk_mpp in particular + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + + IMPLICIT NONE + PRIVATE + + +!$AGRIF_DO_NOT_TREAT + INCLUDE 'mpif.h' +!$AGRIF_END_DO_NOT_TREAT + + TYPE, PUBLIC :: buffer + INTEGER :: size = 0 + REAL(wp), DIMENSION(:,:), POINTER :: data + END TYPE buffer + + TYPE(buffer), POINTER :: obuffer_n=>NULL() , ibuffer_n=>NULL() + TYPE(buffer), POINTER :: obuffer_s=>NULL() , ibuffer_s=>NULL() + TYPE(buffer), POINTER :: obuffer_e=>NULL() , ibuffer_e=>NULL() + TYPE(buffer), POINTER :: obuffer_w=>NULL() , ibuffer_w=>NULL() + + ! north fold exchange buffers + TYPE(buffer), POINTER :: obuffer_f=>NULL() , ibuffer_f=>NULL() + + INTEGER, PARAMETER, PRIVATE :: jp_delta_buf = 25 ! Size by which to increment buffers + INTEGER, PARAMETER, PRIVATE :: jp_buffer_width = 15+nkounts ! items to store for each berg + + + PUBLIC icb_lbc + PUBLIC icb_lbc_mpp + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icblbc.F90 15088 2021-07-06 13:03:34Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_lbc() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_lbc *** + !! + !! ** Purpose : in non-mpp case need to deal with cyclic conditions + !! including north-fold + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: this + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + + !! periodic east/west boundaries + !! ============================= + + IF( l_Iperio ) THEN + + this => first_berg + DO WHILE( ASSOCIATED(this) ) + pt => this%current_point + IF( pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN + pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp + ELSE IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN + pt%xi = ricb_left + MOD(pt%xi, 1._wp ) + ENDIF + this => this%next + END DO + ! + ENDIF + + !! north/south boundaries + !! ====================== + IF( l_Jperio) CALL ctl_stop(' north-south periodicity not implemented for icebergs') + ! north fold + IF( l_IdoNFold ) CALL icb_lbc_nfld() + ! + END SUBROUTINE icb_lbc + + + SUBROUTINE icb_lbc_nfld() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_lbc_nfld *** + !! + !! ** Purpose : single processor north fold exchange + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: this + TYPE(point) , POINTER :: pt + INTEGER :: iine, ijne, ipts + INTEGER :: iiglo, ijglo + !!---------------------------------------------------------------------- + ! + this => first_berg + DO WHILE( ASSOCIATED(this) ) + pt => this%current_point + ijne = INT( pt%yj + 0.5 ) + IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN + ! + iine = INT( pt%xi + 0.5 ) + ipts = nicbfldpts (mi1(iine)) + ! + ! moving across the cut line means both position and + ! velocity must change + ijglo = INT( ipts/nicbpack ) + iiglo = ipts - nicbpack*ijglo + pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) + pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) + pt%uvel = -1._wp * pt%uvel + pt%vvel = -1._wp * pt%vvel + ENDIF + this => this%next + END DO + ! + END SUBROUTINE icb_lbc_nfld + + !!---------------------------------------------------------------------- + !! MPI massively parallel processing library + !!---------------------------------------------------------------------- + + SUBROUTINE icb_lbc_mpp() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_lbc_mpp *** + !! + !! ** Purpose : multi processor exchange + !! + !! ** Method : identify direction for exchange, pack into a buffer + !! which is basically a real array and delete from linked list + !! length of buffer is exchanged first with receiving processor + !! then buffer is sent if necessary + !!---------------------------------------------------------------------- + TYPE(iceberg) , POINTER :: tmpberg, this + TYPE(point) , POINTER :: pt + INTEGER :: ibergs_to_send_e, ibergs_to_send_w + INTEGER :: ibergs_to_send_n, ibergs_to_send_s + INTEGER :: ibergs_rcvd_from_e, ibergs_rcvd_from_w + INTEGER :: ibergs_rcvd_from_n, ibergs_rcvd_from_s + INTEGER :: i, ibergs_start, ibergs_end + INTEGER :: ipe_N, ipe_S, ipe_W, ipe_E + REAL(wp), DIMENSION(2) :: zewbergs, zwebergs, znsbergs, zsnbergs + INTEGER :: iml_req1, iml_req2, iml_req3, iml_req4 + INTEGER :: iml_req5, iml_req6, iml_req7, iml_req8, iml_err + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat + + ! set up indices of neighbouring processors + ipe_N = -1 + ipe_S = -1 + ipe_W = -1 + ipe_E = -1 + IF( mpinei(jpwe) >= 0 ) ipe_W = mpinei(jpwe) + IF( mpinei(jpea) >= 0 ) ipe_E = mpinei(jpea) + IF( mpinei(jpso) >= 0 ) ipe_S = mpinei(jpso) + IF( mpinei(jpno) >= 0 ) ipe_N = mpinei(jpno) + ! + ! at northern line of processors with north fold handle bergs differently + IF( l_IdoNFold ) ipe_N = -1 + + ! if there's only one processor in x direction then don't let mpp try to handle periodicity + IF( jpni == 1 ) THEN + ipe_E = -1 + ipe_W = -1 + ENDIF + + IF( nn_verbose_level >= 2 ) THEN + WRITE(numicb,*) 'processor west : ', ipe_W + WRITE(numicb,*) 'processor east : ', ipe_E + WRITE(numicb,*) 'processor north : ', ipe_N + WRITE(numicb,*) 'processor south : ', ipe_S + WRITE(numicb,*) 'processor nimpp : ', nimpp + WRITE(numicb,*) 'processor njmpp : ', njmpp + CALL flush( numicb ) + ENDIF + + ! periodicity is handled here when using mpp when there is more than one processor in + ! the i direction, but it also has to happen when jpni=1 case so this is dealt with + ! in icb_lbc and called here + + IF( jpni == 1 ) CALL icb_lbc() + + ! Note that xi is adjusted when swapping because of periodic condition + + IF( nn_verbose_level > 0 ) THEN + ! store the number of icebergs on this processor at start + ibergs_start = icb_utl_count() + ENDIF + + ibergs_to_send_e = 0 + ibergs_to_send_w = 0 + ibergs_to_send_n = 0 + ibergs_to_send_s = 0 + ibergs_rcvd_from_e = 0 + ibergs_rcvd_from_w = 0 + ibergs_rcvd_from_n = 0 + ibergs_rcvd_from_s = 0 + + IF( ASSOCIATED(first_berg) ) THEN ! Find number of bergs that headed east/west + this => first_berg + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei),wp) + 0.5_wp - (nn_hls-1) ) THEN + tmpberg => this + this => this%next + ibergs_to_send_e = ibergs_to_send_e + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to east' + CALL flush( numicb ) + ENDIF + ! deal with periodic case + tmpberg%current_point%xi = ricb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp + ! now pack it into buffer and delete from list + CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e) + CALL icb_utl_delete(first_berg, tmpberg) + ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp - (nn_hls-1) ) THEN + tmpberg => this + this => this%next + ibergs_to_send_w = ibergs_to_send_w + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to west' + CALL flush( numicb ) + ENDIF + ! deal with periodic case + tmpberg%current_point%xi = ricb_left + MOD(tmpberg%current_point%xi, 1._wp ) + ! now pack it into buffer and delete from list + CALL icb_pack_into_buffer( tmpberg, obuffer_w, ibergs_to_send_w) + CALL icb_utl_delete(first_berg, tmpberg) + ELSE + this => this%next + ENDIF + END DO + ENDIF + IF( nn_verbose_level >= 3) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' send ew: ', ibergs_to_send_e, ibergs_to_send_w + CALL flush(numicb) + ENDIF + + ! send bergs east and receive bergs from west (ie ones that were sent east) and vice versa + + ! pattern here is copied from lib_mpp code + + IF( mpinei(jpwe) >= 0 ) zewbergs(1) = ibergs_to_send_w + IF( mpinei(jpea) >= 0 ) zwebergs(1) = ibergs_to_send_e + IF( mpinei(jpwe) >= 0 ) CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) + IF( mpinei(jpea) >= 0 ) CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) + IF( mpinei(jpea) >= 0 ) CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) + IF( mpinei(jpwe) >= 0 ) CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) + IF( mpinei(jpwe) >= 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) + IF( mpinei(jpea) >= 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) + IF( mpinei(jpea) >= 0 ) ibergs_rcvd_from_e = INT( zewbergs(2) ) + IF( mpinei(jpwe) >= 0 ) ibergs_rcvd_from_w = INT( zwebergs(2) ) + + IF( nn_verbose_level >= 3) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e + CALL flush(numicb) + ENDIF + + IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 ) + IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 ) + IF( ibergs_rcvd_from_e > 0 ) THEN + CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) + CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) + ENDIF + IF( ibergs_rcvd_from_w > 0 ) THEN + CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) + CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) + ENDIF + IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) + IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) + DO i = 1, ibergs_rcvd_from_e + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' + CALL FLUSH( numicb ) + ENDIF + CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) + END DO + DO i = 1, ibergs_rcvd_from_w + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' + CALL FLUSH( numicb ) + ENDIF + CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) + END DO + + ! Find number of bergs that headed north/south + ! (note: this block should technically go ahead of the E/W recv block above + ! to handle arbitrary orientation of PEs. But for simplicity, it is + ! here to accomodate diagonal transfer of bergs between PEs -AJA) + + IF( ASSOCIATED(first_berg) ) THEN + this => first_berg + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN + tmpberg => this + this => this%next + ibergs_to_send_n = ibergs_to_send_n + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to north' + CALL flush( numicb ) + ENDIF + CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n) + CALL icb_utl_delete(first_berg, tmpberg) + ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp - (nn_hls-1) ) THEN + tmpberg => this + this => this%next + ibergs_to_send_s = ibergs_to_send_s + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to south' + CALL flush( numicb ) + ENDIF + CALL icb_pack_into_buffer( tmpberg, obuffer_s, ibergs_to_send_s) + CALL icb_utl_delete(first_berg, tmpberg) + ELSE + this => this%next + ENDIF + END DO + ENDIF + if( nn_verbose_level >= 3) then + write(numicb,*) 'bergstep ',nktberg,' send ns: ', ibergs_to_send_n, ibergs_to_send_s + call flush(numicb) + endif + + ! send bergs north + ! and receive bergs from south (ie ones sent north) + + IF( mpinei(jpso) >= 0 ) znsbergs(1) = ibergs_to_send_s + IF( mpinei(jpno) >= 0 ) zsnbergs(1) = ibergs_to_send_n + IF( mpinei(jpso) >= 0 ) CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) + IF( mpinei(jpno) >= 0 ) CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) + IF( mpinei(jpno) >= 0 ) CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) + IF( mpinei(jpso) >= 0 ) CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) + IF( mpinei(jpso) >= 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) + IF( mpinei(jpno) >= 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) + IF( mpinei(jpno) >= 0 ) ibergs_rcvd_from_n = INT( znsbergs(2) ) + IF( mpinei(jpso) >= 0 ) ibergs_rcvd_from_s = INT( zsnbergs(2) ) + + IF( nn_verbose_level >= 3) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n + CALL FLUSH(numicb) + ENDIF + + IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 ) + IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 ) + IF( ibergs_rcvd_from_n > 0 ) THEN + CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) + CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) + ENDIF + IF( ibergs_rcvd_from_s > 0 ) THEN + CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) + CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) + ENDIF + IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) + IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) + DO i = 1, ibergs_rcvd_from_n + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' + CALL FLUSH( numicb ) + ENDIF + CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) + END DO + DO i = 1, ibergs_rcvd_from_s + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' + CALL FLUSH( numicb ) + ENDIF + CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) + END DO + + IF( nn_verbose_level > 0 ) THEN + ! compare the number of icebergs on this processor from the start to the end + ibergs_end = icb_utl_count() + i = ( ibergs_rcvd_from_n + ibergs_rcvd_from_s + ibergs_rcvd_from_e + ibergs_rcvd_from_w ) - & + ( ibergs_to_send_n + ibergs_to_send_s + ibergs_to_send_e + ibergs_to_send_w ) + IF( ibergs_end-(ibergs_start+i) .NE. 0 ) THEN + WRITE( numicb,* ) 'send_bergs_to_other_pes: net change in number of icebergs' + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_end=', & + ibergs_end,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_start=', & + ibergs_start,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: delta=', & + i,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: error=', & + ibergs_end-(ibergs_start+i),' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_n=', & + ibergs_to_send_n,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_s=', & + ibergs_to_send_s,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_e=', & + ibergs_to_send_e,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_w=', & + ibergs_to_send_w,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_n=', & + ibergs_rcvd_from_n,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_s=', & + ibergs_rcvd_from_s,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_e=', & + ibergs_rcvd_from_e,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_w=', & + ibergs_rcvd_from_w,' on PE',narea + 1000 FORMAT(a,i5,a,i4) + CALL ctl_stop('send_bergs_to_other_pes: lost or gained an iceberg or two') + ENDIF + ENDIF + + ! deal with north fold if we necessary when there is more than one top row processor + ! note that for jpni=1 north fold has been dealt with above in call to icb_lbc + IF( l_IdoNFold .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( ) + + IF( nn_verbose_level > 0 ) THEN + i = 0 + this => first_berg + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp - (nn_hls-1) .OR. & + pt%xi > REAL(mig(nicbei),wp) + 0.5_wp - (nn_hls-1) .OR. & + pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp - (nn_hls-1) .OR. & + pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN + i = i + 1 + WRITE(numicb,*) 'berg lost in halo: ', this%number(:) + WRITE(numicb,*) ' ', nimpp, njmpp + WRITE(numicb,*) ' ', nicbdi, nicbei, nicbdj, nicbej + CALL flush( numicb ) + ENDIF + this => this%next + ENDDO ! WHILE + CALL mpp_sum('icblbc', i) + IF( i .GT. 0 ) THEN + WRITE( numicb,'(a,i4)') 'send_bergs_to_other_pes: # of bergs outside computational domain = ',i + CALL ctl_stop('send_bergs_to_other_pes: there are bergs still in halos!') + ENDIF ! root_pe + ENDIF ! debug + ! + CALL mppsync() + ! + END SUBROUTINE icb_lbc_mpp + + + SUBROUTINE icb_lbc_mpp_nfld() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_lbc_mpp_nfld *** + !! + !! ** Purpose : north fold treatment in multi processor exchange + !! + !! ** Method : + !!---------------------------------------------------------------------- + TYPE(iceberg) , POINTER :: tmpberg, this + TYPE(point) , POINTER :: pt + INTEGER :: ibergs_to_send + INTEGER :: ibergs_to_rcv + INTEGER :: iiglo, ijglo, jk, jn + INTEGER :: ifldproc, iproc, ipts + INTEGER :: iine, ijne + INTEGER :: jjn + REAL(wp), DIMENSION(0:3) :: zsbergs, znbergs + INTEGER :: iml_req1, iml_req2, iml_err + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat + + ! set up indices of neighbouring processors + + ! nicbfldproc is a list of unique processor numbers that this processor + ! exchanges with (including itself), so we loop over this array; since + ! its of fixed size, the first -1 marks end of list of processors + ! + nicbfldnsend(:) = 0 + nicbfldexpect(:) = 0 + nicbfldreq(:) = 0 + ! + ! Since each processor may be communicating with more than one northern + ! neighbour, cycle through the sends so that the receive order can be + ! controlled. + ! + ! First compute how many icebergs each active neighbour should expect + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + nicbfldnsend(jn) = 0 + + ! Find number of bergs that need to be exchanged + ! Pick out exchanges with processor ifldproc + ! if ifldproc is this processor then don't send + ! + IF( ASSOCIATED(first_berg) ) THEN + this => first_berg + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + iine = INT( pt%xi + 0.5 ) + (nn_hls-1) + iproc = nicbflddest(mi1(iine)) + IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN + IF( iproc == ifldproc ) THEN + ! + IF( iproc /= narea ) THEN + tmpberg => this + nicbfldnsend(jn) = nicbfldnsend(jn) + 1 + ENDIF + ! + ENDIF + ENDIF + this => this%next + END DO + ENDIF + ! + ENDIF + ! + END DO + ! + ! Now tell each active neighbour how many icebergs to expect + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + IF( ifldproc == narea ) CYCLE + + zsbergs(0) = narea + zsbergs(1) = nicbfldnsend(jn) + !IF ( nicbfldnsend(jn) .GT. 0 .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc + CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn)) + ENDIF + ! + END DO + ! + ! and receive the heads-up from active neighbours preparing to send + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + IF( ifldproc == narea ) CYCLE + + CALL mpprecv( 21, znbergs(1:2), 2 ) + DO jjn = 1,jpni + IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT + END DO + IF( jjn .GT. jpni .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB ERROR' + nicbfldexpect(jjn) = INT( znbergs(2) ) + !IF ( nicbfldexpect(jjn) .GT. 0 .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn) + !IF (nn_verbose_level > 0) CALL FLUSH(numicb) + ENDIF + ! + END DO + ! + ! post the mpi waits if using immediate send protocol + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + IF( ifldproc == narea ) CYCLE + CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) + ENDIF + ! + END DO + + ! + ! Cycle through the icebergs again, this time packing and sending any + ! going through the north fold. They will be expected. + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + ibergs_to_send = 0 + + ! Find number of bergs that need to be exchanged + ! Pick out exchanges with processor ifldproc + ! if ifldproc is this processor then don't send + ! + IF( ASSOCIATED(first_berg) ) THEN + this => first_berg + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + iine = INT( pt%xi + 0.5 ) + (nn_hls-1) + ijne = INT( pt%yj + 0.5 ) + (nn_hls-1) + ipts = nicbfldpts (mi1(iine)) + iproc = nicbflddest(mi1(iine)) + IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN + IF( iproc == ifldproc ) THEN + ! + ! moving across the cut line means both position and + ! velocity must change + ijglo = INT( ipts/nicbpack ) + iiglo = ipts - nicbpack*ijglo + pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) + pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) + pt%uvel = -1._wp * pt%uvel + pt%vvel = -1._wp * pt%vvel + ! + ! now remove berg from list and pack it into a buffer + IF( iproc /= narea ) THEN + tmpberg => this + ibergs_to_send = ibergs_to_send + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold' + CALL flush( numicb ) + ENDIF + CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send) + CALL icb_utl_delete(first_berg, tmpberg) + ENDIF + ! + ENDIF + ENDIF + this => this%next + END DO + ENDIF + if( nn_verbose_level >= 3) then + write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send + call flush(numicb) + endif + ! + ! if we're in this processor, then we've done everything we need to + ! so go on to next element of loop + IF( ifldproc == narea ) CYCLE + + ! send bergs + + IF( ibergs_to_send > 0 ) & + CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) ) + ! + ENDIF + ! + END DO + ! + ! Now receive the expected number of bergs from the active neighbours + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + IF( ifldproc == narea ) CYCLE + ibergs_to_rcv = nicbfldexpect(jn) + + IF( ibergs_to_rcv > 0 ) THEN + CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv) + CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 ) + ENDIF + ! + DO jk = 1, ibergs_to_rcv + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold' + CALL flush( numicb ) + ENDIF + CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk ) + END DO + ENDIF + ! + END DO + ! + ! Finally post the mpi waits if using immediate send protocol + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + IF( ifldproc == narea ) CYCLE + CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) + ENDIF + ! + END DO + ! + END SUBROUTINE icb_lbc_mpp_nfld + + + SUBROUTINE icb_pack_into_buffer( berg, pbuff, kb ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: berg + TYPE(buffer) , POINTER :: pbuff + INTEGER , INTENT(in) :: kb + ! + INTEGER :: k ! local integer + !!---------------------------------------------------------------------- + ! + IF( .NOT. ASSOCIATED(pbuff) ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) + IF( kb .GT. pbuff%size ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) + + !! pack points into buffer + + pbuff%data( 1,kb) = berg%current_point%lon + pbuff%data( 2,kb) = berg%current_point%lat + pbuff%data( 3,kb) = berg%current_point%uvel + pbuff%data( 4,kb) = berg%current_point%vvel + pbuff%data( 5,kb) = berg%current_point%xi + pbuff%data( 6,kb) = berg%current_point%yj + pbuff%data( 7,kb) = float(berg%current_point%year) + pbuff%data( 8,kb) = berg%current_point%day + pbuff%data( 9,kb) = berg%current_point%mass + pbuff%data(10,kb) = berg%current_point%thickness + pbuff%data(11,kb) = berg%current_point%width + pbuff%data(12,kb) = berg%current_point%length + pbuff%data(13,kb) = berg%current_point%mass_of_bits + pbuff%data(14,kb) = berg%current_point%heat_density + + pbuff%data(15,kb) = berg%mass_scaling + DO k=1,nkounts + pbuff%data(15+k,kb) = REAL( berg%number(k), wp ) + END DO + ! + END SUBROUTINE icb_pack_into_buffer + + + SUBROUTINE icb_unpack_from_buffer(first, pbuff, kb) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: first + TYPE(buffer) , POINTER :: pbuff + INTEGER , INTENT(in) :: kb + ! + TYPE(iceberg) :: currentberg + TYPE(point) :: pt + INTEGER :: ik + !!---------------------------------------------------------------------- + ! + pt%lon = pbuff%data( 1,kb) + pt%lat = pbuff%data( 2,kb) + pt%uvel = pbuff%data( 3,kb) + pt%vvel = pbuff%data( 4,kb) + pt%xi = pbuff%data( 5,kb) + pt%yj = pbuff%data( 6,kb) + pt%year = INT( pbuff%data( 7,kb) ) + pt%day = pbuff%data( 8,kb) + pt%mass = pbuff%data( 9,kb) + pt%thickness = pbuff%data(10,kb) + pt%width = pbuff%data(11,kb) + pt%length = pbuff%data(12,kb) + pt%mass_of_bits = pbuff%data(13,kb) + pt%heat_density = pbuff%data(14,kb) + + currentberg%mass_scaling = pbuff%data(15,kb) + DO ik = 1, nkounts + currentberg%number(ik) = INT( pbuff%data(15+ik,kb) ) + END DO + ! + CALL icb_utl_add(currentberg, pt ) + ! + END SUBROUTINE icb_unpack_from_buffer + + + SUBROUTINE icb_increase_buffer(old,kdelta) + !!---------------------------------------------------------------------- + TYPE(buffer), POINTER :: old + INTEGER , INTENT(in) :: kdelta + ! + TYPE(buffer), POINTER :: new + INTEGER :: inew_size + !!---------------------------------------------------------------------- + ! + IF( .NOT. ASSOCIATED(old) ) THEN ; inew_size = kdelta + ELSE ; inew_size = old%size + kdelta + ENDIF + ALLOCATE( new ) + ALLOCATE( new%data( jp_buffer_width, inew_size) ) + new%size = inew_size + IF( ASSOCIATED(old) ) THEN + new%data(:,1:old%size) = old%data(:,1:old%size) + DEALLOCATE(old%data) + DEALLOCATE(old) + ENDIF + old => new + ! + END SUBROUTINE icb_increase_buffer + + + SUBROUTINE icb_increase_ibuffer(old,kdelta) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + TYPE(buffer), POINTER :: old + INTEGER , INTENT(in) :: kdelta + ! + TYPE(buffer), POINTER :: new + INTEGER :: inew_size, iold_size + !!---------------------------------------------------------------------- + + IF( .NOT. ASSOCIATED(old) ) THEN + inew_size = kdelta + jp_delta_buf + iold_size = 0 + ELSE + iold_size = old%size + IF( kdelta .LT. old%size ) THEN + inew_size = old%size + kdelta + ELSE + inew_size = kdelta + jp_delta_buf + ENDIF + ENDIF + + IF( iold_size .NE. inew_size ) THEN + ALLOCATE( new ) + ALLOCATE( new%data( jp_buffer_width, inew_size) ) + new%size = inew_size + IF( ASSOCIATED(old) ) THEN + new%data(:,1:old%size) = old%data(:,1:old%size) + DEALLOCATE(old%data) + DEALLOCATE(old) + ENDIF + old => new + !IF (nn_verbose_level > 0) WRITE( numicb,*) 'icb_increase_ibuffer',narea,' increased to',inew_size + ENDIF + ! + END SUBROUTINE icb_increase_ibuffer + + + !!====================================================================== +END MODULE icblbc diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbrst.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbrst.f90 new file mode 100644 index 0000000000000000000000000000000000000000..845bf05e1736df8ed105ce9088efe44535601d55 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbrst.f90 @@ -0,0 +1,441 @@ + + + + + + + + + + + + + +MODULE icbrst + !!====================================================================== + !! *** MODULE icbrst *** + !! Ocean physics: read and write iceberg restart files + !!====================================================================== + !! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-04 (Alderson) Restore restart routine + !! - ! Currently needs a fixed processor + !! - ! layout between restarts + !! - ! 2015-11 Dave Storkey Convert icb_rst_read to use IOM so can + !! read single restart files + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_rst_read : read restart file + !! icb_rst_write : write restart file + !!---------------------------------------------------------------------- + USE par_oce ! NEMO parameters + USE dom_oce ! NEMO domain + USE in_out_manager ! NEMO IO routines + USE lib_mpp ! NEMO MPI library, lk_mpp in particular + USE netcdf ! netcdf routines for IO + USE iom + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_rst_read ! routine called in icbini.F90 module + PUBLIC icb_rst_write ! routine called in icbstp.F90 module + + INTEGER :: nlonid, nlatid, nxid, nyid, nuvelid, nvvelid + INTEGER :: nmassid, nthicknessid, nwidthid, nlengthid + INTEGER :: nyearid, ndayid + INTEGER :: nscaling_id, nmass_of_bits_id, nheat_density_id, numberid + INTEGER :: nsiceid, nsheatid, ncalvid, ncalvhid, nkountid + INTEGER :: nret, ncid, nc_dim + + INTEGER, DIMENSION(3) :: nstrt3, nlngth3 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbrst.F90 15088 2021-07-06 13:03:34Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_rst_read() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_rst_read *** + !! + !! ** Purpose : read a iceberg restart file + !! NB: for this version, we just read back in the restart for this processor + !! so we cannot change the processor layout currently with iceberg code + !!---------------------------------------------------------------------- + INTEGER :: idim, ivar, iatt + INTEGER :: jn, iunlim_dim, ibergs_in_file + INTEGER :: ii, ij, iclass, ibase_err, imax_icb + REAL(wp), DIMENSION(nkounts) :: zdata + LOGICAL :: ll_found_restart + CHARACTER(len=256) :: cl_path + CHARACTER(len=256) :: cl_filename + CHARACTER(len=NF90_MAX_NAME) :: cl_dname + TYPE(iceberg) :: localberg ! NOT a pointer but an actual local variable + TYPE(point) :: localpt ! NOT a pointer but an actual local variable + !!---------------------------------------------------------------------- + ! Find a restart file. Assume iceberg restarts in same directory as ocean restarts + ! and are called TRIM(cn_ocerst)//'_icebergs' + cl_path = TRIM(cn_icbrst_indir) + IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' + cl_filename = TRIM(cn_icbrst_in) + CALL iom_open( TRIM(cl_path)//cl_filename, ncid ) + + imax_icb = 0 + IF( iom_file(ncid)%iduld .GE. 0) THEN + + ibergs_in_file = iom_file(ncid)%lenuld + DO jn = 1,ibergs_in_file + + ! iom_get treats the unlimited dimension as time. Here the unlimited dimension + ! is the iceberg index, but we can still use the ktime keyword to get the iceberg we want. + + CALL iom_get( ncid, 'xi' ,localpt%xi , ktime=jn ) + CALL iom_get( ncid, 'yj' ,localpt%yj , ktime=jn ) + + ii = INT( localpt%xi + 0.5 ) + ( nn_hls-1 ) + ij = INT( localpt%yj + 0.5 ) + ( nn_hls-1 ) + ! Only proceed if this iceberg is on the local processor (excluding halos). + IF ( ii >= mig(Nis0) .AND. ii <= mig(Nie0) .AND. & + & ij >= mjg(Njs0) .AND. ij <= mjg(Nje0) ) THEN + + CALL iom_get( ncid, jpdom_unknown, 'number', zdata(:) , ktime=jn, kstart=(/1/), kcount=(/nkounts/) ) + localberg%number(:) = INT(zdata(:)) + imax_icb = MAX( imax_icb, INT(zdata(1)) ) + CALL iom_get( ncid, 'mass_scaling' , localberg%mass_scaling, ktime=jn ) + CALL iom_get( ncid, 'lon' , localpt%lon , ktime=jn ) + CALL iom_get( ncid, 'lat' , localpt%lat , ktime=jn ) + CALL iom_get( ncid, 'uvel' , localpt%uvel , ktime=jn ) + CALL iom_get( ncid, 'vvel' , localpt%vvel , ktime=jn ) + CALL iom_get( ncid, 'mass' , localpt%mass , ktime=jn ) + CALL iom_get( ncid, 'thickness' , localpt%thickness , ktime=jn ) + CALL iom_get( ncid, 'width' , localpt%width , ktime=jn ) + CALL iom_get( ncid, 'length' , localpt%length , ktime=jn ) + CALL iom_get( ncid, 'year' , zdata(1) , ktime=jn ) + localpt%year = INT(zdata(1)) + CALL iom_get( ncid, 'day' , localpt%day , ktime=jn ) + CALL iom_get( ncid, 'mass_of_bits' , localpt%mass_of_bits , ktime=jn ) + CALL iom_get( ncid, 'heat_density' , localpt%heat_density , ktime=jn ) + ! + CALL icb_utl_add( localberg, localpt ) + ! + ENDIF + ! + END DO + ! + ELSE + ibergs_in_file = 0 + ENDIF + + ! Gridded variables + CALL iom_get( ncid, jpdom_auto, 'calving' , src_calving ) + CALL iom_get( ncid, jpdom_auto, 'calving_hflx', src_calving_hflx ) + CALL iom_get( ncid, jpdom_auto, 'stored_heat' , berg_grid%stored_heat ) + ! with jpdom_auto_xy, ue use only the third element of kstart and kcount. + CALL iom_get( ncid, jpdom_auto_xy, 'stored_ice' , berg_grid%stored_ice, kstart=(/-99,-99,1/), kcount=(/-99,-99,nclasses/) ) + + CALL iom_get( ncid, jpdom_unknown, 'kount' , zdata(:) ) + num_bergs(:) = INT(zdata(:)) + ! + + ! Sanity checks + jn = icb_utl_count() + IF ( lwp .AND. nn_verbose_level >= 0 ) & + WRITE(numout,'(2(a,i5))') 'icebergs, read_restart_bergs: # bergs =',jn,' on PE',narea-1 + IF( lk_mpp ) THEN + ! Only mpp_sum ibergs_in_file if we are reading from multiple restart files. + IF( INDEX(iom_file(ncid)%name,'icebergs.nc' ) .EQ. 0 ) CALL mpp_sum('icbrst', ibergs_in_file) + CALL mpp_sum('icbrst', jn) + ENDIF + IF( lwp ) WRITE(numout,'(a,i5,a,i5,a)') 'icebergs, icb_rst_read: there were',ibergs_in_file, & + & ' bergs in the restart file and', jn,' bergs have been read' + ! Close file + CALL iom_close( ncid ) + ! + ! Confirm that all areas have a suitable base for assigning new iceberg + ! numbers. This will not be the case if restarting from a collated dataset + ! (even if using the same processor decomposition) + ! + ibase_err = 0 + IF( num_bergs(1) < 0 .AND. num_bergs(1) /= narea - jpnij ) THEN + ! If this area has never calved a new berg then the base should be + ! set to narea - jpnij. If it is negative but something else then + ! a new base will be needed to guarantee unique, future iceberg numbers + ibase_err = 1 + ELSEIF( MOD( num_bergs(1) - narea , jpnij ) /= 0 ) THEN + ! If this area has a base which is not in the set {narea + N*jpnij} + ! for positive integers N then a new base will be needed to guarantee + ! unique, future iceberg numbers + ibase_err = 1 + ENDIF + IF( lk_mpp ) THEN + CALL mpp_sum('icbrst', ibase_err) + ENDIF + IF( ibase_err > 0 ) THEN + ! + ! A new base is needed. The only secure solution is to set bases such that + ! all future icebergs numbers will be greater than the current global maximum + IF( lk_mpp ) THEN + CALL mpp_max('icbrst', imax_icb) + ENDIF + num_bergs(1) = imax_icb - jpnij + narea + ENDIF + ! + IF( lwp .AND. nn_verbose_level >= 0 ) WRITE(numout,'(a)') 'icebergs, icb_rst_read: completed' + ! + END SUBROUTINE icb_rst_read + + + SUBROUTINE icb_rst_write( kt ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_rst_write *** + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt + ! + INTEGER :: jn ! dummy loop index + INTEGER :: idg ! number of digits + INTEGER :: ix_dim, iy_dim, ik_dim, in_dim + CHARACTER(len=256) :: cl_path + CHARACTER(len=256) :: cl_filename + CHARACTER(len=8 ) :: cl_kt + CHARACTER(LEN=12 ) :: clfmt ! writing format + TYPE(iceberg), POINTER :: this + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + + ! Following the normal restart procedure, this routine will be called + ! the timestep before a restart stage as well as the restart timestep. + ! This is a performance step enabling the file to be opened and contents + ! defined in advance of the write. This is not possible with icebergs + ! since the number of bergs to be written could change between timesteps + IF( kt == nitrst ) THEN + ! Only operate on the restart timestep itself. + ! Assume we write iceberg restarts to same directory as ocean restarts. + ! + ! directory name + cl_path = TRIM(cn_icbrst_outdir) + IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' + ! + ! file name + WRITE(cl_kt, '(i8.8)') kt + cl_filename = TRIM(cexper)//"_"//cl_kt//"_"//TRIM(cn_icbrst_out) + IF( lk_mpp ) THEN + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' + WRITE(cl_filename, clfmt) TRIM(cl_filename), '_', narea-1, '.nc' + ELSE + WRITE(cl_filename,'(a,a)') TRIM(cl_filename), '.nc' + ENDIF + + IF ( lwp .AND. nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, write_restart: creating ', & + & TRIM(cl_path)//TRIM(cl_filename) + + nret = NF90_CREATE(TRIM(cl_path)//TRIM(cl_filename), NF90_CLOBBER, ncid) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_create failed') + + ! Dimensions + nret = NF90_DEF_DIM(ncid, 'x', Ni_0, ix_dim) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim x failed') + + nret = NF90_DEF_DIM(ncid, 'y', Nj_0, iy_dim) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim y failed') + + nret = NF90_DEF_DIM(ncid, 'c', nclasses, nc_dim) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim c failed') + + nret = NF90_DEF_DIM(ncid, 'k', nkounts, ik_dim) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim k failed') + + ! global attributes + IF( lk_mpp ) THEN + ! Set domain parameters (assume jpdom_local_full) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ) + ENDIF + + IF (associated(first_berg)) then + nret = NF90_DEF_DIM(ncid, 'n', NF90_UNLIMITED, in_dim) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim n failed') + ENDIF + + ! Variables + nret = NF90_DEF_VAR(ncid, 'kount' , NF90_INT , (/ ik_dim /), nkountid) + nret = NF90_DEF_VAR(ncid, 'calving' , NF90_DOUBLE, (/ ix_dim, iy_dim /), ncalvid) + nret = NF90_DEF_VAR(ncid, 'calving_hflx', NF90_DOUBLE, (/ ix_dim, iy_dim /), ncalvhid) + nret = NF90_DEF_VAR(ncid, 'stored_ice' , NF90_DOUBLE, (/ ix_dim, iy_dim, nc_dim /), nsiceid) + nret = NF90_DEF_VAR(ncid, 'stored_heat' , NF90_DOUBLE, (/ ix_dim, iy_dim /), nsheatid) + + ! Attributes + nret = NF90_PUT_ATT(ncid, ncalvid , 'long_name', 'iceberg calving') + nret = NF90_PUT_ATT(ncid, ncalvid , 'units', 'some') + nret = NF90_PUT_ATT(ncid, ncalvhid, 'long_name', 'heat flux associated with iceberg calving') + nret = NF90_PUT_ATT(ncid, ncalvhid, 'units', 'some') + nret = NF90_PUT_ATT(ncid, nsiceid , 'long_name', 'stored ice used to calve icebergs') + nret = NF90_PUT_ATT(ncid, nsiceid , 'units', 'kg/s') + nret = NF90_PUT_ATT(ncid, nsheatid, 'long_name', 'heat in stored ice used to calve icebergs') + nret = NF90_PUT_ATT(ncid, nsheatid, 'units', 'J/kg/s') + + IF ( ASSOCIATED(first_berg) ) THEN + + ! Only add berg variables for this PE if we have anything to say + + ! Variables + nret = NF90_DEF_VAR(ncid, 'lon', NF90_DOUBLE, in_dim, nlonid) + nret = NF90_DEF_VAR(ncid, 'lat', NF90_DOUBLE, in_dim, nlatid) + nret = NF90_DEF_VAR(ncid, 'xi', NF90_DOUBLE, in_dim, nxid) + nret = NF90_DEF_VAR(ncid, 'yj', NF90_DOUBLE, in_dim, nyid) + nret = NF90_DEF_VAR(ncid, 'uvel', NF90_DOUBLE, in_dim, nuvelid) + nret = NF90_DEF_VAR(ncid, 'vvel', NF90_DOUBLE, in_dim, nvvelid) + nret = NF90_DEF_VAR(ncid, 'mass', NF90_DOUBLE, in_dim, nmassid) + nret = NF90_DEF_VAR(ncid, 'thickness', NF90_DOUBLE, in_dim, nthicknessid) + nret = NF90_DEF_VAR(ncid, 'width', NF90_DOUBLE, in_dim, nwidthid) + nret = NF90_DEF_VAR(ncid, 'length', NF90_DOUBLE, in_dim, nlengthid) + nret = NF90_DEF_VAR(ncid, 'number', NF90_INT, (/ik_dim,in_dim/), numberid) + nret = NF90_DEF_VAR(ncid, 'year', NF90_INT, in_dim, nyearid) + nret = NF90_DEF_VAR(ncid, 'day', NF90_DOUBLE, in_dim, ndayid) + nret = NF90_DEF_VAR(ncid, 'mass_scaling', NF90_DOUBLE, in_dim, nscaling_id) + nret = NF90_DEF_VAR(ncid, 'mass_of_bits', NF90_DOUBLE, in_dim, nmass_of_bits_id) + nret = NF90_DEF_VAR(ncid, 'heat_density', NF90_DOUBLE, in_dim, nheat_density_id) + + ! Attributes + nret = NF90_PUT_ATT(ncid, nlonid, 'long_name', 'longitude') + nret = NF90_PUT_ATT(ncid, nlonid, 'units', 'degrees_E') + nret = NF90_PUT_ATT(ncid, nlatid, 'long_name', 'latitude') + nret = NF90_PUT_ATT(ncid, nlatid, 'units', 'degrees_N') + nret = NF90_PUT_ATT(ncid, nxid, 'long_name', 'x grid box position') + nret = NF90_PUT_ATT(ncid, nxid, 'units', 'fractional') + nret = NF90_PUT_ATT(ncid, nyid, 'long_name', 'y grid box position') + nret = NF90_PUT_ATT(ncid, nyid, 'units', 'fractional') + nret = NF90_PUT_ATT(ncid, nuvelid, 'long_name', 'zonal velocity') + nret = NF90_PUT_ATT(ncid, nuvelid, 'units', 'm/s') + nret = NF90_PUT_ATT(ncid, nvvelid, 'long_name', 'meridional velocity') + nret = NF90_PUT_ATT(ncid, nvvelid, 'units', 'm/s') + nret = NF90_PUT_ATT(ncid, nmassid, 'long_name', 'mass') + nret = NF90_PUT_ATT(ncid, nmassid, 'units', 'kg') + nret = NF90_PUT_ATT(ncid, nthicknessid, 'long_name', 'thickness') + nret = NF90_PUT_ATT(ncid, nthicknessid, 'units', 'm') + nret = NF90_PUT_ATT(ncid, nwidthid, 'long_name', 'width') + nret = NF90_PUT_ATT(ncid, nwidthid, 'units', 'm') + nret = NF90_PUT_ATT(ncid, nlengthid, 'long_name', 'length') + nret = NF90_PUT_ATT(ncid, nlengthid, 'units', 'm') + nret = NF90_PUT_ATT(ncid, numberid, 'long_name', 'iceberg number on this processor') + nret = NF90_PUT_ATT(ncid, numberid, 'units', 'count') + nret = NF90_PUT_ATT(ncid, nyearid, 'long_name', 'calendar year of calving event') + nret = NF90_PUT_ATT(ncid, nyearid, 'units', 'years') + nret = NF90_PUT_ATT(ncid, ndayid, 'long_name', 'year day of calving event') + nret = NF90_PUT_ATT(ncid, ndayid, 'units', 'days') + nret = NF90_PUT_ATT(ncid, nscaling_id, 'long_name', 'scaling factor for mass of calving berg') + nret = NF90_PUT_ATT(ncid, nscaling_id, 'units', 'none') + nret = NF90_PUT_ATT(ncid, nmass_of_bits_id, 'long_name', 'mass of bergy bits') + nret = NF90_PUT_ATT(ncid, nmass_of_bits_id, 'units', 'kg') + nret = NF90_PUT_ATT(ncid, nheat_density_id, 'long_name', 'heat density') + nret = NF90_PUT_ATT(ncid, nheat_density_id, 'units', 'J/kg') + + ENDIF ! associated(first_berg) + + ! End define mode + nret = NF90_ENDDEF(ncid) + + ! -------------------------------- + ! now write some data + + nstrt3(1) = 1 + nstrt3(2) = 1 + nlngth3(1) = Ni_0 + nlngth3(2) = Nj_0 + nlngth3(3) = 1 + + DO jn=1,nclasses + nstrt3(3) = jn + nret = NF90_PUT_VAR( ncid, nsiceid, berg_grid%stored_ice(Nis0:Nie0,Njs0:Nje0,jn), nstrt3, nlngth3 ) + IF (nret .ne. NF90_NOERR) THEN + IF( lwp ) WRITE(numout,*) TRIM(NF90_STRERROR( nret )) + CALL ctl_stop('icebergs, write_restart: nf_put_var stored_ice failed') + ENDIF + ENDDO + IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_ice written' + + nret = NF90_PUT_VAR( ncid, nkountid, num_bergs(:) ) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var kount failed') + + nret = NF90_PUT_VAR( ncid, nsheatid, berg_grid%stored_heat(Nis0:Nie0,Njs0:Nje0) ) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var stored_heat failed') + IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_heat written' + + nret = NF90_PUT_VAR( ncid, ncalvid , src_calving(Nis0:Nie0,Njs0:Nje0) ) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving failed') + nret = NF90_PUT_VAR( ncid, ncalvhid, src_calving_hflx(Nis0:Nie0,Njs0:Nje0) ) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving_hflx failed') + IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: calving written' + + IF ( ASSOCIATED(first_berg) ) THEN + + ! Write variables + ! just write out the current point of the trajectory + + this => first_berg + jn = 0 + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + jn=jn+1 + + nret = NF90_PUT_VAR(ncid, numberid, this%number, (/1,jn/), (/nkounts,1/) ) + nret = NF90_PUT_VAR(ncid, nscaling_id, this%mass_scaling, (/ jn /) ) + + nret = NF90_PUT_VAR(ncid, nlonid, pt%lon, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nlatid, pt%lat, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nxid, pt%xi, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nyid, pt%yj, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nuvelid, pt%uvel, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nvvelid, pt%vvel, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nmassid, pt%mass, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nthicknessid, pt%thickness, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nwidthid, pt%width, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nlengthid, pt%length, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nyearid, pt%year, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, ndayid, pt%day, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nmass_of_bits_id, pt%mass_of_bits, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nheat_density_id, pt%heat_density, (/ jn /) ) + + this=>this%next + END DO + ! + ENDIF ! associated(first_berg) + + ! Finish up + nret = NF90_CLOSE(ncid) + IF (nret /= NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_close failed') + + ! Sanity check + jn = icb_utl_count() + IF ( lwp .AND. nn_verbose_level >= 0) & + WRITE(numout,'(2(a,i5))') 'icebergs, icb_rst_write: # bergs =',jn,' on PE',narea-1 + IF( lk_mpp ) THEN + CALL mpp_sum('icbrst', jn) + ENDIF + IF(lwp) WRITE(numout,'(a,i5,a,i5,a)') 'icebergs, icb_rst_write: ', jn, & + & ' bergs in total have been written at timestep ', kt + ! + ! Finish up + ! + ENDIF + END SUBROUTINE icb_rst_write + ! + !!====================================================================== +END MODULE icbrst diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbstp.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbstp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a462e8e9ccc49803215510ed96b9d239339d7ae3 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbstp.f90 @@ -0,0 +1,190 @@ + + + + + + + + + + + + + +MODULE icbstp + !!====================================================================== + !! *** MODULE icbstp *** + !! Icebergs: initialise variables for iceberg tracking + !!====================================================================== + !! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! Move budgets to icbdia routine + !! - ! 2011-05 (Alderson) Add call to copy forcing arrays + !! - ! into icb copies with haloes + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_stp : start iceberg tracking + !! icb_end : end iceberg tracking + !!---------------------------------------------------------------------- + USE par_oce ! nemo parameters + USE dom_oce ! ocean domain + USE sbc_oce ! ocean surface forcing + USE phycst ! physical constants + ! + USE icb_oce ! iceberg: define arrays + USE icbini ! iceberg: initialisation routines + USE icbutl ! iceberg: utility routines + USE icbrst ! iceberg: restart routines + USE icbdyn ! iceberg: dynamics (ie advection) routines + USE icbclv ! iceberg: calving routines + USE icbthm ! iceberg: thermodynamics routines + USE icblbc ! iceberg: lateral boundary routines (including mpp) + USE icbtrj ! iceberg: trajectory I/O routines + USE icbdia ! iceberg: budget + ! + USE in_out_manager ! nemo IO + USE lib_mpp ! massively parallel library + USE iom ! I/O manager + USE fldread ! field read + USE timing ! timing + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_stp ! routine called in sbcmod.F90 module + PUBLIC icb_end ! routine called in nemogcm.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbstp.F90 14239 2020-12-23 08:57:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_stp( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_stp *** + !! + !! ** Purpose : iceberg time stepping. + !! + !! ** Method : - top level routine to do things in the correct order + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + LOGICAL :: ll_sample_traj, ll_budget, ll_verbose ! local logical + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('icb_stp') + + ! !== start of timestep housekeeping ==! + ! + nktberg = kt + ! + !CALL test_icb_utl_getkb + !CALL ctl_stop('end test icb') + ! + IF( nn_test_icebergs < 0 .OR. ln_use_calving ) THEN !* read calving data + ! + CALL fld_read ( kt, 1, sf_icb ) + src_calving (:,:) = sf_icb(1)%fnow(:,:,1) ! calving in km^3/year (water equivalent) + src_calving_hflx(:,:) = 0._wp ! NO heat flux for now + ! + ENDIF + ! + berg_grid%floating_melt(:,:) = 0._wp + ! + ! !* anything that needs to be reset to zero each timestep + CALL icb_dia_step() ! for budgets is dealt with here + ! + ! !* write out time + ll_verbose = .FALSE. + IF( nn_verbose_write > 0 .AND. MOD( kt-1 , nn_verbose_write ) == 0 ) ll_verbose = ( nn_verbose_level > 0 ) + ! + IF( ll_verbose ) WRITE(numicb,9100) nktberg, ndastp, nsec_day + 9100 FORMAT('kt= ',i8, ' day= ',i8,' secs=',i8) + ! + ! !* copy nemo forcing arrays into iceberg versions with extra halo + CALL icb_utl_copy( Kmm ) ! only necessary for variables not on T points + ! + ! + ! !== process icebergs ==! + ! ! + CALL icb_clv_flx( kt ) ! Accumulate ice from calving + ! ! + CALL icb_clv( kt ) ! Calve excess stored ice into icebergs + ! ! + ! + ! !== For each berg, evolve ==! + ! + IF( ASSOCIATED(first_berg) ) CALL icb_dyn( kt ) ! ice berg dynamics + + IF( lk_mpp ) THEN ; CALL icb_lbc_mpp() ! Send bergs to other PEs + ELSE ; CALL icb_lbc() ! Deal with any cyclic boundaries in non-mpp case + ENDIF + + IF( ASSOCIATED(first_berg) ) CALL icb_thm( kt ) ! Ice berg thermodynamics (melting) + rolling + ! + ! + ! !== diagnostics and output ==! + ! + ! !* For each berg, record trajectory (when needed) + ll_sample_traj = .FALSE. + IF( nn_sample_rate > 0 .AND. MOD(kt-1,nn_sample_rate) == 0 ) ll_sample_traj = .TRUE. + IF( ll_sample_traj .AND. ASSOCIATED(first_berg) ) CALL icb_trj_write( kt ) + + ! !* Gridded diagnostics + ! ! To get these iom_put's and those preceding to actually do something + ! ! use 1 in cpp file and create content for XML file + ! + CALL iom_put( "calving" , berg_grid%calving (:,:) ) ! 'calving mass input' + CALL iom_put( "berg_floating_melt", berg_grid%floating_melt(:,:) ) ! 'Melt rate of icebergs + bits' , 'kg/m2/s' + CALL iom_put( "berg_stored_ice" , berg_grid%stored_ice (:,:,:) ) ! 'Accumulated ice mass by class', 'kg' + ! + CALL icb_dia_put() !* store mean budgets + ! + ! !* Dump icebergs to screen + IF( nn_verbose_level >= 2 ) CALL icb_utl_print( 'icb_stp, status', kt ) + ! + ! !* Diagnose budgets + ll_budget = .FALSE. + IF( nn_verbose_write > 0 .AND. MOD(kt-1,nn_verbose_write) == 0 ) ll_budget = ln_bergdia + CALL icb_dia( ll_budget ) + ! + IF( lrst_oce ) THEN !* restart + CALL icb_rst_write( kt ) + IF( nn_sample_rate > 0 ) CALL icb_trj_sync() + ENDIF + ! + IF( ln_timing ) CALL timing_stop('icb_stp') + ! + END SUBROUTINE icb_stp + + + SUBROUTINE icb_end( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_end *** + !! + !! ** Purpose : close iceberg files + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! model time-step index + !!---------------------------------------------------------------------- + ! + ! finish with trajectories if they were written + IF( nn_sample_rate > 0 ) CALL icb_trj_end() + + IF(lwp) WRITE(numout,'(a,i6)') 'icebergs: icb_end complete', narea + ! + IF( nn_verbose_level > 0 ) THEN + CALL flush( numicb ) + CLOSE( numicb ) + ENDIF + ! + END SUBROUTINE icb_end + + !!====================================================================== +END MODULE icbstp diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbthm.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbthm.f90 new file mode 100644 index 0000000000000000000000000000000000000000..60a574e479cc72e50f975782fd1b171b45a4800b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbthm.f90 @@ -0,0 +1,310 @@ + + + + + + + + + + + + + +MODULE icbthm + !!====================================================================== + !! *** MODULE icbthm *** + !! Icebergs: thermodynamics routines for icebergs + !!====================================================================== + !! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) Use tmask instead of tmask_i + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! icb_thm : initialise + !! reference for equations - M = Martin + Adcroft, OM 34, 2010 + !!---------------------------------------------------------------------- + USE par_oce ! NEMO parameters + USE dom_oce ! NEMO domain + USE in_out_manager ! NEMO IO routines, numout in particular + USE lib_mpp ! NEMO MPI routines, ctl_stop in particular + USE phycst ! NEMO physical constants + USE sbc_oce + USE eosbn2 ! equation of state + USE lib_fortran, ONLY : DDPDD + + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + USE icbdia ! iceberg budget routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_thm ! routine called in icbstp.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbthm.F90 15088 2021-07-06 13:03:34Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_thm( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_thm *** + !! + !! ** Purpose : compute the iceberg thermodynamics. + !! + !! ** Method : - See Martin & Adcroft, Ocean Modelling 34, 2010 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! timestep number, just passed to icb_utl_print_berg + ! + INTEGER :: ii, ij, jk, ikb + REAL(wp) :: zM, zT, zW, zL, zSST, zVol, zLn, zWn, zTn, znVol, zIC, zDn, zD, zvb, zub, ztb + REAL(wp) :: zMv, zMe, zMb, zmelt, zdvo, zdvob, zdva, zdM, zSs, zdMe, zdMb, zdMv + REAL(wp) :: zSSS, zfzpt + REAL(wp) :: zMnew, zMnew1, zMnew2, zheat_hcflux, zheat_latent, z1_12 + REAL(wp) :: zMbits, znMbits, zdMbitsE, zdMbitsM, zLbits, zAbits, zMbb + REAL(wp) :: zxi, zyj, zff, z1_rday, z1_e1e2, zdt, z1_dt, z1_dt_e1e2, zdepw + REAL(wp), DIMENSION(jpk) :: ztoce, zuoce, zvoce, ze3t, zzMv + TYPE(iceberg), POINTER :: this, next + TYPE(point) , POINTER :: pt + ! + COMPLEX(dp), DIMENSION(jpi,jpj) :: cicb_melt, cicb_hflx + !!---------------------------------------------------------------------- + ! + !! initialiaze cicb_melt and cicb_heat + cicb_melt = CMPLX( 0.e0, 0.e0, dp ) + cicb_hflx = CMPLX( 0.e0, 0.e0, dp ) + ! + z1_rday = 1._wp / rday + z1_12 = 1._wp / 12._wp + zdt = berg_dt + z1_dt = 1._wp / zdt + ! + ! we're either going to ignore berg fresh water melt flux and associated heat + ! or we pass it into the ocean, so at this point we set them both to zero, + ! accumulate the contributions to them from each iceberg in the while loop following + ! and then pass them (or not) to the ocean + ! + berg_grid%floating_melt(:,:) = 0._wp + ! calving_hflx re-used here as temporary workspace for the heat flux associated with melting + berg_grid%calving_hflx(:,:) = 0._wp + ! + this => first_berg + DO WHILE( ASSOCIATED(this) ) + ! + pt => this%current_point + nknberg = this%number(1) + + CALL icb_utl_interp( pt%xi, pt%yj, & ! position + & pssu=pt%ssu, pua=pt%ua, & ! oce/atm velocities + & pssv=pt%ssv, pva=pt%va, & ! oce/atm velocities + & psst=pt%sst, pcn=pt%cn, & + & psss=pt%sss ) + + IF ( nn_sample_rate > 0 .AND. MOD(kt-1,nn_sample_rate) == 0 ) THEN + CALL icb_utl_interp( pt%xi, pt%yj, pe1=pt%e1, pe2=pt%e2, & + & pui=pt%ui, pssh_i=pt%ssh_x, & + & pvi=pt%vi, pssh_j=pt%ssh_y, & + & phi=pt%hi, & + & plat=pt%lat, plon=pt%lon ) + END IF + ! + zSST = pt%sst + zSSS = pt%sss + CALL eos_fzp(zSSS,zfzpt) ! freezing point + zIC = MIN( 1._wp, pt%cn + rn_sicn_shift ) ! Shift sea-ice concentration !!gm ??? + zM = pt%mass + zT = pt%thickness ! total thickness + zD = rho_berg_1_oce * zT ! draught (keel depth) + zW = pt%width + zL = pt%length + zxi = pt%xi ! position in (i,j) referential + zyj = pt%yj + ii = INT( zxi + 0.5 ) ! T-cell of the berg + ii = mi1( ii + (nn_hls-1) ) + ij = INT( zyj + 0.5 ) + ij = mj1( ij + (nn_hls-1) ) + zVol = zT * zW * zL + + ! Environment + ! default sst, ssu and ssv + ! ln_M2016: use temp, u and v profile + IF ( ln_M2016 ) THEN + + ! load t, u, v and e3 profile at icb position + CALL icb_utl_interp( pt%xi, pt%yj, ptoce=ztoce, puoce=zuoce, pvoce=zvoce, pe3t=ze3t ) + + !compute bottom level + CALL icb_utl_getkb( pt%kb, ze3t, zD ) + + ikb = MIN(pt%kb,mbkt(ii,ij)) ! limit pt%kb by mbkt + ! => bottom temperature used to fill ztoce(mbkt:jpk) + ztb = ztoce(ikb) ! basal temperature + zub = zuoce(ikb) + zvb = zvoce(ikb) + ELSE + ztb = pt%sst + zub = pt%ssu + zvb = pt%ssv + END IF + + zdvob = SQRT( (pt%uvel-zub)**2 + (pt%vvel-zvb)**2 ) ! relative basal velocity + zdva = SQRT( (pt%ua -pt%ssu)**2 + (pt%va -pt%ssv)**2 ) ! relative wind + zSs = 1.5_wp * SQRT( zdva ) + 0.1_wp * zdva ! Sea state (eqn M.A9) + ! + ! Melt rates in m/s (i.e. division by rday) + ! Buoyant convection at sides (eqn M.A10) + IF ( ln_M2016 ) THEN + ! averaging along all the iceberg draft + zzMv(:) = MAX( 7.62d-3*ztoce(:)+1.29d-3*(ztoce(:)**2), 0._wp ) * z1_rday + CALL icb_utl_zavg(zMv, zzMv, ze3t, zD, ikb ) + ELSE + zMv = MAX( 7.62d-3*zSST+1.29d-3*(zSST**2), 0._wp ) * z1_rday + END IF + ! + ! Basal turbulent melting (eqn M.A7 ) + IF ( zSST > zfzpt ) THEN ! Calculate basal melting only if SST above freezing point + zMb = MAX( 0.58_wp*(zdvob**0.8_wp)*(ztb+4.0_wp)/(zL**0.2_wp) , 0._wp ) * z1_rday + ELSE + zMb = 0._wp ! No basal melting if SST below freezing point + ENDIF + ! + ! Wave erosion (eqn M.A8 ) + zMe = MAX( z1_12*(zSST+2.)*zSs*(1._wp+COS(rpi*(zIC**3))) , 0._wp ) * z1_rday + + IF( ln_operator_splitting ) THEN ! Operator split update of volume/mass + zTn = MAX( zT - zMb*zdt , 0._wp ) ! new total thickness (m) + znVol = zTn * zW * zL ! new volume (m^3) + zMnew1 = ( znVol / zVol ) * zM ! new mass (kg) + zdMb = zM - zMnew1 ! mass lost to basal melting (>0) (kg) + ! + zLn = MAX( zL - zMv*zdt , 0._wp ) ! new length (m) + zWn = MAX( zW - zMv*zdt , 0._wp ) ! new width (m) + znVol = zTn * zWn * zLn ! new volume (m^3) + zMnew2 = ( znVol / zVol ) * zM ! new mass (kg) + zdMv = zMnew1 - zMnew2 ! mass lost to buoyant convection (>0) (kg) + ! + zLn = MAX( zLn - zMe*zdt , 0._wp ) ! new length (m) + zWn = MAX( zWn - zMe*zdt , 0._wp ) ! new width (m) + znVol = zTn * zWn * zLn ! new volume (m^3) + zMnew = ( znVol / zVol ) * zM ! new mass (kg) + zdMe = zMnew2 - zMnew ! mass lost to erosion (>0) (kg) + zdM = zM - zMnew ! mass lost to all erosion and melting (>0) (kg) + ! + ELSE ! Update dimensions of berg + zLn = MAX( zL -(zMv+zMe)*zdt ,0._wp ) ! (m) + zWn = MAX( zW -(zMv+zMe)*zdt ,0._wp ) ! (m) + zTn = MAX( zT - zMb *zdt ,0._wp ) ! (m) + ! Update volume and mass of berg + znVol = zTn*zWn*zLn ! (m^3) + zMnew = (znVol/zVol)*zM ! (kg) + zdM = zM - zMnew ! (kg) + zdMb = (zM/zVol) * (zW* zL ) *zMb*zdt ! approx. mass loss to basal melting (kg) + zdMe = (zM/zVol) * (zT*(zW+zL)) *zMe*zdt ! approx. mass lost to erosion (kg) + zdMv = (zM/zVol) * (zT*(zW+zL)) *zMv*zdt ! approx. mass loss to buoyant convection (kg) + ENDIF + + IF( rn_bits_erosion_fraction > 0._wp ) THEN ! Bergy bits + ! + zMbits = pt%mass_of_bits ! mass of bergy bits (kg) + zdMbitsE = rn_bits_erosion_fraction * zdMe ! change in mass of bits (kg) + znMbits = zMbits + zdMbitsE ! add new bergy bits to mass (kg) + zLbits = MIN( zL, zW, zT, 40._wp ) ! assume bergy bits are smallest dimension or 40 meters + zAbits = ( zMbits / rn_rho_bergs ) / zLbits ! Effective bottom area (assuming T=Lbits) + zMbb = MAX( 0.58_wp*(zdvob**0.8_wp)*(zSST+2._wp) / & + & ( zLbits**0.2_wp ) , 0._wp ) * z1_rday ! Basal turbulent melting (for bits) + zMbb = rn_rho_bergs * zAbits * zMbb ! in kg/s + zdMbitsM = MIN( zMbb*zdt , znMbits ) ! bergy bits mass lost to melting (kg) + znMbits = znMbits-zdMbitsM ! remove mass lost to bergy bits melt + IF( zMnew == 0._wp ) THEN ! if parent berg has completely melted then + zdMbitsM = zdMbitsM + znMbits ! instantly melt all the bergy bits + znMbits = 0._wp + ENDIF + ELSE ! No bergy bits + zAbits = 0._wp + zdMbitsE = 0._wp + zdMbitsM = 0._wp + znMbits = pt%mass_of_bits ! retain previous value incase non-zero + ENDIF + + ! use tmask rather than tmask_i when dealing with icebergs + IF( tmask(ii,ij,1) /= 0._wp ) THEN ! Add melting to the grid and field diagnostics + z1_e1e2 = r1_e1e2t(ii,ij) * this%mass_scaling + z1_dt_e1e2 = z1_dt * z1_e1e2 + ! + ! iceberg melt + !! the use of DDPDD function for the cumulative sum is needed for reproducibility + zmelt = ( zdM - ( zdMbitsE - zdMbitsM ) ) * z1_dt ! kg/s + CALL DDPDD( CMPLX( zmelt * z1_e1e2, 0.e0, dp ), cicb_melt(ii,ij) ) + ! + ! iceberg heat flux + !! the use of DDPDD function for the cumulative sum is needed for reproducibility + !! NB. The src_calving_hflx field is currently hardwired to zero in icb_stp, which means that the + !! heat density of the icebergs is zero and the heat content flux to the ocean from iceberg + !! melting is always zero. Leaving the term in the code until such a time as this is fixed. DS. + zheat_hcflux = zmelt * pt%heat_density ! heat content flux : kg/s x J/kg = J/s + zheat_latent = - zmelt * rLfus ! latent heat flux: kg/s x J/kg = J/s + CALL DDPDD( CMPLX( ( zheat_hcflux + zheat_latent ) * z1_e1e2, 0.e0, dp ), cicb_hflx(ii,ij) ) + ! + ! diagnostics + CALL icb_dia_melt( ii, ij, zMnew, zheat_hcflux, zheat_latent, this%mass_scaling, & + & zdM, zdMbitsE, zdMbitsM, zdMb, zdMe, & + & zdMv, z1_dt_e1e2, z1_e1e2 ) + ELSE + WRITE(numout,*) 'icb_thm: berg ',this%number(:),' appears to have grounded at ',narea,ii,ij + CALL icb_utl_print_berg( this, kt ) + WRITE(numout,*) 'msk=',tmask(ii,ij,1), e1e2t(ii,ij) + CALL ctl_stop('icb_thm', 'berg appears to have grounded!') + ENDIF + + ! Rolling + zDn = rho_berg_1_oce * zTn ! draught (keel depth) + IF( zDn > 0._wp .AND. MAX(zWn,zLn) < SQRT( 0.92*(zDn**2) + 58.32*zDn ) ) THEN + zT = zTn + zTn = zWn + zWn = zT + ENDIF + + ! Store the new state of iceberg (with L>W) + pt%mass = zMnew + pt%mass_of_bits = znMbits + pt%thickness = zTn + pt%width = MIN( zWn , zLn ) + pt%length = MAX( zWn , zLn ) + + next=>this%next + +!!gm add a test to avoid over melting ? +!!pm I agree, over melting could break conservation (more melt than calving) + + IF( zMnew <= 0._wp ) THEN ! Delete the berg if completely melted + CALL icb_utl_delete( first_berg, this ) + ! + ELSE ! Diagnose mass distribution on grid + z1_e1e2 = r1_e1e2t(ii,ij) * this%mass_scaling + CALL icb_dia_size( ii, ij, zWn, zLn, zAbits, & + & this%mass_scaling, zMnew, znMbits, z1_e1e2 ) + ENDIF + ! + this=>next + ! + END DO + ! + berg_grid%floating_melt = REAL(cicb_melt,dp) ! kg/m2/s + berg_grid%calving_hflx = REAL(cicb_hflx,dp) + ! + ! now use melt and associated heat flux in ocean (or not) + ! + IF(.NOT. ln_passive_mode ) THEN + emp (:,:) = emp (:,:) - berg_grid%floating_melt(:,:) + qns (:,:) = qns (:,:) + berg_grid%calving_hflx (:,:) + ENDIF + ! + END SUBROUTINE icb_thm + + !!====================================================================== +END MODULE icbthm diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbtrj.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbtrj.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3c994a6d29a6e269f0bc23a782d2f1632d2d3336 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbtrj.f90 @@ -0,0 +1,300 @@ + + + + + + + + + + + + + +MODULE icbtrj + !!====================================================================== + !! *** MODULE icbtrj *** + !! Ocean physics: trajectory I/O routines + !!====================================================================== + !! History : 3.3 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-05 (Alderson) New module to handle trajectory output + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_trj_init : initialise iceberg trajectory output files + !! icb_trj_write : + !! icb_trj_sync : + !! icb_trj_end : + !!---------------------------------------------------------------------- + USE par_oce ! NEMO parameters + USE dom_oce ! NEMO ocean domain + USE phycst ! NEMO physical constants + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + ! + USE lib_mpp ! NEMO MPI library, lk_mpp in particular + USE in_out_manager ! NEMO IO, numout in particular + USE ioipsl , ONLY : ju2ymds ! for calendar + USE netcdf + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_trj_init ! routine called in icbini.F90 module + PUBLIC icb_trj_write ! routine called in icbstp.F90 module + PUBLIC icb_trj_sync ! routine called in icbstp.F90 module + PUBLIC icb_trj_end ! routine called in icbstp.F90 module + + INTEGER :: num_traj = 0 + INTEGER :: n_dim, m_dim + INTEGER :: ntrajid + INTEGER :: numberid, nstepid, nscaling_id + INTEGER :: nlonid, nlatid, nxid, nyid, nuvelid, nvvelid, nmassid + INTEGER :: nssuid, nssvid, nuaid, nvaid, nuiid, nviid + INTEGER :: nsshxid, nsshyid, nsstid, ncntid, nthkid + INTEGER :: nthicknessid, nwidthid, nlengthid + INTEGER :: nyearid, ndayid + INTEGER :: nmass_of_bits_id, nheat_density_id + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbtrj.F90 14030 2020-12-03 09:26:33Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_trj_init( ktend ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_trj_init *** + !! + !! ** Purpose : initialise iceberg trajectory output files + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktend ! time step index + ! + INTEGER :: iret, iyear, imonth, iday + INTEGER :: idg ! number of digits + REAL(dp) :: zfjulday, zsec + CHARACTER(len=80) :: cl_filename + CHARACTER(LEN=12) :: clfmt ! writing format + CHARACTER(LEN=8 ) :: cldate_ini, cldate_end + TYPE(iceberg), POINTER :: this + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + + ! compute initial time step date + CALL ju2ymds( fjulday, iyear, imonth, iday, zsec ) + WRITE(cldate_ini, '(i4.4,2i2.2)') iyear, imonth, iday + + ! compute end time step date + zfjulday = fjulday + rn_Dt / rday * REAL( nitend - nit000 + 1 , wp) + IF( ABS(zfjulday - REAL(NINT(zfjulday),wp)) < 0.1 / rday ) zfjulday = REAL(NINT(zfjulday),wp) ! avoid truncation error + CALL ju2ymds( zfjulday, iyear, imonth, iday, zsec ) + WRITE(cldate_end, '(i4.4,2i2.2)') iyear, imonth, iday + + ! define trajectory output name + cl_filename = 'trajectory_icebergs_'//cldate_ini//'-'//cldate_end + IF ( lk_mpp ) THEN + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' + WRITE(cl_filename, clfmt) TRIM(cl_filename), '_', narea-1, '.nc' + ELSE + WRITE(cl_filename,'(a,a)') TRIM(cl_filename), '.nc' + ENDIF + IF( lwp .AND. nn_verbose_level >= 0 ) WRITE(numout,'(2a)') 'icebergs, icb_trj_init: creating ',TRIM(cl_filename) + + iret = NF90_CREATE( TRIM(cl_filename), NF90_CLOBBER, ntrajid ) + IF (iret .NE. NF90_NOERR) CALL ctl_stop('icebergs, icb_trj_init: nf_create failed') + + ! Dimensions + iret = NF90_DEF_DIM( ntrajid, 'n', NF90_UNLIMITED, n_dim ) + IF ( iret /= NF90_NOERR ) CALL ctl_stop('icebergs, icb_trj_init: nf_def_dim n failed') + iret = NF90_DEF_DIM( ntrajid, 'k', nkounts, m_dim ) + IF ( iret /= NF90_NOERR ) CALL ctl_stop('icebergs, icb_trj_init: nf_def_dim k failed') + + ! Variables + iret = NF90_DEF_VAR( ntrajid, 'iceberg_number', NF90_INT , (/m_dim,n_dim/), numberid ) + iret = NF90_DEF_VAR( ntrajid, 'timestep' , NF90_INT , n_dim , nstepid ) + iret = NF90_DEF_VAR( ntrajid, 'mass_scaling' , NF90_DOUBLE, n_dim , nscaling_id ) + iret = NF90_DEF_VAR( ntrajid, 'lon' , NF90_DOUBLE, n_dim , nlonid ) + iret = NF90_DEF_VAR( ntrajid, 'lat' , NF90_DOUBLE, n_dim , nlatid ) + iret = NF90_DEF_VAR( ntrajid, 'xi' , NF90_DOUBLE, n_dim , nxid ) + iret = NF90_DEF_VAR( ntrajid, 'yj' , NF90_DOUBLE, n_dim , nyid ) + iret = NF90_DEF_VAR( ntrajid, 'uvel' , NF90_DOUBLE, n_dim , nuvelid ) + iret = NF90_DEF_VAR( ntrajid, 'vvel' , NF90_DOUBLE, n_dim , nvvelid ) + iret = NF90_DEF_VAR( ntrajid, 'ssu' , NF90_DOUBLE, n_dim , nssuid ) + iret = NF90_DEF_VAR( ntrajid, 'ssv' , NF90_DOUBLE, n_dim , nssvid ) + iret = NF90_DEF_VAR( ntrajid, 'uta' , NF90_DOUBLE, n_dim , nuaid ) + iret = NF90_DEF_VAR( ntrajid, 'vta' , NF90_DOUBLE, n_dim , nvaid ) + iret = NF90_DEF_VAR( ntrajid, 'uti' , NF90_DOUBLE, n_dim , nuiid ) + iret = NF90_DEF_VAR( ntrajid, 'vti' , NF90_DOUBLE, n_dim , nviid ) + iret = NF90_DEF_VAR( ntrajid, 'ssh_x' , NF90_DOUBLE, n_dim , nsshxid ) + iret = NF90_DEF_VAR( ntrajid, 'ssh_y' , NF90_DOUBLE, n_dim , nsshyid ) + iret = NF90_DEF_VAR( ntrajid, 'sst' , NF90_DOUBLE, n_dim , nsstid ) + iret = NF90_DEF_VAR( ntrajid, 'icnt' , NF90_DOUBLE, n_dim , ncntid ) + iret = NF90_DEF_VAR( ntrajid, 'ithk' , NF90_DOUBLE, n_dim , nthkid ) + iret = NF90_DEF_VAR( ntrajid, 'mass' , NF90_DOUBLE, n_dim , nmassid ) + iret = NF90_DEF_VAR( ntrajid, 'thickness' , NF90_DOUBLE, n_dim , nthicknessid ) + iret = NF90_DEF_VAR( ntrajid, 'width' , NF90_DOUBLE, n_dim , nwidthid ) + iret = NF90_DEF_VAR( ntrajid, 'length' , NF90_DOUBLE, n_dim , nlengthid ) + iret = NF90_DEF_VAR( ntrajid, 'year' , NF90_INT , n_dim , nyearid ) + iret = NF90_DEF_VAR( ntrajid, 'day' , NF90_DOUBLE, n_dim , ndayid ) + iret = NF90_DEF_VAR( ntrajid, 'mass_of_bits' , NF90_DOUBLE, n_dim , nmass_of_bits_id ) + iret = NF90_DEF_VAR( ntrajid, 'heat_density' , NF90_DOUBLE, n_dim , nheat_density_id ) + + ! Attributes + iret = NF90_PUT_ATT( ntrajid, numberid , 'long_name', 'iceberg number on this processor' ) + iret = NF90_PUT_ATT( ntrajid, numberid , 'units' , 'count' ) + iret = NF90_PUT_ATT( ntrajid, nstepid , 'long_name', 'timestep number kt' ) + iret = NF90_PUT_ATT( ntrajid, nstepid , 'units' , 'count' ) + iret = NF90_PUT_ATT( ntrajid, nlonid , 'long_name', 'longitude' ) + iret = NF90_PUT_ATT( ntrajid, nlonid , 'units' , 'degrees_E') + iret = NF90_PUT_ATT( ntrajid, nlatid , 'long_name', 'latitude' ) + iret = NF90_PUT_ATT( ntrajid, nlatid , 'units' , 'degrees_N' ) + iret = NF90_PUT_ATT( ntrajid, nxid , 'long_name', 'x grid box position' ) + iret = NF90_PUT_ATT( ntrajid, nxid , 'units' , 'fractional' ) + iret = NF90_PUT_ATT( ntrajid, nyid , 'long_name', 'y grid box position' ) + iret = NF90_PUT_ATT( ntrajid, nyid , 'units' , 'fractional' ) + iret = NF90_PUT_ATT( ntrajid, nuvelid , 'long_name', 'zonal velocity' ) + iret = NF90_PUT_ATT( ntrajid, nuvelid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nvvelid , 'long_name', 'meridional velocity' ) + iret = NF90_PUT_ATT( ntrajid, nvvelid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nssuid , 'long_name', 'ocean u component' ) + iret = NF90_PUT_ATT( ntrajid, nssuid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nssvid , 'long_name', 'ocean v component' ) + iret = NF90_PUT_ATT( ntrajid, nssvid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nuaid , 'long_name', 'atmosphere u component' ) + iret = NF90_PUT_ATT( ntrajid, nuaid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nvaid , 'long_name', 'atmosphere v component' ) + iret = NF90_PUT_ATT( ntrajid, nvaid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nuiid , 'long_name', 'sea ice u component' ) + iret = NF90_PUT_ATT( ntrajid, nuiid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nviid , 'long_name', 'sea ice v component' ) + iret = NF90_PUT_ATT( ntrajid, nviid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nsshxid , 'long_name', 'sea surface height gradient from x points' ) + iret = NF90_PUT_ATT( ntrajid, nsshxid , 'units' , 'm/m' ) + iret = NF90_PUT_ATT( ntrajid, nsshyid , 'long_name', 'sea surface height gradient from y points' ) + iret = NF90_PUT_ATT( ntrajid, nsshyid , 'units' , 'm/m' ) + iret = NF90_PUT_ATT( ntrajid, nsstid , 'long_name', 'sea surface temperature' ) + iret = NF90_PUT_ATT( ntrajid, nsstid , 'units' , 'degC') + iret = NF90_PUT_ATT( ntrajid, ncntid , 'long_name', 'sea ice concentration' ) + iret = NF90_PUT_ATT( ntrajid, ncntid , 'units' , 'degC') + iret = NF90_PUT_ATT( ntrajid, nthkid , 'long_name', 'sea ice thickness' ) + iret = NF90_PUT_ATT( ntrajid, nthkid , 'units' , 'm' ) + iret = NF90_PUT_ATT( ntrajid, nmassid , 'long_name', 'mass') + iret = NF90_PUT_ATT( ntrajid, nmassid , 'units' , 'kg' ) + iret = NF90_PUT_ATT( ntrajid, nthicknessid , 'long_name', 'thickness' ) + iret = NF90_PUT_ATT( ntrajid, nthicknessid , 'units' , 'm' ) + iret = NF90_PUT_ATT( ntrajid, nwidthid , 'long_name', 'width' ) + iret = NF90_PUT_ATT( ntrajid, nwidthid , 'units' , 'm' ) + iret = NF90_PUT_ATT( ntrajid, nlengthid , 'long_name', 'length' ) + iret = NF90_PUT_ATT( ntrajid, nlengthid , 'units' , 'm' ) + iret = NF90_PUT_ATT( ntrajid, nyearid , 'long_name', 'calendar year' ) + iret = NF90_PUT_ATT( ntrajid, nyearid , 'units' , 'years' ) + iret = NF90_PUT_ATT( ntrajid, ndayid , 'long_name', 'day of year' ) + iret = NF90_PUT_ATT( ntrajid, ndayid , 'units' , 'days' ) + iret = NF90_PUT_ATT( ntrajid, nscaling_id , 'long_name', 'scaling factor for mass of berg' ) + iret = NF90_PUT_ATT( ntrajid, nscaling_id , 'units' , 'none' ) + iret = NF90_PUT_ATT( ntrajid, nmass_of_bits_id, 'long_name', 'mass of bergy bits' ) + iret = NF90_PUT_ATT( ntrajid, nmass_of_bits_id, 'units' , 'kg' ) + iret = NF90_PUT_ATT( ntrajid, nheat_density_id, 'long_name', 'heat density' ) + iret = NF90_PUT_ATT( ntrajid, nheat_density_id, 'units' , 'J/kg' ) + ! + ! End define mode + iret = NF90_ENDDEF( ntrajid ) + ! + END SUBROUTINE icb_trj_init + + + SUBROUTINE icb_trj_write( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_trj_write *** + !! + !! ** Purpose : write out iceberg trajectories + !! + !! ** Method : - for the moment write out each snapshot of positions later + !! can rewrite so that it is buffered and written out more efficiently + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! time-step index + ! + INTEGER :: iret, jn + CHARACTER(len=80) :: cl_filename + TYPE(iceberg), POINTER :: this + TYPE(point ), POINTER :: pt + !!---------------------------------------------------------------------- + + ! Write variables + ! sga - just write out the current point of the trajectory + + this => first_berg + jn = num_traj + DO WHILE( ASSOCIATED(this) ) + pt => this%current_point + jn = jn + 1 + ! + iret = NF90_PUT_VAR( ntrajid, numberid , this%number , (/1,jn/) , (/nkounts,1/) ) + iret = NF90_PUT_VAR( ntrajid, nstepid , kt , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nscaling_id , this%mass_scaling, (/ jn /) ) + ! + iret = NF90_PUT_VAR( ntrajid, nlonid , pt%lon , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nlatid , pt%lat , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nxid , pt%xi , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nyid , pt%yj , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nuvelid , pt%uvel , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nvvelid , pt%vvel , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nssuid , pt%ssu , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nssvid , pt%ssv , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nuaid , pt%ua , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nvaid , pt%va , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nuiid , pt%ui , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nviid , pt%vi , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nsshxid , pt%ssh_x , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nsshyid , pt%ssh_y , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nsstid , pt%sst , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, ncntid , pt%cn , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nthkid , pt%hi , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nmassid , pt%mass , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nthicknessid , pt%thickness , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nwidthid , pt%width , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nlengthid , pt%length , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nyearid , pt%year , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, ndayid , pt%day , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nmass_of_bits_id, pt%mass_of_bits , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nheat_density_id, pt%heat_density , (/ jn /) ) + ! + this => this%next + END DO + IF( lwp .AND. nn_verbose_level > 0 ) WRITE(numout,*) 'trajectory write to frame ', jn + num_traj = jn + ! + END SUBROUTINE icb_trj_write + + + SUBROUTINE icb_trj_sync() + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_trj_sync *** + !! + !! ** Purpose : + !!---------------------------------------------------------------------- + INTEGER :: iret + !!---------------------------------------------------------------------- + ! flush to file + iret = NF90_SYNC( ntrajid ) + IF ( iret /= NF90_NOERR ) CALL ctl_stop( 'icebergs, icb_trj_sync: nf_sync failed' ) + ! + END SUBROUTINE icb_trj_sync + + + SUBROUTINE icb_trj_end() + !!---------------------------------------------------------------------- + INTEGER :: iret + !!---------------------------------------------------------------------- + ! Finish up + iret = NF90_CLOSE( ntrajid ) + IF ( iret /= NF90_NOERR ) CALL ctl_stop( 'icebergs, icb_trj_end: nf_close failed' ) + ! + END SUBROUTINE icb_trj_end + + !!====================================================================== +END MODULE icbtrj diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbutl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbutl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b0f250998a170831eff548b7859c7da8321115bc --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/icbutl.f90 @@ -0,0 +1,980 @@ + + + + + + + + + + + + + +MODULE icbutl + !!====================================================================== + !! *** MODULE icbutl *** + !! Icebergs: various iceberg utility routines + !!====================================================================== + !! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! 4.2 ! 2020-07 (P. Mathiot) simplification of interpolation routine + !! ! and add Nacho Merino work + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_utl_interp : + !! icb_utl_pos : compute bottom left corner indice, weight and mask + !! icb_utl_bilin_h : interpolation field to icb position + !! icb_utl_bilin_e : interpolation of scale factor to icb position + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE oce, ONLY: ts, uu, vv + USE dom_oce ! ocean domain + USE in_out_manager ! IO parameters + USE lbclnk ! lateral boundary condition + USE lib_mpp ! MPI code and lk_mpp in particular + USE icb_oce ! define iceberg arrays + USE sbc_oce ! ocean surface boundary conditions + + IMPLICIT NONE + PRIVATE + + INTERFACE icb_utl_bilin_h + MODULE PROCEDURE icb_utl_bilin_2d_h, icb_utl_bilin_3d_h + END INTERFACE + + PUBLIC icb_utl_copy ! routine called in icbstp module + PUBLIC icb_utl_getkb ! routine called in icbdyn and icbthm modules + PUBLIC test_icb_utl_getkb ! routine called in icbdyn and icbthm modules + PUBLIC icb_utl_zavg ! routine called in icbdyn and icbthm modules + PUBLIC icb_utl_interp ! routine called in icbdyn, icbthm modules + PUBLIC icb_utl_bilin_h ! routine called in icbdyn module + PUBLIC icb_utl_add ! routine called in icbini.F90, icbclv, icblbc and icbrst modules + PUBLIC icb_utl_delete ! routine called in icblbc, icbthm modules + PUBLIC icb_utl_destroy ! routine called in icbstp module + PUBLIC icb_utl_track ! routine not currently used, retain just in case + PUBLIC icb_utl_print_berg ! routine called in icbthm module + PUBLIC icb_utl_print ! routine called in icbini, icbstp module + PUBLIC icb_utl_count ! routine called in icbdia, icbini, icblbc, icbrst modules + PUBLIC icb_utl_incr ! routine called in icbini, icbclv modules + PUBLIC icb_utl_yearday ! routine called in icbclv, icbstp module + PUBLIC icb_utl_mass ! routine called in icbdia module + PUBLIC icb_utl_heat ! routine called in icbdia module + + !! * Substitutions + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbutl.F90 15372 2021-10-14 15:47:24Z davestorkey $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_utl_copy( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_copy *** + !! + !! ** Purpose : iceberg initialization. + !! + !! ** Method : - blah blah + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(0:jpi+1,0:jpj+1) :: ztmp + INTEGER :: jk ! vertical loop index + INTEGER :: Kmm ! ocean time levelindex + ! + ! copy nemo forcing arrays into iceberg versions with extra halo + ! only necessary for variables not on T points + ! and ssh which is used to calculate gradients + ! + ! surface forcing + ! + ssu_e(1:jpi,1:jpj) = ssu_m(:,:) * umask(:,:,1) + ssv_e(1:jpi,1:jpj) = ssv_m(:,:) * vmask(:,:,1) + sst_e(1:jpi,1:jpj) = sst_m(:,:) + sss_e(1:jpi,1:jpj) = sss_m(:,:) + fr_e (1:jpi,1:jpj) = fr_i (:,:) + ua_e (1:jpi,1:jpj) = utau_icb (:,:) * umask(:,:,1) ! maybe mask useless because mask applied in sbcblk + va_e (1:jpi,1:jpj) = vtau_icb (:,:) * vmask(:,:,1) ! maybe mask useless because mask applied in sbcblk + ff_e(1:jpi,1:jpj) = ff_f (:,:) + ! + CALL lbc_lnk_icb( 'icbutl', ssu_e, 'U', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ssv_e, 'V', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ua_e , 'U', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', va_e , 'V', -1._wp, 1, 1 ) + ssh_e(1:jpi, 1:jpj) = ssh_m(:,:) * tmask(:,:,1) + ! + ! (PM) could be improve with a 3d lbclnk gathering both variables + ! should be done once extra haloe generalised + IF ( ln_M2016 ) THEN + DO jk = 1,jpk + ! uoce + ztmp(1:jpi,1:jpj) = uu(:,:,jk,Kmm) + CALL lbc_lnk_icb( 'icbutl', ztmp, 'U', -1._wp, 1, 1 ) + uoce_e(:,:,jk) = ztmp(:,:) + ! + ! voce + ztmp(1:jpi,1:jpj) = vv(:,:,jk,Kmm) + CALL lbc_lnk_icb( 'icbutl', ztmp, 'V', -1._wp, 1, 1 ) + voce_e(:,:,jk) = ztmp(:,:) + ! + e3t_e(1:jpi,1:jpj,jk) = (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + END DO + toce_e(1:jpi,1:jpj,:) = ts(:,:,:,1,Kmm) + END IF + ! + END SUBROUTINE icb_utl_copy + + + SUBROUTINE icb_utl_interp( pi, pj, pe1 , pssu, pui, pua, pssh_i, & + & pe2 , pssv, pvi, pva, pssh_j, & + & psst, psss, pcn, phi, pff , & + & plon, plat, ptoce, puoce, pvoce, pe3t ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_interp *** + !! + !! ** Purpose : interpolation + !! + !! ** Method : - interpolate from various ocean arrays onto iceberg position + !! + !! !!gm CAUTION here I do not care of the slip/no-slip conditions + !! this can be done later (not that easy to do...) + !! right now, U is 0 in land so that the coastal value of velocity parallel to the coast + !! is half the off shore value, wile the normal-to-the-coast value is zero. + !! This is OK as a starting point. + !! !!pm HARD CODED: - rho_air now computed in sbcblk (what are the effect ?) + !! - drag coefficient (should it be namelist parameter ?) + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: pi , pj ! position in (i,j) referential + REAL(wp), INTENT( out), OPTIONAL :: pe1, pe2 ! i- and j scale factors + REAL(wp), INTENT( out), OPTIONAL :: pssu, pssv, pui, pvi, pua, pva ! ocean, ice and wind speeds + REAL(wp), INTENT( out), OPTIONAL :: pssh_i, pssh_j ! ssh i- & j-gradients + REAL(wp), INTENT( out), OPTIONAL :: psst, psss, pcn, phi, pff ! SST, SSS, ice concentration, ice thickness, Coriolis + REAL(wp), INTENT( out), OPTIONAL :: plat, plon ! position + REAL(wp), DIMENSION(jpk), INTENT( out), OPTIONAL :: ptoce, puoce, pvoce, pe3t ! 3D variables + ! + REAL(wp), DIMENSION(4) :: zwT , zwU , zwV , zwF ! interpolation weight + REAL(wp), DIMENSION(4) :: zmskF, zmskU, zmskV, zmskT ! mask + REAL(wp), DIMENSION(4) :: zwTp, zmskTp, zwTm, zmskTm + REAL(wp), DIMENSION(4,jpk) :: zw1d + INTEGER :: iiT, iiU, iiV, iiF, ijT, ijU, ijV, ijF ! bottom left corner + INTEGER :: iiTp, iiTm, ijTp, ijTm + REAL(wp) :: zcd, zmod ! local scalars + !!---------------------------------------------------------------------- + ! + ! get position, weight and mask + CALL icb_utl_pos( pi, pj, 'T', iiT, ijT, zwT, zmskT ) + CALL icb_utl_pos( pi, pj, 'U', iiU, ijU, zwU, zmskU ) + CALL icb_utl_pos( pi, pj, 'V', iiV, ijV, zwV, zmskV ) + CALL icb_utl_pos( pi, pj, 'F', iiF, ijF, zwF, zmskF ) + ! + ! metrics and coordinates + IF ( PRESENT(pe1 ) ) pe1 = icb_utl_bilin_e( e1t, REAL(e1u,sp), e1v, e1f, pi, pj ) ! scale factors + IF ( PRESENT(pe2 ) ) pe2 = icb_utl_bilin_e( e2t, e2u, REAL(e2v,sp), e2f, pi, pj ) + IF ( PRESENT(plon) ) plon= icb_utl_bilin_h( rlon_e, iiT, ijT, zwT, .true. ) + IF ( PRESENT(plat) ) plat= icb_utl_bilin_h( rlat_e, iiT, ijT, zwT, .false. ) + ! + IF ( PRESENT(pssu) ) pssu = icb_utl_bilin_h( ssu_e, iiU, ijU, zwU , .false. ) ! ocean velocities + IF ( PRESENT(pssv) ) pssv = icb_utl_bilin_h( ssv_e, iiV, ijV, zwV , .false. ) ! + IF ( PRESENT(psst) ) psst = icb_utl_bilin_h( sst_e, iiT, ijT, zwT * zmskT, .false. ) ! sst + IF ( PRESENT(psss) ) psss = icb_utl_bilin_h( sss_e, iiT, ijT, zwT * zmskT, .false. ) ! sss + IF ( PRESENT(pcn ) ) pcn = icb_utl_bilin_h( fr_e , iiT, ijT, zwT * zmskT, .false. ) ! ice concentration + IF ( PRESENT(pff ) ) pff = icb_utl_bilin_h( ff_e , iiF, ijF, zwF , .false. ) ! Coriolis parameter + ! + IF ( PRESENT(pua) .AND. PRESENT(pva) ) THEN + pua = icb_utl_bilin_h( ua_e, iiU, ijU, zwU * zmskU, .false. ) ! 10m wind + pva = icb_utl_bilin_h( va_e, iiV, ijV, zwV * zmskV, .false. ) ! here (ua,va) are stress => rough conversion from stress to speed + zcd = 1.22_wp * 1.5e-3_wp ! air density * drag coefficient + zmod = 1._wp / MAX( 1.e-20, SQRT( zcd * SQRT( pua*pua + pva*pva) ) ) + pua = pua * zmod ! note: stress module=0 necessarly implies ua=va=0 + pva = pva * zmod + END IF + ! + IF ( PRESENT(pui) ) pui = 0._wp + IF ( PRESENT(pvi) ) pvi = 0._wp + IF ( PRESENT(phi) ) phi = 0._wp + ! + ! Estimate SSH gradient in i- and j-direction (centred evaluation) + IF ( PRESENT(pssh_i) .AND. PRESENT(pssh_j) ) THEN + CALL icb_utl_pos( pi+0.1_wp, pj , 'T', iiTp, ijTp, zwTp, zmskTp ) + CALL icb_utl_pos( pi-0.1_wp, pj , 'T', iiTm, ijTm, zwTm, zmskTm ) + ! + IF ( .NOT. PRESENT(pe1) ) pe1 = icb_utl_bilin_e( e1t, REAL(e1u,sp), e1v, e1f, pi, pj ) + pssh_i = ( icb_utl_bilin_h( ssh_e, iiTp, ijTp, zwTp*zmskTp, .false. ) - & + & icb_utl_bilin_h( ssh_e, iiTm, ijTm, zwTm*zmskTm, .false. ) ) / ( 0.2_wp * pe1 ) + ! + CALL icb_utl_pos( pi , pj+0.1_wp, 'T', iiTp, ijTp, zwTp, zmskTp ) + CALL icb_utl_pos( pi , pj-0.1_wp, 'T', iiTm, ijTm, zwTm, zmskTm ) + ! + IF ( .NOT. PRESENT(pe2) ) pe2 = icb_utl_bilin_e( e2t, e2u, REAL(e2v,sp), e2f, pi, pj ) + pssh_j = ( icb_utl_bilin_h( ssh_e, iiTp, ijTp, zwTp*zmskTp, .false. ) - & + & icb_utl_bilin_h( ssh_e, iiTm, ijTm, zwTm*zmskTm, .false. ) ) / ( 0.2_wp * pe2 ) + END IF + ! + ! 3d interpolation + IF ( PRESENT(puoce) .AND. PRESENT(pvoce) ) THEN + ! no need to mask as 0 is a valid data for land + zw1d(1,:) = zwU(1) ; zw1d(2,:) = zwU(2) ; zw1d(3,:) = zwU(3) ; zw1d(4,:) = zwU(4) ; + puoce(:) = icb_utl_bilin_h( uoce_e , iiU, ijU, zw1d ) + + zw1d(1,:) = zwV(1) ; zw1d(2,:) = zwV(2) ; zw1d(3,:) = zwV(3) ; zw1d(4,:) = zwV(4) ; + pvoce(:) = icb_utl_bilin_h( voce_e , iiV, ijV, zw1d ) + END IF + + IF ( PRESENT(ptoce) ) THEN + ! for temperature we need to mask the weight properly + ! no need of extra halo as it is a T point variable + zw1d(1,:) = tmask(iiT ,ijT ,:) * zwT(1) * zmskT(1) + zw1d(2,:) = tmask(iiT+1,ijT ,:) * zwT(2) * zmskT(2) + zw1d(3,:) = tmask(iiT ,ijT+1,:) * zwT(3) * zmskT(3) + zw1d(4,:) = tmask(iiT+1,ijT+1,:) * zwT(4) * zmskT(4) + ptoce(:) = icb_utl_bilin_h( toce_e , iiT, ijT, zw1d ) + END IF + ! + IF ( PRESENT(pe3t) ) pe3t(:) = e3t_e(iiT,ijT,:) ! as in Nacho tarball need to be fix once we are able to reproduce Nacho results + ! + END SUBROUTINE icb_utl_interp + + SUBROUTINE icb_utl_pos( pi, pj, cd_type, kii, kij, pw, pmsk ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_bilin *** + !! + !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type + !! this version deals with extra halo points + !! + !! !!gm CAUTION an optional argument should be added to handle + !! the slip/no-slip conditions ==>>> to be done later + !! + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(IN) :: pi, pj ! targeted coordinates in (i,j) referential + CHARACTER(len=1) , INTENT(IN) :: cd_type ! point type + REAL(wp), DIMENSION(4), INTENT(OUT) :: pw, pmsk ! weight and mask + INTEGER , INTENT(OUT) :: kii, kij ! bottom left corner position in local domain + ! + REAL(wp) :: zwi, zwj ! distance to bottom left corner + INTEGER :: ierr + ! + !!---------------------------------------------------------------------- + ! + SELECT CASE ( cd_type ) + CASE ( 'T' ) + ! note that here there is no +0.5 added + ! since we're looking for four T points containing quadrant we're in of + ! current T cell + kii = MAX(0, INT( pi )) + kij = MAX(0, INT( pj )) ! T-point + zwi = pi - REAL(kii,wp) + zwj = pj - REAL(kij,wp) + CASE ( 'U' ) + kii = MAX(0, INT( pi-0.5_wp )) + kij = MAX(0, INT( pj )) ! U-point + zwi = pi - 0.5_wp - REAL(kii,wp) + zwj = pj - REAL(kij,wp) + CASE ( 'V' ) + kii = MAX(0, INT( pi )) + kij = MAX(0, INT( pj-0.5_wp )) ! V-point + zwi = pi - REAL(kii,wp) + zwj = pj - 0.5_wp - REAL(kij,wp) + CASE ( 'F' ) + kii = MAX(0, INT( pi-0.5_wp )) + kij = MAX(0, INT( pj-0.5_wp )) ! F-point + zwi = pi - 0.5_wp - REAL(kii,wp) + zwj = pj - 0.5_wp - REAL(kij,wp) + END SELECT + kii = kii + (nn_hls-1) + kij = kij + (nn_hls-1) + ! + ! compute weight + pw(1) = (1._wp-zwi) * (1._wp-zwj) + pw(2) = zwi * (1._wp-zwj) + pw(3) = (1._wp-zwi) * zwj + pw(4) = zwi * zwj + ! + ! find position in this processor. Prevent near edge problems (see #1389) + ! + IF (TRIM(cd_type) == 'T' ) THEN + ierr = 0 + IF ( kii < mig( 1 ) ) THEN ; ierr = ierr + 1 + ELSEIF( kii >= mig(jpi) ) THEN ; ierr = ierr + 1 + ENDIF + ! + IF ( kij < mjg( 1 ) ) THEN ; ierr = ierr + 1 + ELSEIF( kij >= mjg(jpj) ) THEN ; ierr = ierr + 1 + ENDIF + ! + IF ( ierr > 0 ) THEN + WRITE(numicb,*) 'bottom left corner T point out of bound' + WRITE(numicb,*) pi, kii, mig( 1 ), mig(jpi) + WRITE(numicb,*) pj, kij, mjg( 1 ), mjg(jpj) + WRITE(numicb,*) pmsk + CALL FLUSH(numicb) + CALL ctl_stop('STOP','icb_utl_bilin_e: an icebergs coordinates is out of valid range (out of bound error).' , & + & 'This can be fixed using rn_speed_limit=0.4 in &namberg.' , & + & 'More details in the corresponding iceberg.stat file (nn_verbose_level > 0).' ) + END IF + END IF + ! + ! find position in this processor. Prevent near edge problems (see #1389) + ! (PM) will be useless if extra halo is used in NEMO + ! + IF ( kii <= mig(1)-1 ) THEN ; kii = 0 + ELSEIF( kii > mig(jpi) ) THEN ; kii = jpi + ELSE ; kii = mi1(kii) + ENDIF + IF ( kij <= mjg(1)-1 ) THEN ; kij = 0 + ELSEIF( kij > mjg(jpj) ) THEN ; kij = jpj + ELSE ; kij = mj1(kij) + ENDIF + ! + ! define mask array + ! land value is not used in the interpolation + SELECT CASE ( cd_type ) + CASE ( 'T' ) + pmsk = (/tmask_e(kii,kij), tmask_e(kii+1,kij), tmask_e(kii,kij+1), tmask_e(kii+1,kij+1)/) + CASE ( 'U' ) + pmsk = (/umask_e(kii,kij), umask_e(kii+1,kij), umask_e(kii,kij+1), umask_e(kii+1,kij+1)/) + CASE ( 'V' ) + pmsk = (/vmask_e(kii,kij), vmask_e(kii+1,kij), vmask_e(kii,kij+1), vmask_e(kii+1,kij+1)/) + CASE ( 'F' ) + ! F case only used for coriolis, ff_f is not mask so zmask = 1 + pmsk = 1. + END SELECT + END SUBROUTINE icb_utl_pos + + REAL(wp) FUNCTION icb_utl_bilin_2d_h( pfld, pii, pij, pw, pllon ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_bilin *** + !! + !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type + !! this version deals with extra halo points + !! + !! !!gm CAUTION an optional argument should be added to handle + !! the slip/no-slip conditions ==>>> to be done later + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(0:jpi+1,0:jpj+1), INTENT(in) :: pfld ! field to be interpolated + REAL(wp), DIMENSION(4) , INTENT(in) :: pw ! weight + LOGICAL , INTENT(in) :: pllon ! input data is a longitude + INTEGER , INTENT(in) :: pii, pij ! bottom left corner + ! + REAL(wp), DIMENSION(4) :: zdat ! input data + !!---------------------------------------------------------------------- + ! + ! data + zdat(1) = pfld(pii ,pij ) + zdat(2) = pfld(pii+1,pij ) + zdat(3) = pfld(pii ,pij+1) + zdat(4) = pfld(pii+1,pij+1) + ! + IF( pllon .AND. MAXVAL(zdat) - MINVAL(zdat) > 90._wp ) THEN + WHERE( zdat < 0._wp ) zdat = zdat + 360._wp + ENDIF + ! + ! compute interpolated value + icb_utl_bilin_2d_h = ( zdat(1)*pw(1) + zdat(2)*pw(2) + zdat(3)*pw(3) + zdat(4)*pw(4) ) / MAX(1.e-20, pw(1)+pw(2)+pw(3)+pw(4)) + ! + IF( pllon .AND. icb_utl_bilin_2d_h > 180._wp ) icb_utl_bilin_2d_h = icb_utl_bilin_2d_h - 360._wp + ! + END FUNCTION icb_utl_bilin_2d_h + + FUNCTION icb_utl_bilin_3d_h( pfld, pii, pij, pw ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_bilin *** + !! + !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type + !! this version deals with extra halo points + !! + !! !!gm CAUTION an optional argument should be added to handle + !! the slip/no-slip conditions ==>>> to be done later + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(0:jpi+1,0:jpj+1, jpk), INTENT(in) :: pfld ! field to be interpolated + REAL(wp), DIMENSION(4,jpk) , INTENT(in) :: pw ! weight + INTEGER , INTENT(in) :: pii, pij ! bottom left corner + REAL(wp), DIMENSION(jpk) :: icb_utl_bilin_3d_h + ! + REAL(wp), DIMENSION(4,jpk) :: zdat ! input data + INTEGER :: jk + !!---------------------------------------------------------------------- + ! + ! data + zdat(1,:) = pfld(pii ,pij ,:) + zdat(2,:) = pfld(pii+1,pij ,:) + zdat(3,:) = pfld(pii ,pij+1,:) + zdat(4,:) = pfld(pii+1,pij+1,:) + ! + ! compute interpolated value + DO jk=1,jpk + icb_utl_bilin_3d_h(jk) = ( zdat(1,jk)*pw(1,jk) + zdat(2,jk)*pw(2,jk) + zdat(3,jk)*pw(3,jk) + zdat(4,jk)*pw(4,jk) ) & + & / MAX(1.e-20, pw(1,jk)+pw(2,jk)+pw(3,jk)+pw(4,jk)) + END DO + ! + END FUNCTION icb_utl_bilin_3d_h + + REAL(wp) FUNCTION icb_utl_bilin_e( pet, peu, pev, pef, pi, pj ) + !!---------------------------------------------------------------------- + !! *** FUNCTION dom_init *** + !! + !! ** Purpose : bilinear interpolation at berg location of horizontal scale factor + !! ** Method : interpolation done using the 4 nearest grid points among + !! t-, u-, v-, and f-points. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(in) :: peu, pev! horizontal scale factor to be interpolated at t-,u-,v- & f-pts + REAL(dp), DIMENSION(:,:), INTENT(in) :: pet, pef! horizontal scale factor to be interpolated at t-,u-,v- & f-pts + REAL(wp) , INTENT(IN) :: pi , pj ! iceberg position + ! + ! weights corresponding to corner points of a T cell quadrant + REAL(wp) :: zi, zj ! local real + INTEGER :: ii, ij ! bottom left corner coordinate in local domain + ! + ! values at corner points of a T cell quadrant + ! 00 = bottom left, 10 = bottom right, 01 = top left, 11 = top right + REAL(wp) :: ze00, ze10, ze01, ze11 + !!---------------------------------------------------------------------- + ! + ! cannot used iiT because need ii/ij reltaive to global indices not local one + ii = MAX(1, INT( pi )) ; ij = MAX(1, INT( pj )) ! left bottom T-point (i,j) indices + ! + ! fractional box spacing + ! 0 <= zi < 0.5, 0 <= zj < 0.5 --> NW quadrant of current T cell + ! 0.5 <= zi < 1 , 0 <= zj < 0.5 --> NE quadrant + ! 0 <= zi < 0.5, 0.5 <= zj < 1 --> SE quadrant + ! 0.5 <= zi < 1 , 0.5 <= zj < 1 --> SW quadrant + + zi = pi - REAL(ii,wp) !!gm use here mig, mjg arrays + zj = pj - REAL(ij,wp) + + ! conversion to local domain (no need to do a sanity check already done in icbpos) + ii = mi1(ii) + (nn_hls-1) + ij = mj1(ij) + (nn_hls-1) + ! + IF( 0.0_wp <= zi .AND. zi < 0.5_wp ) THEN + IF( 0.0_wp <= zj .AND. zj < 0.5_wp ) THEN ! NE quadrant + ! ! i=I i=I+1/2 + ze01 = pev(ii ,ij ) ; ze11 = pef(ii ,ij ) ! j=J+1/2 V ------- F + ze00 = pet(ii ,ij ) ; ze10 = peu(ii ,ij ) ! j=J T ------- U + zi = 2._wp * zi + zj = 2._wp * zj + ELSE ! SE quadrant + ! ! i=I i=I+1/2 + ze01 = pet(ii ,ij+1) ; ze11 = peu(ii ,ij+1) ! j=J+1 T ------- U + ze00 = pev(ii ,ij ) ; ze10 = pef(ii ,ij ) ! j=J+1/2 V ------- F + zi = 2._wp * zi + zj = 2._wp * (zj-0.5_wp) + ENDIF + ELSE + IF( 0.0_wp <= zj .AND. zj < 0.5_wp ) THEN ! NW quadrant + ! ! i=I i=I+1/2 + ze01 = pef(ii ,ij ) ; ze11 = pev(ii+1,ij) ! j=J+1/2 F ------- V + ze00 = peu(ii ,ij ) ; ze10 = pet(ii+1,ij) ! j=J U ------- T + zi = 2._wp * (zi-0.5_wp) + zj = 2._wp * zj + ELSE ! SW quadrant + ! ! i=I+1/2 i=I+1 + ze01 = peu(ii ,ij+1) ; ze11 = pet(ii+1,ij+1) ! j=J+1 U ------- T + ze00 = pef(ii ,ij ) ; ze10 = pev(ii+1,ij ) ! j=J+1/2 F ------- V + zi = 2._wp * (zi-0.5_wp) + zj = 2._wp * (zj-0.5_wp) + ENDIF + ENDIF + ! + icb_utl_bilin_e = ( ze01 * (1._wp-zi) + ze11 * zi ) * zj & + & + ( ze00 * (1._wp-zi) + ze10 * zi ) * (1._wp-zj) + ! + END FUNCTION icb_utl_bilin_e + + SUBROUTINE icb_utl_getkb( kb, pe3, pD ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_getkb *** + !! + !! ** Purpose : compute the latest level affected by icb + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(out):: kb + REAL(wp), DIMENSION(:), INTENT(in) :: pe3 + REAL(wp), INTENT(in) :: pD + !! + INTEGER :: jk + REAL(wp) :: zdepw + !!---------------------------------------------------------------------- + !! + zdepw = pe3(1) ; kb = 2 + DO WHILE ( zdepw < pD) + zdepw = zdepw + pe3(kb) + kb = kb + 1 + END DO + kb = MIN(kb - 1,jpk) + END SUBROUTINE icb_utl_getkb + + SUBROUTINE icb_utl_zavg(pzavg, pdat, pe3, pD, kb ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_getkb *** + !! + !! ** Purpose : compute the vertical average of ocean properties affected by icb + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kb ! deepest level affected by icb + REAL(wp), DIMENSION(:), INTENT(in ) :: pe3, pdat ! vertical profile + REAL(wp), INTENT(in ) :: pD ! draft + REAL(wp), INTENT(out) :: pzavg ! z average + !!---------------------------------------------------------------------- + INTEGER :: jk + REAL(wp) :: zdep + !!---------------------------------------------------------------------- + pzavg = 0.0 ; zdep = 0.0 + DO jk = 1,kb-1 + pzavg = pzavg + pe3(jk)*pdat(jk) + zdep = zdep + pe3(jk) + END DO + ! if kb is limited by mbkt => bottom value is used between bathy and icb tail + ! if kb not limited by mbkt => ocean value over mask is used (ie 0.0 for u, v) + pzavg = ( pzavg + (pD - zdep)*pdat(kb)) / pD + END SUBROUTINE icb_utl_zavg + + SUBROUTINE icb_utl_add( bergvals, ptvals ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_add *** + !! + !! ** Purpose : add a new berg to the iceberg list + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), INTENT(in) :: bergvals + TYPE(point) , INTENT(in) :: ptvals + ! + TYPE(iceberg), POINTER :: new => NULL() + !!---------------------------------------------------------------------- + ! + new => NULL() + CALL icb_utl_create( new, bergvals, ptvals ) + CALL icb_utl_insert( new ) + new => NULL() ! Clear new + ! + END SUBROUTINE icb_utl_add + + + SUBROUTINE icb_utl_create( berg, bergvals, ptvals ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_create *** + !! + !! ** Purpose : add a new berg to the iceberg list + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), INTENT(in) :: bergvals + TYPE(point) , INTENT(in) :: ptvals + TYPE(iceberg), POINTER :: berg + ! + TYPE(point) , POINTER :: pt + INTEGER :: istat + !!---------------------------------------------------------------------- + ! + IF( ASSOCIATED(berg) ) CALL ctl_stop( 'icebergs, icb_utl_create: berg already associated' ) + ALLOCATE(berg, STAT=istat) + IF( istat /= 0 ) CALL ctl_stop( 'failed to allocate iceberg' ) + berg%number(:) = bergvals%number(:) + berg%mass_scaling = bergvals%mass_scaling + berg%prev => NULL() + berg%next => NULL() + ! + ALLOCATE(pt, STAT=istat) + IF( istat /= 0 ) CALL ctl_stop( 'failed to allocate first iceberg point' ) + pt = ptvals + berg%current_point => pt + ! + END SUBROUTINE icb_utl_create + + + SUBROUTINE icb_utl_insert( newberg ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_insert *** + !! + !! ** Purpose : add a new berg to the iceberg list + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: newberg + ! + TYPE(iceberg), POINTER :: this, prev, last + !!---------------------------------------------------------------------- + ! + IF( ASSOCIATED( first_berg ) ) THEN + last => first_berg + DO WHILE (ASSOCIATED(last%next)) + last => last%next + ENDDO + newberg%prev => last + last%next => newberg + last => newberg + ELSE ! list is empty so create it + first_berg => newberg + ENDIF + ! + END SUBROUTINE icb_utl_insert + + + REAL(wp) FUNCTION icb_utl_yearday(kmon, kday, khr, kmin, ksec) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_yearday *** + !! + !! ** Purpose : + !! + ! sga - improved but still only applies to 365 day year, need to do this properly + ! + !!gm all these info are already known in daymod, no??? + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kmon, kday, khr, kmin, ksec + ! + INTEGER, DIMENSION(12) :: imonths = (/ 0,31,28,31,30,31,30,31,31,30,31,30 /) + !!---------------------------------------------------------------------- + ! + icb_utl_yearday = REAL( SUM( imonths(1:kmon) ), wp ) + icb_utl_yearday = icb_utl_yearday + REAL(kday-1,wp) + (REAL(khr,wp) + (REAL(kmin,wp) + REAL(ksec,wp)/60.)/60.)/24. + ! + END FUNCTION icb_utl_yearday + + !!------------------------------------------------------------------------- + + SUBROUTINE icb_utl_delete( first, berg ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_delete *** + !! + !! ** Purpose : + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: first, berg + !!---------------------------------------------------------------------- + ! Connect neighbors to each other + IF ( ASSOCIATED(berg%prev) ) THEN + berg%prev%next => berg%next + ELSE + first => berg%next + ENDIF + IF (ASSOCIATED(berg%next)) berg%next%prev => berg%prev + ! + CALL icb_utl_destroy(berg) + ! + END SUBROUTINE icb_utl_delete + + + SUBROUTINE icb_utl_destroy( berg ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_destroy *** + !! + !! ** Purpose : remove a single iceberg instance + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: berg + !!---------------------------------------------------------------------- + ! + ! Remove any points + IF( ASSOCIATED( berg%current_point ) ) DEALLOCATE( berg%current_point ) + ! + DEALLOCATE(berg) + ! + END SUBROUTINE icb_utl_destroy + + + SUBROUTINE icb_utl_track( knum, cd_label, kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_track *** + !! + !! ** Purpose : + !! + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(nkounts) :: knum ! iceberg number + CHARACTER(len=*) :: cd_label ! + INTEGER :: kt ! timestep number + ! + TYPE(iceberg), POINTER :: this + LOGICAL :: match + INTEGER :: k + !!---------------------------------------------------------------------- + ! + this => first_berg + DO WHILE( ASSOCIATED(this) ) + match = .TRUE. + DO k = 1, nkounts + IF( this%number(k) /= knum(k) ) match = .FALSE. + END DO + IF( match ) CALL icb_utl_print_berg(this, kt) + this => this%next + END DO + ! + END SUBROUTINE icb_utl_track + + + SUBROUTINE icb_utl_print_berg( berg, kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_print_berg *** + !! + !! ** Purpose : print one + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: berg + TYPE(point) , POINTER :: pt + INTEGER :: kt ! timestep number + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + pt => berg%current_point + WRITE(numicb, 9200) kt, berg%number(1), & + pt%xi, pt%yj, pt%lon, pt%lat, pt%uvel, pt%vvel, & + pt%ssu, pt%ssv, pt%ua, pt%va, pt%ui, pt%vi + CALL flush( numicb ) + 9200 FORMAT(5x,i5,2x,i10,6(2x,2f10.4)) + ! + END SUBROUTINE icb_utl_print_berg + + + SUBROUTINE icb_utl_print( cd_label, kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_print *** + !! + !! ** Purpose : print many + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*) :: cd_label + INTEGER, INTENT(IN) :: kt ! timestep number + ! + INTEGER :: ibergs, inbergs + TYPE(iceberg), POINTER :: this + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + this => first_berg + IF( ASSOCIATED(this) ) THEN + WRITE(numicb,'(a," pe=(",i3,")")' ) cd_label, narea + WRITE(numicb,'(a8,4x,a6,12x,a5,15x,a7,19x,a3,17x,a5,17x,a5,17x,a5)' ) & + & 'timestep', 'number', 'xi,yj','lon,lat','u,v','ssu,ssv','ua,va','ui,vi' + ENDIF + DO WHILE( ASSOCIATED(this) ) + CALL icb_utl_print_berg(this, kt) + this => this%next + END DO + ibergs = icb_utl_count() + inbergs = ibergs + CALL mpp_sum('icbutl', inbergs) + IF( ibergs > 0 ) WRITE(numicb,'(a," there are",i5," bergs out of",i6," on PE ",i4)') & + & cd_label, ibergs, inbergs, narea + ! + END SUBROUTINE icb_utl_print + + + SUBROUTINE icb_utl_incr() + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_incr *** + !! + !! ** Purpose : + !! + ! Small routine for coping with very large integer values labelling icebergs + ! num_bergs is a array of integers + ! the first member is incremented in steps of jpnij starting from narea + ! this means each iceberg is labelled with a unique number + ! when this gets to the maximum allowed integer the second and subsequent members are + ! used to count how many times the member before cycles + !!---------------------------------------------------------------------- + INTEGER :: ii, ibig + !!---------------------------------------------------------------------- + + ibig = HUGE(num_bergs(1)) + IF( ibig-jpnij < num_bergs(1) ) THEN + num_bergs(1) = narea + DO ii = 2,nkounts + IF( num_bergs(ii) == ibig ) THEN + num_bergs(ii) = 0 + IF( ii == nkounts ) CALL ctl_stop('Sorry, run out of iceberg number space') + ELSE + num_bergs(ii) = num_bergs(ii) + 1 + EXIT + ENDIF + END DO + ELSE + num_bergs(1) = num_bergs(1) + jpnij + ENDIF + ! + END SUBROUTINE icb_utl_incr + + + INTEGER FUNCTION icb_utl_count() + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_count *** + !! + !! ** Purpose : + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: this + !!---------------------------------------------------------------------- + ! + icb_utl_count = 0 + this => first_berg + DO WHILE( ASSOCIATED(this) ) + icb_utl_count = icb_utl_count+1 + this => this%next + END DO + ! + END FUNCTION icb_utl_count + + + REAL(wp) FUNCTION icb_utl_mass( first, justbits, justbergs ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_mass *** + !! + !! ** Purpose : compute the mass all iceberg, all berg bits or all bergs. + !!---------------------------------------------------------------------- + TYPE(iceberg) , POINTER :: first + TYPE(point) , POINTER :: pt + LOGICAL, INTENT(in), OPTIONAL :: justbits, justbergs + ! + TYPE(iceberg), POINTER :: this + !!---------------------------------------------------------------------- + icb_utl_mass = 0._wp + this => first + ! + IF( PRESENT( justbergs ) ) THEN + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_mass = icb_utl_mass + pt%mass * this%mass_scaling + this => this%next + END DO + ELSEIF( PRESENT(justbits) ) THEN + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_mass = icb_utl_mass + pt%mass_of_bits * this%mass_scaling + this => this%next + END DO + ELSE + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_mass = icb_utl_mass + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling + this => this%next + END DO + ENDIF + ! + END FUNCTION icb_utl_mass + + + REAL(wp) FUNCTION icb_utl_heat( first, justbits, justbergs ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_heat *** + !! + !! ** Purpose : compute the heat in all iceberg, all bergies or all bergs. + !!---------------------------------------------------------------------- + TYPE(iceberg) , POINTER :: first + LOGICAL, INTENT(in), OPTIONAL :: justbits, justbergs + ! + TYPE(iceberg) , POINTER :: this + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + icb_utl_heat = 0._wp + this => first + ! + IF( PRESENT( justbergs ) ) THEN + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_heat = icb_utl_heat + pt%mass * this%mass_scaling * pt%heat_density + this => this%next + END DO + ELSEIF( PRESENT(justbits) ) THEN + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_heat = icb_utl_heat + pt%mass_of_bits * this%mass_scaling * pt%heat_density + this => this%next + END DO + ELSE + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_heat = icb_utl_heat + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling * pt%heat_density + this => this%next + END DO + ENDIF + ! + END FUNCTION icb_utl_heat + + SUBROUTINE test_icb_utl_getkb + !!---------------------------------------------------------------------- + !! *** FUNCTION test_icb_utl_getkb *** + !! + !! ** Purpose : Test routine icb_utl_getkb, icb_utl_zavg + !! ** Methode : Call each subroutine with specific input data + !! What should be the output is easy to determined and check + !! if NEMO return the correct answer. + !! ** Comments : not called, if needed a CALL test_icb_utl_getkb need to be added in icb_step + !!---------------------------------------------------------------------- + INTEGER :: ikb + REAL(wp) :: zout + REAL(wp) :: zD + REAL(wp), DIMENSION(jpk) :: ze3, zin + WRITE(numout,*) 'Test icb_utl_getkb : ' + zD = 0.0 ; ze3= 20.0 + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) + CALL icb_utl_getkb(ikb, ze3, zD) + WRITE(numout,*) 'OUTPUT : kb = ',ikb + + zD = 8000000.0 ; ze3= 20.0 + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) + CALL icb_utl_getkb(ikb, ze3, zD) + WRITE(numout,*) 'OUTPUT : kb = ',ikb + + zD = 80.0 ; ze3= 20.0 + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) + CALL icb_utl_getkb(ikb, ze3, zD) + WRITE(numout,*) 'OUTPUT : kb = ',ikb + + zD = 85.0 ; ze3= 20.0 + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) + CALL icb_utl_getkb(ikb, ze3, zD) + WRITE(numout,*) 'OUTPUT : kb = ',ikb + + zD = 75.0 ; ze3= 20.0 + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) + CALL icb_utl_getkb(ikb, ze3, zD) + WRITE(numout,*) 'OUTPUT : kb = ',ikb + + WRITE(numout,*) '==================================' + WRITE(numout,*) 'Test icb_utl_zavg' + zD = 0.0 ; ze3= 20.0 ; zin=1.0 + CALL icb_utl_getkb(ikb, ze3, zD) + CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb + WRITE(numout,*) 'OUTPUT : zout = ',zout + + zD = 50.0 ; ze3= 20.0 ; zin=1.0; zin(3:jpk) = 0.0 + CALL icb_utl_getkb(ikb, ze3, zD) + CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb + WRITE(numout,*) 'OUTPUT : zout = ',zout + CALL FLUSH(numout) + + zD = 80.0 ; ze3= 20.0 ; zin=1.0; zin(3:jpk) = 0.0 + CALL icb_utl_getkb(ikb, ze3, zD) + CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb + WRITE(numout,*) 'OUTPUT : zout = ',zout + + zD = 80 ; ze3= 20.0 ; zin=1.0 ; zin(3:jpk) = 0.0 + CALL icb_utl_getkb(ikb, ze3, zD) + ikb = 2 + CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb + WRITE(numout,*) 'OUTPUT : zout = ',zout + + CALL FLUSH(numout) + + END SUBROUTINE test_icb_utl_getkb + + !!====================================================================== +END MODULE icbutl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/in_out_manager.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/in_out_manager.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0230ca22c1380889636aed265eaf01570c8a3886 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/in_out_manager.f90 @@ -0,0 +1,193 @@ + + + + + + + + + + + + + +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_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 + + +!$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 + + + + + !!---------------------------------------------------------------------- + !! 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/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/iom.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/iom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..31b999a0f6868368a9e4a6819d508d0a11eb259c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/iom.f90 @@ -0,0 +1,2694 @@ + + + + + + + + + + + + + +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 + USE phycst ! physical constants + USE dianam ! build name of file + USE xios + USE ioipsl, ONLY : ju2ymds ! for calendar + USE crs ! Grid coarsening + 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 + + LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .TRUE. !: iom_put flag + 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 + 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 + 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 + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom.F90 15033 2021-06-21 10:24:45Z smasson $ + !! 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 + ! + TYPE(xios_duration) :: dtime = xios_duration(0, 0, 0, 0, 0, 0) + TYPE(xios_date) :: start_date + CHARACTER(len=lc) :: clname + INTEGER :: irefyear, irefmonth, irefday + INTEGER :: ji + LOGICAL :: llrst_context ! is context related to restart + LOGICAL :: llrstr, llrstw + INTEGER :: inum + ! + 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 = cdname + IF( TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(cdname) + 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) /) ) + 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 ) + ! + ! + END SUBROUTINE iom_init + + SUBROUTINE iom_init_closedef(cdname) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE iom_init_closedef *** + !!---------------------------------------------------------------------- + !! + !! ** Purpose : Closure of context definition + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), OPTIONAL, INTENT(IN) :: cdname + 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 + + 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 + + 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) + 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 + 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)) + 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 + 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 + 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" + 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 + 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 ) + 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") + 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 + TYPE(xios_context) :: nemo_hdl + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + CALL xios_get_handle(TRIM(cdname),nemo_hdl) + ELSE + CALL xios_get_handle(TRIM(Agrif_CFixed())//"_"//TRIM(cdname),nemo_hdl) + ENDIF + ! + CALL xios_set_current_context(nemo_hdl) + ! + 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,'/') + 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(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) + 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(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) + 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(dp) :: 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 1 is defined +!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) + 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( xios_field_is_active( cdname, at_current_timestep_arg = .TRUE. ) ) THEN + z2d(:,:) = 0._wp + CALL xios_recv_field( cdname, z2d) + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 +!!clem zz(:,:)=pfield0d +!!clem CALL xios_send_field(cdname, zz) + CALL xios_send_field(cdname, (/pfield0d/)) + 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 +!!clem zz(:,:)=pfield0d +!!clem CALL xios_send_field(cdname, zz) + CALL xios_send_field(cdname, (/pfield0d/)) + END SUBROUTINE iom_p0d_dp + + + SUBROUTINE iom_p1d_sp( cdname, pfield1d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:), INTENT(in) :: pfield1d + CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) + END SUBROUTINE iom_p1d_sp + + SUBROUTINE iom_p1d_dp( cdname, pfield1d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:), INTENT(in) :: pfield1d + CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) + 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( 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 + 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( 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 + 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( 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 + 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( 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 + 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( 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 + 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( 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 + ENDIF + END SUBROUTINE iom_p4d_dp + + !!---------------------------------------------------------------------- + !! '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 + !!---------------------------------------------------------------------- + clname = cdname + IF( TRIM(Agrif_CFixed()) .NE. '0' ) clname = TRIM(Agrif_CFixed())//"_"//clname + 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(ntsi-(0):ntei+(0),ntsj-(0):ntej+(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 jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 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 DO ; END DO + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 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 DO ; END DO + ! + 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 + CHARACTER(LEN=20) :: clfreq + CHARACTER(LEN=20) :: cldate + INTEGER :: idx + INTEGER :: jn + INTEGER :: itrlen + INTEGER :: iyear, imonth, iday, isec + REAL(dp) :: 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. TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) + 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(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(dp) :: 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 + + + LOGICAL FUNCTION iom_use( cdname ) + CHARACTER(LEN=*), INTENT(in) :: cdname + iom_use = xios_field_is_active( cdname ) + 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 + ! get missing value + CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val ) + pmiss_val = ztmp_pmiss_val + END SUBROUTINE iom_miss_val + + !!====================================================================== +END MODULE iom diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/iom_def.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/iom_def.f90 new file mode 100644 index 0000000000000000000000000000000000000000..12dba195d060bb07546501d698fdeee5f948c12e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/iom_def.f90 @@ -0,0 +1,88 @@ + + + + + + + + + + + + + +MODULE iom_def + !!====================================================================== + !! *** MODULE iom_def *** + !! IOM variables definitions + !!====================================================================== + !! History : 9.0 ! 2006 09 (S. Masson) Original code + !! - ! 2007 07 (D. Storkey) Add uldname + !! 4.0 ! 2017-11 (M. Andrejczuk) Extend IOM interface to write any 3D fields + !!---------------------------------------------------------------------- + USE par_kind + USE netcdf + + IMPLICIT NONE + PRIVATE + + INTEGER, PARAMETER, PUBLIC :: jpdom_global = 1 !: ( 1 :Ni0glo, 1 :Nj0glo) + INTEGER, PARAMETER, PUBLIC :: jpdom_local = 2 !: (Nis0: Nie0 ,Njs0: Nje0 ) + INTEGER, PARAMETER, PUBLIC :: jpdom_unknown = 3 !: No dimension checking + INTEGER, PARAMETER, PUBLIC :: jpdom_auto = 4 !: + INTEGER, PARAMETER, PUBLIC :: jpdom_auto_xy = 5 !: Automatically set horizontal dimensions only + + INTEGER, PARAMETER, PUBLIC :: jp_r8 = 200 !: write REAL(8) + INTEGER, PARAMETER, PUBLIC :: jp_r4 = 201 !: write REAL(4) + INTEGER, PARAMETER, PUBLIC :: jp_i4 = 202 !: write INTEGER(4) + INTEGER, PARAMETER, PUBLIC :: jp_i2 = 203 !: write INTEGER(2) + INTEGER, PARAMETER, PUBLIC :: jp_i1 = 204 !: write INTEGER(1) + + INTEGER, PARAMETER, PUBLIC :: jpmax_files = 100 !: maximum number of simultaneously opened file + INTEGER, PARAMETER, PUBLIC :: jpmax_vars = 1200 !: maximum number of variables in one file + INTEGER, PARAMETER, PUBLIC :: jpmax_dims = 4 !: maximum number of dimensions for one variable + INTEGER, PARAMETER, PUBLIC :: jpmax_digits = 9 !: maximum number of digits for the cpu number in the file name + +!$AGRIF_DO_NOT_TREAT + INTEGER, PUBLIC :: iom_open_init = 0 !: used to initialize iom_file(:)%nfid to 0 +!XIOS write restart + LOGICAL, PUBLIC :: lwxios = .FALSE. !: write single file restart using XIOS + INTEGER, PUBLIC :: nxioso = 0 !: type of restart file when writing using XIOS 1 - single, 2 - multiple +!XIOS read restart + LOGICAL, PUBLIC :: lrxios = .FALSE. !: read single file restart using XIOS main switch + LOGICAL, PUBLIC :: lxios_sini = .FALSE. ! is restart in a single file + + + + TYPE, PUBLIC :: file_descriptor + CHARACTER(LEN=240) :: name !: name of the file + CHARACTER(LEN=3 ) :: comp !: name of component opening the file ('OCE', 'ICE'...) + INTEGER :: nfid !: identifier of the file (0 if closed) + !: jpioipsl option has been removed) + INTEGER :: nvars !: number of identified varibles in the file + INTEGER :: iduld !: id of the unlimited dimension + INTEGER :: lenuld !: length of the unlimited dimension (number of records in file) + INTEGER :: irec !: writing record position + CHARACTER(LEN=32) :: uldname !: name of the unlimited dimension + CHARACTER(LEN=32), DIMENSION(jpmax_vars) :: cn_var !: names of the variables + INTEGER, DIMENSION(jpmax_vars) :: nvid !: id of the variables + INTEGER, DIMENSION(jpmax_vars) :: ndims !: number of dimensions of the variables + LOGICAL, DIMENSION(jpmax_vars) :: luld !: variable using the unlimited dimension + INTEGER, DIMENSION(jpmax_dims,jpmax_vars) :: dimsz !: size of variables dimensions + REAL(kind=wp), DIMENSION(jpmax_vars) :: scf !: scale_factor of the variables + REAL(kind=wp), DIMENSION(jpmax_vars) :: ofs !: add_offset of the variables + END TYPE file_descriptor + TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC :: iom_file !: array containing the info for all opened files +!$AGRIF_END_DO_NOT_TREAT + ! + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom_def.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE iom_def diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/iom_nf90.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/iom_nf90.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a6fe555f3d8a38ccc6df0b14bbf7691f3366f1c6 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/iom_nf90.f90 @@ -0,0 +1,751 @@ + + + + + + + + + + + + + +MODULE iom_nf90 + !!====================================================================== + !! *** MODULE iom_nf90 *** + !! Input/Output manager : Library to read input files with NF90 (only fliocom module) + !!====================================================================== + !! History : 9.0 ! 05 12 (J. Belier) Original code + !! 9.0 ! 06 02 (S. Masson) Adaptation to NEMO + !! " ! 07 07 (D. Storkey) Changes to iom_nf90_gettime + !! 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 sbc_oce, ONLY: ght_abl ! abl vertical level number and height + USE lbclnk ! lateal boundary condition / mpp exchanges + USE iom_def ! iom variables definitions + USE netcdf ! NetCDF library + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC iom_nf90_open , iom_nf90_close, iom_nf90_varid, iom_nf90_get, iom_nf90_rstput + PUBLIC iom_nf90_chkatt, iom_nf90_getatt, iom_nf90_putatt + PUBLIC iom_nf90_check + + INTERFACE iom_nf90_get + MODULE PROCEDURE iom_nf90_g0d_sp + MODULE PROCEDURE iom_nf90_g0d_dp, iom_nf90_g123d_dp + END INTERFACE + INTERFACE iom_nf90_rstput + MODULE PROCEDURE iom_nf90_rp0123d_dp + END INTERFACE + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom_nf90.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdlev, cdcomp ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_open *** + !! + !! ** Purpose : open an input file with NF90 + !!--------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(inout) :: cdname ! File name + INTEGER , INTENT( out) :: kiomid ! nf90 identifier of the opened file + LOGICAL , INTENT(in ) :: ldwrt ! read or write the file? + LOGICAL , INTENT(in ) :: ldok ! check the existence + INTEGER , INTENT(in ), OPTIONAL :: kdlev ! size of the ice/abl third dimension + CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cdcomp ! name of component calling iom_nf90_open + + CHARACTER(LEN=256) :: clinfo ! info character + CHARACTER(LEN=256) :: cltmp ! temporary character + CHARACTER(LEN=12 ) :: clfmt ! writing format + CHARACTER(LEN=3 ) :: clcomp ! name of component calling iom_nf90_open + INTEGER :: idg ! number of digits + INTEGER :: iln ! lengths of character + INTEGER :: istop ! temporary storage of nstop + INTEGER :: if90id ! nf90 identifier of the opened file + INTEGER :: idmy ! dummy variable + INTEGER :: jl ! loop variable + INTEGER :: ichunk ! temporary storage of nn_chunksz + INTEGER :: imode ! creation mode flag: NF90_CLOBBER or NF90_NOCLOBBER or NF90_HDF5 + INTEGER :: ihdf5 ! local variable for retrieval of value for NF90_HDF5 + LOGICAL :: llclobber ! local definition of ln_clobber + !--------------------------------------------------------------------- + ! + clinfo = ' iom_nf90_open ~~~ ' + istop = nstop ! store the actual value of nstop + ! + ! !number of vertical levels + IF( PRESENT(cdcomp) ) THEN + IF( .NOT. PRESENT(kdlev) ) CALL ctl_stop( 'iom_nf90_open: cdcomp and kdlev must both be present' ) + clcomp = cdcomp ! use input value + ELSE + clcomp = 'OCE' ! by default + ENDIF + ! + IF( nn_chunksz > 0 ) THEN ; ichunk = nn_chunksz + ELSE ; ichunk = NF90_SIZEHINT_DEFAULT + ENDIF + ! + llclobber = ldwrt .AND. ln_clobber + IF( ldok .AND. .NOT. llclobber ) THEN !== Open existing file ==! + ! !=========================! + IF( ldwrt ) THEN ! ... in write mode + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' open existing file: '//TRIM(cdname)//' in WRITE mode' + IF( snc4set%luse ) THEN + CALL iom_nf90_check(NF90_OPEN( TRIM(cdname), NF90_WRITE , if90id ), clinfo) + ELSE + CALL iom_nf90_check(NF90_OPEN( TRIM(cdname), NF90_WRITE , if90id, chunksize = ichunk ), clinfo) + ENDIF + CALL iom_nf90_check(NF90_SET_FILL( if90id, NF90_NOFILL, idmy ), clinfo) + ELSE ! ... in read mode + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' open existing file: '//TRIM(cdname)//' in READ mode' + CALL iom_nf90_check(NF90_OPEN( TRIM(cdname), NF90_NOWRITE, if90id, chunksize = ichunk ), clinfo) + ENDIF + ELSE !== the file doesn't exist ==! (or we overwrite it) + ! !============================! + iln = INDEX( cdname, '.nc' ) + IF( ldwrt ) THEN !* the file should be open in write mode so we create it... + IF( jpnij > 1 ) THEN + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' + WRITE(cltmp,clfmt) cdname(1:iln-1), '_', narea-1, '.nc' + cdname = TRIM(cltmp) + ENDIF + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' create new file: '//TRIM(cdname)//' in WRITE mode' + + IF( llclobber ) THEN ; imode = IOR( NF90_64BIT_OFFSET, NF90_CLOBBER ) + ELSE ; imode = IOR( NF90_64BIT_OFFSET, NF90_NOCLOBBER ) + ENDIF + IF( snc4set%luse ) THEN + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' creating file: '//TRIM(cdname)//' in hdf5 (netcdf4) mode' + CALL GET_NF90_SYMBOL("NF90_HDF5", ihdf5) + IF( llclobber ) THEN ; imode = IOR(ihdf5, NF90_CLOBBER) + ELSE ; imode = IOR(ihdf5, NF90_NOCLOBBER) + ENDIF + CALL iom_nf90_check(NF90_CREATE( TRIM(cdname), imode, if90id ), clinfo) + ELSE + CALL iom_nf90_check(NF90_CREATE( TRIM(cdname), imode, if90id, chunksize = ichunk ), clinfo) + ENDIF + CALL iom_nf90_check(NF90_SET_FILL( if90id, NF90_NOFILL, idmy ), clinfo) + ! define dimensions + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x', Ni_0, idmy ), clinfo) + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', Nj_0, idmy ), clinfo) + SELECT CASE (clcomp) + CASE ('OCE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo) + CASE ('ICE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat', kdlev, idmy ), clinfo) + CASE ('ABL') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', kdlev, idmy ), clinfo) + CASE ('SED') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numsed', kdlev, idmy ), clinfo) + CASE DEFAULT ; CALL ctl_stop( 'iom_nf90_open unknown component type' ) + END SELECT + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) + ! global attributes + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo) + ELSE !* the file should be open for read mode so it must exist... + CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' ) + ENDIF + ENDIF + ! + ! start to fill file informations + ! ============= + IF( istop == nstop ) THEN ! no error within this routine +!does not work with some compilers kiomid = MINLOC(iom_file(:)%nfid, dim = 1) + kiomid = 0 + DO jl = jpmax_files, 1, -1 + IF( iom_file(jl)%nfid == 0 ) kiomid = jl + ENDDO + iom_file(kiomid)%name = TRIM(cdname) + iom_file(kiomid)%comp = clcomp + iom_file(kiomid)%nfid = if90id + iom_file(kiomid)%nvars = 0 + iom_file(kiomid)%irec = -1 ! useless for NetCDF files, used to know if the file is in define mode + CALL iom_nf90_check(NF90_Inquire(if90id, unlimitedDimId = iom_file(kiomid)%iduld), clinfo) + IF( iom_file(kiomid)%iduld .GE. 0 ) THEN + CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, iom_file(kiomid)%iduld, & + & name = iom_file(kiomid)%uldname, & + & len = iom_file(kiomid)%lenuld ), clinfo ) + ENDIF + IF(lwp) WRITE(numout,*) ' ---> '//TRIM(cdname)//' OK' + ELSE + kiomid = 0 ! return error flag + ENDIF + ! + END SUBROUTINE iom_nf90_open + + + SUBROUTINE iom_nf90_close( kiomid ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_close *** + !! + !! ** Purpose : close an input file with NF90 + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: kiomid ! iom identifier of the file to be closed + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + clinfo = ' iom_nf90_close , file: '//TRIM(iom_file(kiomid)%name) + CALL iom_nf90_check(NF90_CLOSE(iom_file(kiomid)%nfid), clinfo) + END SUBROUTINE iom_nf90_close + + + FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims, lduld ) + !!----------------------------------------------------------------------- + !! *** FUNCTION iom_varid *** + !! + !! ** Purpose : get the id of a variable in a file with NF90 + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! file Identifier + CHARACTER(len=*) , INTENT(in ) :: cdvar ! name of the variable + INTEGER , INTENT(in ) :: kiv ! + 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) + ! + INTEGER :: iom_nf90_varid ! iom variable Id + INTEGER :: if90id ! nf90 file identifier + INTEGER :: ji ! dummy loop index + INTEGER :: ivarid ! NetCDF variable Id + INTEGER :: i_nvd ! number of dimension of the variable + INTEGER, DIMENSION(jpmax_dims) :: idimid ! dimension ids of the variable + LOGICAL :: llok ! ok test + CHARACTER(LEN=100) :: clinfo ! info character + !!----------------------------------------------------------------------- + clinfo = ' iom_nf90_varid, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(cdvar) + iom_nf90_varid = 0 ! default definition + IF( PRESENT(kdimsz) ) kdimsz(:) = 0 ! default definition + if90id = iom_file(kiomid)%nfid ! get back NetCDF file id + ! + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr ! does the variable exist in the file + IF( llok ) THEN + iom_nf90_varid = kiv + iom_file(kiomid)%nvars = kiv + iom_file(kiomid)%nvid(kiv) = ivarid + iom_file(kiomid)%cn_var(kiv) = TRIM(cdvar) + CALL iom_nf90_check(NF90_Inquire_Variable(if90id, ivarid, ndims = i_nvd), clinfo) ! number of dimensions + iom_file(kiomid)%ndims(kiv) = i_nvd + CALL iom_nf90_check(NF90_Inquire_Variable(if90id, ivarid, dimids = idimid(1:i_nvd)), clinfo) ! dimensions ids + iom_file(kiomid)%luld(kiv) = .FALSE. ! default value + iom_file(kiomid)%dimsz(:,kiv) = 0 ! reset dimsz in case previously used + DO ji = 1, i_nvd ! dimensions size + CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, idimid(ji), len = iom_file(kiomid)%dimsz(ji,kiv)), clinfo) + IF( idimid(ji) == iom_file(kiomid)%iduld ) iom_file(kiomid)%luld(kiv) = .TRUE. ! unlimited dimension? + END DO + !---------- Deal with scale_factor and add_offset + llok = NF90_Inquire_attribute(if90id, ivarid, 'scale_factor') == nf90_noerr + IF( llok) THEN + CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, 'scale_factor', iom_file(kiomid)%scf(kiv)), clinfo) + ELSE + iom_file(kiomid)%scf(kiv) = 1. + END IF + llok = NF90_Inquire_attribute(if90id, ivarid, 'add_offset') == nf90_noerr + IF( llok ) THEN + CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, 'add_offset', iom_file(kiomid)%ofs(kiv)), clinfo) + ELSE + iom_file(kiomid)%ofs(kiv) = 0. + END IF + ! return the simension size + IF( PRESENT(kdimsz) ) THEN + IF( i_nvd <= SIZE(kdimsz) ) THEN + kdimsz(1:i_nvd) = iom_file(kiomid)%dimsz(1:i_nvd,kiv) + 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(kiv) + IF( PRESENT( lduld) ) lduld = iom_file(kiomid)%luld(kiv) + ELSE + iom_nf90_varid = -1 ! variable not found, return error code: -1 + ENDIF + ! + END FUNCTION iom_nf90_varid + + !!---------------------------------------------------------------------- + !! INTERFACE iom_nf90_get + !!---------------------------------------------------------------------- + + SUBROUTINE iom_nf90_g0d_sp( kiomid, kvid, pvar, kstart ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g0d *** + !! + !! ** Purpose : read a scalar with NF90 + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kvid ! variable id + REAL(sp), INTENT( out) :: pvar ! read field + INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis + ! + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) + CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) + END SUBROUTINE iom_nf90_g0d_sp + + SUBROUTINE iom_nf90_g0d_dp( kiomid, kvid, pvar, kstart ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g0d *** + !! + !! ** Purpose : read a scalar with NF90 + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kvid ! variable id + REAL(dp), INTENT( out) :: pvar ! read field + INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis + ! + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) + CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) + END SUBROUTINE iom_nf90_g0d_dp + + SUBROUTINE iom_nf90_g123d_dp( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & + & pv_r1d, pv_r2d, pv_r3d ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g123d *** + !! + !! ** Purpose : read a 1D/2D/3D variable with NF90 + !! + !! ** Method : read ONE record at each CALL + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! iom identifier of the file + INTEGER , INTENT(in ) :: kvid ! Name of the variable + INTEGER , INTENT(in ) :: knbdim ! number of dimensions of the variable + INTEGER , DIMENSION(:) , INTENT(in ) :: kstart ! start position of the reading in each axis + INTEGER , DIMENSION(:) , INTENT(in ) :: kcount ! number of points to be read in each axis + INTEGER , INTENT(in ) :: kx1, kx2, ky1, ky2 ! subdomain indexes + 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) + ! + CHARACTER(LEN=100) :: clinfo ! info character + INTEGER :: if90id ! nf90 identifier of the opened file + INTEGER :: ivid ! nf90 variable id + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g123d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) + if90id = iom_file(kiomid)%nfid ! get back NetCDF file id + ivid = iom_file(kiomid)%nvid(kvid) ! get back NetCDF var id + ! + IF( PRESENT(pv_r1d) ) THEN + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r1d(: ), start = kstart(1:knbdim), & + & count = kcount(1:knbdim)), clinfo ) + ELSEIF( PRESENT(pv_r2d) ) THEN + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r2d(kx1:kx2,ky1:ky2 ), start = kstart(1:knbdim), & + & count = kcount(1:knbdim)), clinfo ) + ELSEIF( PRESENT(pv_r3d) ) THEN + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r3d(kx1:kx2,ky1:ky2,:), start = kstart(1:knbdim), & + & count = kcount(1:knbdim)), clinfo ) + ENDIF + ! + END SUBROUTINE iom_nf90_g123d_dp + + + + SUBROUTINE iom_nf90_chkatt( kiomid, cdatt, llok, ksize, cdvar ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_chkatt *** + !! + !! ** Purpose : check existence of attribute with NF90 + !! (either a global attribute (default) or a variable + !! attribute if optional variable name is supplied (cdvar)) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdatt ! attribute name + LOGICAL , INTENT( out) :: llok ! error code + INTEGER , INTENT( out), OPTIONAL & + & :: ksize ! attribute size + CHARACTER(len=*), INTENT(in ), OPTIONAL & + & :: cdvar ! name of the variable + ! + INTEGER :: if90id ! temporary integer + INTEGER :: isize ! temporary integer + INTEGER :: ivarid ! NetCDF variable Id + !--------------------------------------------------------------------- + ! + if90id = iom_file(kiomid)%nfid + IF( PRESENT(cdvar) ) THEN + ! check the variable exists in the file + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr + IF( llok ) & + ! check the variable has the attribute required + llok = NF90_Inquire_attribute(if90id, ivarid, cdatt, len=isize ) == nf90_noerr + ELSE + llok = NF90_Inquire_attribute(if90id, NF90_GLOBAL, cdatt, len=isize ) == nf90_noerr + ENDIF + ! + IF( PRESENT(ksize) ) ksize = isize + ! + IF( .not. llok) & + CALL ctl_warn('iom_nf90_chkatt: no attribute '//cdatt//' found') + ! + END SUBROUTINE iom_nf90_chkatt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_nf90_getatt + !!---------------------------------------------------------------------- + + SUBROUTINE iom_nf90_getatt( kiomid, cdatt, katt0d, katt1d, patt0d, patt1d, cdatt0d, cdvar) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_getatt *** + !! + !! ** Purpose : read an attribute with NF90 + !! (either a global attribute (default) or a variable + !! attribute if optional variable name is supplied (cdvar)) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! attribute name + INTEGER , INTENT( out), OPTIONAL :: katt0d ! read scalar integer + INTEGER, DIMENSION(:) , INTENT( out), OPTIONAL :: katt1d ! read 1d array integer + REAL(wp) , INTENT( out), OPTIONAL :: patt0d ! read scalar real + REAL(wp), DIMENSION(:), INTENT( out), OPTIONAL :: patt1d ! read 1d array real + CHARACTER(len=*) , INTENT( out), OPTIONAL :: cdatt0d ! read character + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! name of the variable + ! + INTEGER :: if90id ! temporary integer + INTEGER :: ivarid ! NetCDF variable Id + LOGICAL :: llok ! temporary logical + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + ! + if90id = iom_file(kiomid)%nfid + IF( PRESENT(cdvar) ) THEN + ! check the variable exists in the file + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr + IF( llok ) THEN + ! check the variable has the attribute required + llok = NF90_Inquire_attribute(if90id, ivarid, cdatt) == nf90_noerr + ELSE + CALL ctl_warn('iom_nf90_getatt: no variable '//TRIM(cdvar)//' found') + ENDIF + ELSE + llok = NF90_Inquire_attribute(if90id, NF90_GLOBAL, cdatt) == nf90_noerr + ivarid = NF90_GLOBAL + ENDIF + ! + IF( llok) THEN + clinfo = 'iom_nf90_getatt, file: '//TRIM(iom_file(kiomid)%name)//', att: '//TRIM(cdatt) + IF(PRESENT( katt0d)) CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = katt0d), clinfo) + IF(PRESENT( katt1d)) CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = katt1d), clinfo) + IF(PRESENT( patt0d)) CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = patt0d), clinfo) + IF(PRESENT( patt1d)) CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = patt1d), clinfo) + IF(PRESENT(cdatt0d)) CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = cdatt0d), clinfo) + ELSE + IF(PRESENT( katt0d)) katt0d = -999 + IF(PRESENT( katt1d)) katt1d(:) = -999 + IF(PRESENT( patt0d)) patt0d = -999._wp + IF(PRESENT( patt1d)) patt1d(:) = -999._wp + IF(PRESENT(cdatt0d)) cdatt0d = 'UNKNOWN' + ENDIF + ! + END SUBROUTINE iom_nf90_getatt + + + SUBROUTINE iom_nf90_putatt( kiomid, cdatt, katt0d, katt1d, patt0d, patt1d, cdatt0d, cdvar) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_putatt *** + !! + !! ** Purpose : write an attribute with NF90 + !! (either a global attribute (default) or a variable + !! attribute if optional variable name is supplied (cdvar)) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! attribute name + INTEGER , INTENT(in ), OPTIONAL :: katt0d ! read scalar integer + INTEGER, DIMENSION(:) , INTENT(in ), OPTIONAL :: katt1d ! read 1d array integer + REAL(wp) , INTENT(in ), OPTIONAL :: patt0d ! read scalar real + REAL(wp), DIMENSION(:), INTENT(in ), OPTIONAL :: patt1d ! read 1d array real + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdatt0d ! read character + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! name of the variable + ! + INTEGER :: if90id ! temporary integer + INTEGER :: ivarid ! NetCDF variable Id + INTEGER :: isize ! Attribute size + INTEGER :: itype ! Attribute type + LOGICAL :: llok ! temporary logical + LOGICAL :: llatt ! temporary logical + LOGICAL :: lldata ! temporary logical + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + ! + if90id = iom_file(kiomid)%nfid + IF( PRESENT(cdvar) ) THEN + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr ! is the variable in the file? + IF( .NOT. llok ) THEN + CALL ctl_warn('iom_nf90_putatt: no variable '//TRIM(cdvar)//' found' & + & , ' no attribute '//cdatt//' written' ) + RETURN + ENDIF + ELSE + ivarid = NF90_GLOBAL + ENDIF + llatt = NF90_Inquire_attribute(if90id, ivarid, cdatt, len = isize, xtype = itype ) == nf90_noerr + ! + ! trick: irec used to know if the file is in define mode or not + lldata = iom_file(kiomid)%irec /= -1 ! default: go back in define mode if in data mode + IF( lldata .AND. llatt ) THEN ! attribute already there. Do we really need to go back in define mode? + ! do we have the appropriate type? + IF(PRESENT( katt0d) .OR. PRESENT( katt1d)) llok = itype == NF90_INT + IF(PRESENT( patt0d) .OR. PRESENT( patt1d)) llok = itype == NF90_DOUBLE + IF(PRESENT(cdatt0d) ) llok = itype == NF90_CHAR + ! and do we have the appropriate size? + IF(PRESENT( katt0d)) llok = llok .AND. isize == 1 + IF(PRESENT( katt1d)) llok = llok .AND. isize == SIZE(katt1d) + IF(PRESENT( patt0d)) llok = llok .AND. isize == 1 + IF(PRESENT( patt1d)) llok = llok .AND. isize == SIZE(patt1d) + IF(PRESENT(cdatt0d)) llok = llok .AND. isize == LEN_TRIM(cdatt0d) + ! + lldata = .NOT. llok + ENDIF + ! + clinfo = 'iom_nf90_putatt, file: '//TRIM(iom_file(kiomid)%name)//', att: '//TRIM(cdatt) + IF(lldata) CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo) ! leave data mode to define mode + ! + IF(PRESENT( katt0d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = katt0d) , clinfo) + IF(PRESENT( katt1d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = katt1d) , clinfo) + IF(PRESENT( patt0d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = patt0d) , clinfo) + IF(PRESENT( patt1d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = patt1d) , clinfo) + IF(PRESENT(cdatt0d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = trim(cdatt0d)), clinfo) + ! + IF(lldata) CALL iom_nf90_check(NF90_ENDDEF( if90id ), clinfo) ! leave define mode to data mode + ! + END SUBROUTINE iom_nf90_putatt + + SUBROUTINE iom_nf90_rp0123d_dp( kt, kwrite, kiomid, cdvar , kvid , ktype, & + & pv_r0d, pv_r1d, pv_r2d, pv_r3d ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_rstput *** + !! + !! ** Purpose : read the time axis cdvar in the file + !!-------------------------------------------------------------------- + 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 ! variable name + INTEGER , INTENT(in) :: kvid ! variable id + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable type (default R8) + REAL(dp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field + REAL(dp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field + REAL(dp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field + REAL(dp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field + ! + INTEGER :: idims ! number of dimension + INTEGER :: idvar ! variable id + INTEGER :: jd ! dimension loop counter + INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes + INTEGER, DIMENSION(4) :: idimsz ! dimensions size + INTEGER, DIMENSION(4) :: idimid ! dimensions id + CHARACTER(LEN=256) :: clinfo ! info character + INTEGER :: if90id ! nf90 file identifier + INTEGER :: itype ! variable type + INTEGER, DIMENSION(4) :: ichunksz ! NetCDF4 chunk sizes. Will be computed using + ! ! nn_nchunks_[i,j,k,t] namelist parameters + INTEGER :: ichunkalg, ishuffle, ideflate, ideflate_level + ! ! NetCDF4 internally fixed parameters + LOGICAL :: lchunk ! logical switch to activate chunking and compression + ! ! when appropriate (currently chunking is applied to 4d fields only) + INTEGER :: idlv ! local variable + !--------------------------------------------------------------------- + ! + clinfo = ' iom_nf90_rp0123d, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(cdvar) + if90id = iom_file(kiomid)%nfid + ! + ! define dimension variables if it is not already done + ! ========================== + IF( iom_file(kiomid)%nvars == 0 ) THEN + ! are we in define mode? + IF( iom_file(kiomid)%irec /= -1 ) THEN ! trick: irec used to know if the file is in define mode or not + CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo) ; iom_file(kiomid)%irec = -1 + ENDIF + ! define the dimension variables if it is not already done + DO jd = 1, 2 + CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(jd,jd)),clinfo) + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ 1, 2 /), & + & iom_file(kiomid)%nvid(jd) ), clinfo) + END DO + iom_file(kiomid)%dimsz(2,1) = iom_file(kiomid)%dimsz(2,2) ! second dim of first variable + iom_file(kiomid)%dimsz(1,2) = iom_file(kiomid)%dimsz(1,1) ! first dim of second variable + DO jd = 3, 4 + CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(1,jd)), clinfo) + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ jd /), & + & iom_file(kiomid)%nvid(jd) ), clinfo) + END DO + ! update informations structure related the dimension variable we just added... + iom_file(kiomid)%nvars = 4 + iom_file(kiomid)%luld(1:4) = (/ .FALSE., .FALSE., .FALSE., .TRUE. /) + iom_file(kiomid)%ndims(1:4) = (/ 2, 2, 1, 1 /) + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' define dimension variables done' + ENDIF + ! define the data if it is not already done + ! =============== + IF( kvid <= 0 ) THEN + ! + ! NetCDF4 chunking and compression fixed settings + ichunkalg = 0 + ishuffle = 1 + ideflate = 1 + ideflate_level = 1 + ! + idvar = iom_file(kiomid)%nvars + 1 + ! are we in define mode? + IF( iom_file(kiomid)%irec /= -1 ) THEN ! trick: irec used to know if the file is in define mode or not + CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo) ; iom_file(kiomid)%irec = -1 + ENDIF + ! variable definition + IF( PRESENT(pv_r0d) ) THEN ; idims = 0 + ELSEIF( PRESENT(pv_r1d) ) THEN + idims = 2 ; idimid(1:idims) = (/3,4/) + ELSEIF( PRESENT(pv_r2d) ) THEN ; idims = 3 ; idimid(1:idims) = (/1,2,4/) + ELSEIF( PRESENT(pv_r3d) ) THEN + idims = 4 ; idimid(1:idims) = (/1,2,3,4/) + ENDIF + IF( PRESENT(ktype) ) THEN ! variable external type + SELECT CASE (ktype) + CASE (jp_r8) ; itype = NF90_DOUBLE + CASE (jp_r4) ; itype = NF90_FLOAT + CASE (jp_i4) ; itype = NF90_INT + CASE (jp_i2) ; itype = NF90_SHORT + CASE (jp_i1) ; itype = NF90_BYTE + CASE DEFAULT ; CALL ctl_stop( TRIM(clinfo)//' unknown variable type' ) + END SELECT + ELSE + itype = NF90_DOUBLE + ENDIF + IF( PRESENT(pv_r0d) ) THEN + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, & + & iom_file(kiomid)%nvid(idvar) ), clinfo ) + ELSE + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, idimid(1:idims), & + & iom_file(kiomid)%nvid(idvar) ), clinfo ) + ENDIF + lchunk = .false. + IF( snc4set%luse .AND. idims == 4 ) lchunk = .true. + ! update informations structure related the new variable we want to add... + iom_file(kiomid)%nvars = idvar + iom_file(kiomid)%cn_var(idvar) = TRIM(cdvar) + iom_file(kiomid)%scf(idvar) = 1. + iom_file(kiomid)%ofs(idvar) = 0. + iom_file(kiomid)%ndims(idvar) = idims + IF( .NOT. PRESENT(pv_r0d) ) THEN ; iom_file(kiomid)%luld(idvar) = .TRUE. + ELSE ; iom_file(kiomid)%luld(idvar) = .FALSE. + ENDIF + DO jd = 1, idims + CALL iom_nf90_check(NF90_INQUIRE_DIMENSION( if90id, idimid(jd), len = iom_file(kiomid)%dimsz(jd,idvar) ), clinfo) + IF ( lchunk ) ichunksz(jd) = iom_file(kiomid)%dimsz(jd,idvar) + END DO + IF ( lchunk ) THEN + ! Calculate chunk sizes by partitioning each dimension as requested in namnc4 namelist + ! Disallow very small chunk sizes and prevent chunk sizes larger than each individual dimension + ichunksz(1) = MIN( ichunksz(1),MAX( (ichunksz(1)-1)/snc4set%ni + 1 ,16 ) ) ! Suggested default nc4set%ni=4 + ichunksz(2) = MIN( ichunksz(2),MAX( (ichunksz(2)-1)/snc4set%nj + 1 ,16 ) ) ! Suggested default nc4set%nj=2 + ichunksz(3) = MIN( ichunksz(3),MAX( (ichunksz(3)-1)/snc4set%nk + 1 , 1 ) ) ! Suggested default nc4set%nk=6 + ichunksz(4) = 1 ! Do not allow chunks to span the + ! ! unlimited dimension + CALL iom_nf90_check(SET_NF90_DEF_VAR_CHUNKING(if90id, idvar, ichunkalg, ichunksz), clinfo) + CALL iom_nf90_check(SET_NF90_DEF_VAR_DEFLATE(if90id, idvar, ishuffle, ideflate, ideflate_level), clinfo) + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' chunked ok. Chunks sizes: ', ichunksz + ENDIF + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' defined ok' + ELSE + idvar = kvid + ENDIF + ! + ! time step kwrite : write the variable + IF( kt == kwrite ) THEN + ! are we in write mode? + IF( iom_file(kiomid)%irec == -1 ) THEN ! trick: irec used to know if the file is in define mode or not + CALL iom_nf90_check(NF90_ENDDEF( if90id ), clinfo) ; iom_file(kiomid)%irec = 0 + ENDIF + ! on what kind of domain must the data be written? + IF( PRESENT(pv_r2d) .OR. PRESENT(pv_r3d) ) THEN + idimsz(1:2) = iom_file(kiomid)%dimsz(1:2,idvar) + IF( idimsz(1) == Ni_0 .AND. idimsz(2) == Nj_0 ) THEN + ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0 + ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN + ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj + ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN + ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj + ELSE + CALL ctl_stop( 'iom_nf90_rp0123d: should have been an impossible case...' ) + ENDIF + + ! write dimension variables if it is not already done + ! ============= + ! trick: is defined to 0 => dimension variable are defined but not yet written + IF( iom_file(kiomid)%dimsz(1, 4) == 0 ) THEN ! time_counter = 0 + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 1, glamt(ix1:ix2, iy1:iy2) ), clinfo ) + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 2, gphit(ix1:ix2, iy1:iy2) ), clinfo ) + SELECT CASE (iom_file(kiomid)%comp) + CASE ('OCE') + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, gdept_1d ), clinfo ) + CASE ('ABL') + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, ght_abl ), clinfo ) + CASE DEFAULT + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, (/ (idlv, idlv = 1,iom_file(kiomid)%dimsz(1,3)) /) ), clinfo ) + END SELECT + ! "wrong" value: to be improved but not really useful... + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 4, kt ), clinfo ) + ! update the size of the variable corresponding to the unlimited dimension + iom_file(kiomid)%dimsz(1, 4) = 1 ! so we don't enter this IF case any more... + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' write dimension variables done' + ENDIF + ENDIF + + ! write the data + ! ============= + IF( PRESENT(pv_r0d) ) THEN + CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r0d ), clinfo ) + ELSEIF( PRESENT(pv_r1d) ) THEN + CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r1d(:) ), clinfo ) + ELSEIF( PRESENT(pv_r2d) ) THEN + CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r2d(ix1:ix2,iy1:iy2) ), clinfo ) + ELSEIF( PRESENT(pv_r3d) ) THEN + CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r3d(ix1:ix2,iy1:iy2,:) ), clinfo ) + ENDIF + ! add 1 to the size of the temporal dimension (not really useful...) + IF( iom_file(kiomid)%luld(idvar) ) iom_file(kiomid)%dimsz(iom_file(kiomid)%ndims(idvar), idvar) & + & = iom_file(kiomid)%dimsz(iom_file(kiomid)%ndims(idvar), idvar) + 1 + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' written ok' + ENDIF + ! + END SUBROUTINE iom_nf90_rp0123d_dp + + + SUBROUTINE iom_nf90_check( kstatus, cdinfo ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_check *** + !! + !! ** Purpose : check nf90 errors + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: kstatus + CHARACTER(LEN=*), INTENT(in) :: cdinfo + !--------------------------------------------------------------------- + IF(kstatus /= nf90_noerr) CALL ctl_stop( 'iom_nf90_check : '//TRIM(nf90_strerror(kstatus)), TRIM(cdinfo) ) + END SUBROUTINE iom_nf90_check + + !!====================================================================== +END MODULE iom_nf90 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isf_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isf_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..47d103c8186fc03bb3925977541280c30f231453 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isf_oce.f90 @@ -0,0 +1,284 @@ + + + + + + + + + + + + + +MODULE isf_oce + !!====================================================================== + !! *** MODULE isf_oce *** + !! Ice shelves : ice shelves variables defined in memory + !!====================================================================== + !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav + !! X.X ! 2006-02 (C. Wang ) Original code bg03 + !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization + !! 4.1 ! 2019-09 (P. Mathiot) Split param/explicit ice shelf and re-organisation + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isf : define and allocate ice shelf variables + !!---------------------------------------------------------------------- + USE par_kind + USE par_oce , ONLY: jpi, jpj, jpk + USE in_out_manager, ONLY: wp, jpts ! I/O manager + USE lib_mpp , ONLY: ctl_stop, mpp_sum ! MPP library + USE fldread ! read input fields + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_alloc, isf_alloc_par, isf_alloc_cav, isf_alloc_cpl, isf_dealloc_cpl + ! + !------------------------------------------------------- + ! 0 : namelist parameter + !------------------------------------------------------- + ! + ! 0.1 -------- ice shelf cavity parameter -------------- + CHARACTER(LEN=256), PUBLIC :: cn_isfdir + LOGICAL , PUBLIC :: ln_isf + LOGICAL , PUBLIC :: ln_isfdebug + ! + ! 0.2 -------- ice shelf cavity opened namelist parameter ------------- + LOGICAL , PUBLIC :: ln_isfcav_mlt !: logical for the use of ice shelf parametrisation + REAL(wp) , PUBLIC :: rn_gammat0 !: temperature exchange coeficient [] + REAL(wp) , PUBLIC :: rn_gammas0 !: salinity exchange coeficient [] + REAL(wp) , PUBLIC :: rn_htbl !: Losch top boundary layer thickness [m] + REAL(wp) , PUBLIC :: rn_isfload_T !: + REAL(wp) , PUBLIC :: rn_isfload_S !: + CHARACTER(LEN=256), PUBLIC :: cn_gammablk !: gamma formulation + CHARACTER(LEN=256), PUBLIC :: cn_isfcav_mlt !: melt formulation (cavity/param) + CHARACTER(LEN=256), PUBLIC :: cn_isfload !: ice shelf load computation method + TYPE(FLD_N) , PUBLIC :: sn_isfcav_fwf !: information about the isf melting file to be read + ! + ! 0.3 -------- ice shelf cavity parametrised namelist parameter ------------- + LOGICAL , PUBLIC :: ln_isfpar_mlt !: logical for the computation of melt inside the cavity + REAL(wp) , PUBLIC :: rn_isfpar_bg03_gt0 !: temperature exchange coeficient [m/s] + CHARACTER(LEN=256), PUBLIC :: cn_isfpar_mlt !: melt formulation (cavity/param) + TYPE(FLD_N) , PUBLIC :: sn_isfpar_fwf !: information about the isf melting file to be read + TYPE(FLD_N) , PUBLIC :: sn_isfpar_zmax !: information about the grounding line depth file to be read + TYPE(FLD_N) , PUBLIC :: sn_isfpar_zmin !: information about the calving line depth file to be read + TYPE(FLD_N) , PUBLIC :: sn_isfpar_Leff !: information about the effective length file to be read + ! + ! 0.4 -------- coupling namelist parameter ------------- + LOGICAL, PUBLIC :: ln_isfcpl !: + LOGICAL, PUBLIC :: ln_isfcpl_cons !: + INTEGER, PUBLIC :: nn_drown !: + ! + !------------------------------------------------------- + ! 1 : ice shelf parameter + !------------------------------------------------------- + ! + REAL(wp), PARAMETER, PUBLIC :: rLfusisf = 0.334e6_wp !: latent heat of fusion of ice shelf [J/kg] + REAL(wp), PARAMETER, PUBLIC :: rcpisf = 2000.0_wp !: specific heat of ice shelf [J/kg/K] + REAL(wp), PARAMETER, PUBLIC :: rkappa = 1.54e-6_wp !: heat diffusivity through the ice-shelf [m2/s] + REAL(wp), PARAMETER, PUBLIC :: rhoisf = 920.0_wp !: volumic mass of ice shelf [kg/m3] + REAL(wp), PARAMETER, PUBLIC :: rtsurf = -20.0 !: surface temperature [C] + ! + !------------------------------------------------------- + ! 2 : ice shelf global variables + !------------------------------------------------------- + ! + ! 2.1 -------- ice shelf cavity parameter -------------- + LOGICAL , PUBLIC :: l_isfoasis = .FALSE. + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfload !: ice shelf load + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_oasis + ! + ! 2.2 -------- ice shelf cavity melt namelist parameter ------------- + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_cav !: + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_cav , misfkb_cav !: + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_cav, rfrac_tbl_cav !: + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_cav , fwfisf_cav_b !: before and now net fwf from the ice shelf [kg/m2/s] + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_cav_tsc , risf_cav_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s] + TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfcav_fwf !: + ! + REAL(wp) , PUBLIC :: risf_lamb1, risf_lamb2, risf_lamb3 ! freezing point linearization coeficient + ! + ! 2.3 -------- ice shelf param. melt namelist parameter ------------- + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_par !: + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_par , misfkb_par !: + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_par, rfrac_tbl_par !: + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_par , fwfisf_par_b !: before and now net fwf from the ice shelf [kg/m2/s] + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_par_tsc , risf_par_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s] + TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfpar_fwf !: + ! + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf0_tbl_par !: thickness of tbl (initial value) [m] + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfLeff !: + ! + ! 2.4 -------- coupling namelist parameter ------------- + INTEGER , PUBLIC :: nstp_iscpl !: + REAL(wp), PUBLIC :: rdt_iscpl !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfcpl_ssh, risfcpl_cons_ssh, risfcpl_cons_ssh_b !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risfcpl_vol, risfcpl_cons_vol, risfcpl_cons_vol_b !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: risfcpl_tsc, risfcpl_cons_tsc, risfcpl_cons_tsc_b !: + ! + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isf_alloc_par() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_alloc_par *** + !! + !! ** Purpose : + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr, ialloc + !!---------------------------------------------------------------------- + ierr = 0 ! set to zero if no array to be allocated + ! + ALLOCATE(risfLeff(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + ALLOCATE(misfkt_par(jpi,jpj), misfkb_par(jpi,jpj), STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( rfrac_tbl_par(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + ALLOCATE( rhisf_tbl_par(jpi,jpj), rhisf0_tbl_par(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + ALLOCATE( mskisf_par(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + CALL mpp_sum ( 'isf', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'isf: failed to allocate arrays.' ) + ! + END SUBROUTINE isf_alloc_par + + + SUBROUTINE isf_alloc_cav() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_alloc_cav *** + !! + !! ** Purpose : + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr, ialloc + !!---------------------------------------------------------------------- + ierr = 0 ! set to zero if no array to be allocated + ! + ALLOCATE(misfkt_cav(jpi,jpj), misfkb_cav(jpi,jpj), STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( rfrac_tbl_cav(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + ALLOCATE( rhisf_tbl_cav(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + CALL mpp_sum ( 'isf', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'isf: failed to allocate arrays.' ) + ! + END SUBROUTINE isf_alloc_cav + + + SUBROUTINE isf_alloc_cpl() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_alloc_cpl *** + !! + !! ** Purpose : allocate array use for the ice sheet coupling + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr, ialloc + !!---------------------------------------------------------------------- + ierr = 0 + ! + ALLOCATE( risfcpl_ssh(jpi,jpj) , risfcpl_tsc(jpi,jpj,jpk,jpts) , risfcpl_vol(jpi,jpj,jpk) , STAT=ialloc ) + ierr = ierr + ialloc + ! + risfcpl_tsc(:,:,:,:) = 0._wp ; risfcpl_vol(:,:,:) = 0._wp ; risfcpl_ssh(:,:) = 0._wp + + IF ( ln_isfcpl_cons ) THEN + ALLOCATE( risfcpl_cons_tsc(jpi,jpj,jpk,jpts) , risfcpl_cons_vol(jpi,jpj,jpk) , risfcpl_cons_ssh(jpi,jpj) , STAT=ialloc ) + ierr = ierr + ialloc + ! + risfcpl_cons_tsc(:,:,:,:) = 0._wp ; risfcpl_cons_vol(:,:,:) = 0._wp ; risfcpl_cons_ssh(:,:) = 0._wp + ! + END IF + ! + CALL mpp_sum ( 'isf', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('STOP','isfcpl: failed to allocate arrays.') + ! + END SUBROUTINE isf_alloc_cpl + + + SUBROUTINE isf_dealloc_cpl() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_dealloc_cpl *** + !! + !! ** Purpose : de-allocate useless public 3d array used for ice sheet coupling + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr, ialloc + !!---------------------------------------------------------------------- + ierr = 0 + ! + DEALLOCATE( risfcpl_ssh , risfcpl_tsc , risfcpl_vol , STAT=ialloc ) + ierr = ierr + ialloc + ! + CALL mpp_sum ( 'isf', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('STOP','isfcpl: failed to deallocate arrays.') + ! + END SUBROUTINE isf_dealloc_cpl + + + SUBROUTINE isf_alloc() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_alloc *** + !! + !! ** Purpose : allocate array used for the ice shelf cavity (cav and par) + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr, ialloc + !!---------------------------------------------------------------------- + ! + ierr = 0 ! set to zero if no array to be allocated + ! + ALLOCATE( fwfisf_par (jpi,jpj) , fwfisf_par_b(jpi,jpj) , & + & fwfisf_cav (jpi,jpj) , fwfisf_cav_b(jpi,jpj) , & + & fwfisf_oasis(jpi,jpj) , STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( risf_par_tsc(jpi,jpj,jpts) , risf_par_tsc_b(jpi,jpj,jpts) , STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( risf_cav_tsc(jpi,jpj,jpts) , risf_cav_tsc_b(jpi,jpj,jpts) , STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( risfload(jpi,jpj) , STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( mskisf_cav(jpi,jpj) , STAT=ialloc ) + ierr = ierr + ialloc + ! + CALL mpp_sum ( 'isf', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'isf: failed to allocate arrays.' ) + ! + ! initalisation of fwf and tsc array to 0 + risfload (:,:) = 0._wp + fwfisf_oasis(:,:) = 0._wp + fwfisf_par (:,:) = 0._wp ; fwfisf_par_b (:,:) = 0._wp + fwfisf_cav (:,:) = 0._wp ; fwfisf_cav_b (:,:) = 0._wp + risf_cav_tsc(:,:,:) = 0._wp ; risf_cav_tsc_b(:,:,:) = 0._wp + risf_par_tsc(:,:,:) = 0._wp ; risf_par_tsc_b(:,:,:) = 0._wp + ! + END SUBROUTINE isf_alloc + + !!====================================================================== +END MODULE isf_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcav.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcav.f90 new file mode 100644 index 0000000000000000000000000000000000000000..13b9f847fa1f57a1eb389e1d3cb9af1645e369bd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcav.f90 @@ -0,0 +1,297 @@ + + + + + + + + + + + + + +MODULE isfcav + !!====================================================================== + !! *** MODULE isfcav *** + !! Ice shelf cavity module : update ice shelf melting under ice + !! shelf + !!====================================================================== + !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav + !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization + !! 4.1 ! 2019-09 (P. Mathiot) Split ice shelf cavity and ice shelf parametrisation + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isf_cav : update ice shelf melting under ice shelf + !!---------------------------------------------------------------------- + USE isf_oce ! ice shelf public variables + ! + USE isfrst , ONLY: isfrst_write, isfrst_read ! ice shelf restart read/write subroutine + USE isfutils , ONLY: debug ! ice shelf debug subroutine + USE isftbl , ONLY: isf_tbl ! ice shelf top boundary layer properties subroutine + USE isfcavmlt, ONLY: isfcav_mlt ! ice shelf melt formulation subroutine + USE isfcavgam, ONLY: isfcav_gammats ! ice shelf melt exchange coeficient subroutine + USE isfdiags , ONLY: isf_diags_flx ! ice shelf diags subroutine + ! + USE oce , ONLY: ts, uu, vv, rn2 ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE par_oce , ONLY: jpi,jpj ! ocean space and time domain + USE phycst , ONLY: grav,rho0,rho0_rcp,r1_rho0_rcp ! physical constants + USE eosbn2 , ONLY: ln_teos10 ! use ln_teos10 or not + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE fldread ! read input field at current time step + USE lbclnk ! lbclnk + USE lib_mpp ! MPP library + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_cav, isf_cav_init ! routine called in isfmlt + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isf_cav( kt, Kmm, ptsc, pqfwf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_cav *** + !! + !! ** Purpose : handle surface boundary condition under ice shelf + !! + !! ** Method : based on Mathiot et al. (2017) + !! + !! ** Action : - compute geometry of the Losch top bournary layer (see Losch et al. 2008) + !! - depending on the chooses option + !! - compute temperature/salt in the tbl + !! - compute exchange coeficient + !! - compute heat and fwf fluxes + !! - output + !! + !! ** Convention : all fluxes are from isf to oce + !! + !!--------------------------------------------------------------------- + !!-------------------------- OUT -------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: pqfwf ! ice shelf fwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(inout) :: ptsc ! T & S ice shelf cavity contents + !!-------------------------- IN -------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + LOGICAL :: lit + INTEGER :: nit, ji, jj, ikt + REAL(wp) :: zerr + REAL(wp) :: zcoef, zdku, zdkv + REAL(wp), DIMENSION(jpi,jpj) :: zqlat, zqoce, zqhc, zqh ! heat fluxes + REAL(wp), DIMENSION(jpi,jpj) :: zqh_b, zRc ! + REAL(wp), DIMENSION(jpi,jpj) :: zgammat, zgammas ! exchange coeficient + REAL(wp), DIMENSION(jpi,jpj) :: zttbl, zstbl ! temp. and sal. in top boundary layer + !!--------------------------------------------------------------------- + ! + ! compute T/S/U/V for the top boundary layer + CALL isf_tbl(Kmm, ts(:,:,:,jp_tem,Kmm), zttbl(:,:),'T', misfkt_cav, rhisf_tbl_cav, misfkb_cav, rfrac_tbl_cav ) + CALL isf_tbl(Kmm, ts(:,:,:,jp_sal,Kmm), zstbl(:,:),'T', misfkt_cav, rhisf_tbl_cav, misfkb_cav, rfrac_tbl_cav ) + ! + ! output T/S/U/V for the top boundary layer + CALL iom_put('ttbl_cav',zttbl(:,:) * mskisf_cav(:,:)) + CALL iom_put('stbl' ,zstbl(:,:) * mskisf_cav(:,:)) + ! + ! initialisation + IF ( TRIM(cn_gammablk) == 'vel_stab' ) THEN + zqoce(:,:) = -pqfwf(:,:) * rLfusisf ! + zqh_b(:,:) = ptsc(:,:,jp_tem) * rho0_rcp ! last time step total heat fluxes (to speed up convergence) + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ikt = mikt(ji,jj) + ! compute Rc number (as done in zdfric.F90) +!!gm better to do it like in the new zdfric.F90 i.e. avm weighted Ri computation + zcoef = 0.5_wp / (e3w_0(ji,jj,ikt+1)*(1._wp+r3t(ji,jj,Kmm))) + ! ! shear of horizontal velocity + zdku = zcoef * ( uu(ji-1,jj ,ikt ,Kmm) + uu(ji,jj,ikt ,Kmm) & + & -uu(ji-1,jj ,ikt+1,Kmm) - uu(ji,jj,ikt+1,Kmm) ) + zdkv = zcoef * ( vv(ji ,jj-1,ikt ,Kmm) + vv(ji,jj,ikt ,Kmm) & + & -vv(ji ,jj-1,ikt+1,Kmm) - vv(ji,jj,ikt+1,Kmm) ) + ! ! richardson number (minimum value set to zero) + zRc(ji,jj) = MAX(rn2(ji,jj,ikt+1), 1.e-20_wp) / MAX( zdku*zdku + zdkv*zdkv, 1.e-20_wp ) + END DO ; END DO + CALL lbc_lnk( 'isfmlt', zRc, 'T', 1._wp ) + ENDIF + ! + ! compute ice shelf melting + nit = 1 ; lit = .TRUE. + DO WHILE ( lit ) ! maybe just a constant number of iteration as in blk_core is fine + ! + ! compute gammat everywhere (2d) + ! useless if melt specified + IF ( TRIM(cn_isfcav_mlt) .NE. 'spe' ) THEN + CALL isfcav_gammats( Kmm, zttbl, zstbl, zqoce , pqfwf, zRc, & + & zgammat, zgammas ) + END IF + ! + ! compute tfrz, latent heat and melt (2d) + CALL isfcav_mlt(kt, zgammat, zgammas, zttbl, zstbl, & + & zqhc , zqoce, pqfwf ) + ! + ! define if we need to iterate + SELECT CASE ( cn_gammablk ) + CASE ( 'spe','vel' ) + ! no convergence needed + lit = .FALSE. + CASE ( 'vel_stab' ) + ! compute error between 2 iterations + zerr = 0._wp + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zerr = MAX( zerr, ABS(zqhc(ji,jj)+zqoce(ji,jj) - zqh_b(ji,jj)) ) + END DO ; END DO + CALL mpp_max( 'isfcav', zerr ) ! max over the global domain + ! + ! define if iteration needed + IF (nit >= 100) THEN ! too much iteration + CALL ctl_stop( 'STOP', 'isf_cav: vel_stab gamma formulation had too many iterations ...' ) + ELSE IF ( zerr <= 0.01_wp ) THEN ! convergence is achieve + lit = .FALSE. + ELSE ! converge is not yet achieve + nit = nit + 1 + zqh_b(:,:) = zqhc(:,:)+zqoce(:,:) + END IF + END SELECT + ! + END DO + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! compute heat and water flux ( > 0 from isf to oce) + pqfwf(ji,jj) = pqfwf(ji,jj) * mskisf_cav(ji,jj) + zqoce(ji,jj) = zqoce(ji,jj) * mskisf_cav(ji,jj) + zqhc (ji,jj) = zqhc(ji,jj) * mskisf_cav(ji,jj) + ! + ! compute heat content flux ( > 0 from isf to oce) + zqlat(ji,jj) = - pqfwf(ji,jj) * rLfusisf ! 2d latent heat flux (W/m2) + ! + ! total heat flux ( > 0 from isf to oce) + zqh(ji,jj) = ( zqhc (ji,jj) + zqoce(ji,jj) ) + ! + ! set temperature content + ptsc(ji,jj,jp_tem) = zqh(ji,jj) * r1_rho0_rcp + END DO ; END DO + CALL lbc_lnk( 'isfmlt', pqfwf, 'T', 1.0_wp) + ! + ! output fluxes + CALL isf_diags_flx( Kmm, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, 'cav', pqfwf, zqoce, zqlat, zqhc) + ! + ! write restart variables (qoceisf, qhcisf, fwfisf for now and before) + IF (lrst_oce) CALL isfrst_write(kt, 'cav', ptsc, pqfwf) + ! + IF ( ln_isfdebug ) THEN + IF(lwp) WRITE(numout,*) '' + CALL debug('isf_cav: ptsc T',ptsc(:,:,1)) + CALL debug('isf_cav: ptsc S',ptsc(:,:,2)) + CALL debug('isf_cav: pqfwf fwf',pqfwf(:,:)) + IF(lwp) WRITE(numout,*) '' + END IF + ! + END SUBROUTINE isf_cav + + SUBROUTINE isf_cav_init + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_cav_init *** + !! + !! ** Purpose : initialisation of variable needed to compute melt under an ice shelf + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr + !!--------------------------------------------------------------------- + ! + !============== + ! 0: allocation + !============== + ! + CALL isf_alloc_cav() + ! + !================== + ! 1: initialisation + !================== + ! + ! top and bottom level of the 'top boundary layer' + misfkt_cav(:,:) = mikt(:,:) ; misfkb_cav(:,:) = 1 + ! + ! thickness of 'tbl' and fraction of bottom cell affected by 'tbl' + rhisf_tbl_cav(:,:) = 0.0_wp ; rfrac_tbl_cav(:,:) = 0.0_wp + ! + ! cavity mask + mskisf_cav(:,:) = (1._wp - tmask(:,:,1)) * ssmask(:,:) + !================ + ! 2: activate restart + !================ + ! + !================ + ! 3: read restart + !================ + ! + ! read cav variable from restart + IF ( ln_rstart ) CALL isfrst_read('cav', risf_cav_tsc, fwfisf_cav, risf_cav_tsc_b, fwfisf_cav_b) + ! + !========================================== + ! 3: specific allocation and initialisation (depending of scheme choice) + !========================================== + ! + SELECT CASE ( TRIM(cn_isfcav_mlt) ) + CASE( 'spe' ) + + ALLOCATE( sf_isfcav_fwf(1), STAT=ierr ) + ALLOCATE( sf_isfcav_fwf(1)%fnow(jpi,jpj,1), sf_isfcav_fwf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_isfcav_fwf, (/ sn_isfcav_fwf /), cn_isfdir, 'isf_cav_init', 'read fresh water flux isf data', 'namisf' ) + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>> The ice shelf melt inside the cavity is read from forcing files' + + CASE( '2eq' ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>> The original ISOMIP melt formulation is used to compute melt under the ice shelves' + + CASE( '3eq' ) + ! coeficient for linearisation of potential tfreez + ! Crude approximation for pressure (but commonly used) + IF ( ln_teos10 ) THEN ! linearisation from Jourdain et al. (2017) + risf_lamb1 =-0.0564_wp + risf_lamb2 = 0.0773_wp + risf_lamb3 =-7.8633e-8 * grav * rho0 + ELSE ! linearisation from table 4 (Asay-Davis et al., 2015) + risf_lamb1 =-0.0573_wp + risf_lamb2 = 0.0832_wp + risf_lamb3 =-7.5300e-8 * grav * rho0 + ENDIF + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>> The 3 equations melt formulation is used to compute melt under the ice shelves' + + CASE DEFAULT + CALL ctl_stop(' cn_isfcav_mlt method unknown (spe, 2eq, 3eq), check namelist') + END SELECT + ! + END SUBROUTINE isf_cav_init + +END MODULE isfcav diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcavgam.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcavgam.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3ad11b412e6f44a0e4cb945932ca4f0b952dd921 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcavgam.f90 @@ -0,0 +1,281 @@ + + + + + + + + + + + + + +MODULE isfcavgam + !!====================================================================== + !! *** MODULE isfgammats *** + !! Ice shelf gamma module : compute exchange coeficient at the ice/ocean interface + !!====================================================================== + !! History : 4.1 ! (P. Mathiot) original + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfcav_gammats : compute exchange coeficient gamma + !!---------------------------------------------------------------------- + USE isf_oce + USE isfutils, ONLY: debug + USE isftbl , ONLY: isf_tbl + + USE oce , ONLY: uu, vv ! ocean dynamics + USE phycst , ONLY: grav, vkarmn ! physical constant + USE eosbn2 , ONLY: eos_rab ! equation of state + USE zdfdrg , ONLY: rCd0_top, r_ke0_top ! vertical physics: top/bottom drag coef. + USE iom , ONLY: iom_put ! + USE lib_mpp , ONLY: ctl_stop + + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + ! + IMPLICIT NONE + ! + PRIVATE + ! + PUBLIC isfcav_gammats + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + ! + !!----------------------------------------------------------------------------------------------------- + !! PUBLIC SUBROUTINES + !!----------------------------------------------------------------------------------------------------- + ! + SUBROUTINE isfcav_gammats( Kmm, pttbl, pstbl, pqoce, pqfwf, pRc, pgt, pgs ) + !!---------------------------------------------------------------------- + !! ** Purpose : compute the coefficient echange for heat and fwf flux + !! + !! ** Method : select the gamma formulation + !! 3 method available (cst, vel and vel_stab) + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt , pgs ! gamma t and gamma s + !!-------------------------- IN ------------------------------------- + INTEGER :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! isf heat and fwf + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number + !!--------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: zutbl, zvtbl ! top boundary layer velocity + !!--------------------------------------------------------------------- + ! + !========================================== + ! 1.: compute velocity in the tbl if needed + !========================================== + ! + SELECT CASE ( cn_gammablk ) + CASE ( 'spe' ) + ! gamma is constant (specified in namelist) + ! nothing to do + CASE ('vel', 'vel_stab') + ! compute velocity in tbl + CALL isf_tbl(Kmm, uu(:,:,:,Kmm) ,zutbl(:,:),'U', miku, rhisf_tbl_cav) + CALL isf_tbl(Kmm, vv(:,:,:,Kmm) ,zvtbl(:,:),'V', mikv, rhisf_tbl_cav) + ! + ! mask velocity in tbl with ice shelf mask + zutbl(:,:) = zutbl(:,:) * mskisf_cav(:,:) + zvtbl(:,:) = zvtbl(:,:) * mskisf_cav(:,:) + ! + ! output + CALL iom_put('utbl',zutbl(:,:)) + CALL iom_put('vtbl',zvtbl(:,:)) + CASE DEFAULT + CALL ctl_stop('STOP','method to compute gamma (cn_gammablk) is unknown (should not see this)') + END SELECT + ! + !========================================== + ! 2.: compute gamma + !========================================== + ! + SELECT CASE ( cn_gammablk ) + CASE ( 'spe' ) ! gamma is constant (specified in namelist) + pgt(:,:) = rn_gammat0 + pgs(:,:) = rn_gammas0 + CASE ( 'vel' ) ! gamma is proportional to u* + CALL gammats_vel ( zutbl, zvtbl, rCd0_top, r_ke0_top, pgt, pgs ) + CASE ( 'vel_stab' ) ! gamma depends of stability of boundary layer and u* + CALL gammats_vel_stab (Kmm, pttbl, pstbl, zutbl, zvtbl, rCd0_top, r_ke0_top, pqoce, pqfwf, pRc, pgt, pgs ) + CASE DEFAULT + CALL ctl_stop('STOP','method to compute gamma (cn_gammablk) is unknown (should not see this)') + END SELECT + ! + !========================================== + ! 3.: output and debug + !========================================== + ! + CALL iom_put('isfgammat', pgt(:,:)) + CALL iom_put('isfgammas', pgs(:,:)) + ! + IF (ln_isfdebug) THEN + CALL debug( 'isfcav_gam pgt:', pgt(:,:) ) + CALL debug( 'isfcav_gam pgs:', pgs(:,:) ) + END IF + ! + END SUBROUTINE isfcav_gammats + ! + !!----------------------------------------------------------------------------------------------------- + !! PRIVATE SUBROUTINES + !!----------------------------------------------------------------------------------------------------- + ! + SUBROUTINE gammats_vel( putbl, pvtbl, pCd, pke2, & ! <<== in + & pgt, pgs ) ! ==>> out gammats [m/s] + !!---------------------------------------------------------------------- + !! ** Purpose : compute the coefficient echange coefficient + !! + !! ** Method : gamma is velocity dependent ( gt= gt0 * Ustar ) + !! + !! ** Reference : Asay-Davis et al., Geosci. Model Dev., 9, 2471-2497, 2016 + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas [m/s] + !!-------------------------- IN ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coefficient + REAL(wp), INTENT(in ) :: pke2 ! background velocity + !!--------------------------------------------------------------------- + INTEGER :: ji, jj ! loop index + REAL(wp), DIMENSION(jpi,jpj) :: zustar + !!--------------------------------------------------------------------- + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! compute ustar (AD15 eq. 27) + zustar(ji,jj) = SQRT( pCd(ji,jj) * ( putbl(ji,jj) * putbl(ji,jj) + pvtbl(ji,jj) * pvtbl(ji,jj) + pke2 ) ) * mskisf_cav(ji,jj) + ! + ! Compute gammats + pgt(ji,jj) = zustar(ji,jj) * rn_gammat0 + pgs(ji,jj) = zustar(ji,jj) * rn_gammas0 + END DO ; END DO + ! + ! output ustar + CALL iom_put('isfustar',zustar(:,:)) + ! + END SUBROUTINE gammats_vel + + SUBROUTINE gammats_vel_stab( Kmm, pttbl, pstbl, putbl, pvtbl, pCd, pke2, pqoce, pqfwf, pRc, & ! <<== in + & pgt , pgs ) ! ==>> out gammats [m/s] + !!---------------------------------------------------------------------- + !! ** Purpose : compute the coefficient echange coefficient + !! + !! ** Method : gamma is velocity dependent and stability dependent + !! + !! ** Reference : Holland and Jenkins, 1999, JPO, p1787-1800 + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas + !!-------------------------- IN ------------------------------------- + INTEGER :: Kmm ! ocean time level index + REAL(wp), INTENT(in ) :: pke2 ! background velocity squared + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! surface heat flux and fwf flux + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coeficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! tracer in the losch top boundary layer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number + !!--------------------------------------------------------------------- + INTEGER :: ji, jj ! loop index + INTEGER :: ikt ! local integer + REAL(wp) :: zdku, zdkv ! U, V shear + REAL(wp) :: zPr, zSc ! Prandtl and Scmidth number + REAL(wp) :: zmob, zmols ! Monin Obukov length, coriolis factor at T point + REAL(wp) :: zbuofdep, zhnu ! Bouyancy length scale, sublayer tickness + REAL(wp) :: zhmax ! limitation of mol + REAL(wp) :: zetastar ! stability parameter + REAL(wp) :: zgmolet, zgmoles, zgturb ! contribution of modelecular sublayer and turbulence + REAL(wp) :: zcoef ! temporary coef + REAL(wp) :: zdep + REAL(wp) :: zeps = 1.0e-20_wp + REAL(wp), PARAMETER :: zxsiN = 0.052_wp ! dimensionless constant + REAL(wp), PARAMETER :: znu = 1.95e-6_wp ! kinamatic viscosity of sea water (m2.s-1) + REAL(wp), DIMENSION(2) :: zts, zab + REAL(wp), DIMENSION(jpi,jpj) :: zustar ! friction velocity + !!--------------------------------------------------------------------- + ! + ! compute Pr and Sc number (eq ??) + zPr = 13.8_wp + zSc = 2432.0_wp + ! + ! compute gamma mole (eq ??) + zgmolet = 12.5_wp * zPr ** (2.0/3.0) - 6.0_wp + zgmoles = 12.5_wp * zSc ** (2.0/3.0) - 6.0_wp + ! + ! compute gamma + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + + ikt = mikt(ji,jj) + + ! compute ustar + zustar(ji,jj) = SQRT( pCd(ji,jj) * ( putbl(ji,jj) * putbl(ji,jj) + pvtbl(ji,jj) * pvtbl(ji,jj) + pke2 ) ) + + IF( zustar(ji,jj) == 0._wp ) THEN ! only for kt = 1 I think + pgt(ji,jj) = rn_gammat0 + pgs(ji,jj) = rn_gammas0 + ELSE + ! compute bouyancy + zts(jp_tem) = pttbl(ji,jj) + zts(jp_sal) = pstbl(ji,jj) + zdep = (gdepw_0(ji,jj,ikt)*(1._wp+r3t(ji,jj,Kmm))) + ! + CALL eos_rab( zts, zdep, zab, Kmm ) + ! + ! compute length scale (Eq ??) + zbuofdep = grav * ( zab(jp_tem) * pqoce(ji,jj) - zab(jp_sal) * pqfwf(ji,jj) ) + ! + ! compute Monin Obukov Length + ! Maximum boundary layer depth (Eq ??) + zhmax = (gdept_0(ji,jj,mbkt(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) - (gdepw_0(ji,jj,mikt(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) -0.001_wp + ! + ! Compute Monin obukhov length scale at the surface and Ekman depth: (Eq ??) + zmob = zustar(ji,jj) ** 3 / (vkarmn * (zbuofdep + zeps)) + zmols = SIGN(1._wp, zmob) * MIN(ABS(zmob), zhmax) * tmask(ji,jj,ikt) + ! + ! compute eta* (stability parameter) (Eq ??) + zetastar = 1._wp / ( SQRT(1._wp + MAX( 0._wp, zxsiN * zustar(ji,jj) & + & / MAX( 1.e-20, ABS(ff_t(ji,jj)) * zmols * pRc(ji,jj) ) ))) + ! + ! compute the sublayer thickness (Eq ??) + zhnu = 5 * znu / MAX( 1.e-20, zustar(ji,jj) ) + ! + ! compute gamma turb (Eq ??) + zgturb = 1._wp / vkarmn * LOG(zustar(ji,jj) * zxsiN * zetastar * zetastar / MAX( 1.e-10, ABS(ff_t(ji,jj)) * zhnu )) & + & + 1._wp / ( 2 * zxsiN * zetastar ) - 1._wp / vkarmn + ! + ! compute gammats + pgt(ji,jj) = zustar(ji,jj) / (zgturb + zgmolet) + pgs(ji,jj) = zustar(ji,jj) / (zgturb + zgmoles) + END IF + END DO ; END DO + ! output ustar + CALL iom_put('isfustar',zustar(:,:)) + + END SUBROUTINE gammats_vel_stab + +END MODULE isfcavgam diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcavmlt.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcavmlt.f90 new file mode 100644 index 0000000000000000000000000000000000000000..55da8c6af22064692f493769195db4e5336f98bf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcavmlt.f90 @@ -0,0 +1,330 @@ + + + + + + + + + + + + + +MODULE isfcavmlt + !!====================================================================== + !! *** MODULE isfcavmlt *** + !! ice shelf module : update surface ocean boundary condition under ice + !! shelves + !!====================================================================== + !! History : 4.0 ! 2019-09 (P. Mathiot) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfcav_mlt : compute or read ice shelf fwf/heat fluxes from isf + !! to oce + !!---------------------------------------------------------------------- + + USE isf_oce ! ice shelf + USE isftbl , ONLY: isf_tbl ! ice shelf depth average + USE isfutils,ONLY: debug ! debug subroutine + + USE dom_oce ! ocean space and time domain + USE phycst , ONLY: rcp, rho0, rho0_rcp ! physical constants + USE eosbn2 , ONLY: eos_fzp ! equation of state + + USE in_out_manager ! I/O manager + USE iom , ONLY: iom_put ! I/O library + USE fldread , ONLY: fld_read, FLD, FLD_N ! + USE lib_fortran, ONLY: glob_sum ! + USE lib_mpp , ONLY: ctl_stop ! + + IMPLICIT NONE + PRIVATE + + PUBLIC isfcav_mlt + + !! * Substitutions + + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +! ------------------------------------------------------------------------------------------------------- +! -------------------------------- PUBLIC SUBROUTINE ---------------------------------------------------- +! ------------------------------------------------------------------------------------------------------- + + SUBROUTINE isfcav_mlt(kt, pgt, pgs , pttbl, pstbl, & + & pqhc, pqoce, pqfwf ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE isfcav_mlt *** + !! + !! ** Purpose : compute or read ice shelf fwf/heat fluxes in the ice shelf cavity + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: kt + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt , pgs ! gamma t and gamma s + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer + !!--------------------------------------------------------------------- + ! + ! compute latent heat and melt (2d) + SELECT CASE ( cn_isfcav_mlt ) + CASE ( 'spe' ) ! ice shelf melt specified (read input file, and heat fluxes derived from + CALL isfcav_mlt_spe( kt, pstbl, & + & pqhc, pqoce, pqfwf ) + CASE ( '2eq' ) ! ISOMIP formulation (2 equations) for volume flux (Hunter et al., 2006) + CALL isfcav_mlt_2eq( pgt, pttbl, pstbl, & + & pqhc , pqoce, pqfwf ) + CASE ( '3eq' ) ! ISOMIP+ formulation (3 equations) for volume flux (Asay-Davis et al., 2015) + CALL isfcav_mlt_3eq( pgt, pgs , pttbl, pstbl, & + & pqhc, pqoce, pqfwf ) + CASE ( 'oasis' ) ! fwf pass trough oasis + CALL isfcav_mlt_oasis( kt, pstbl, & + & pqhc, pqoce, pqfwf ) + CASE DEFAULT + CALL ctl_stop('STOP', 'unknown isf melt formulation : cn_isfcav (should not see this)') + END SELECT + ! + IF (ln_isfdebug) THEN + IF(lwp) WRITE(numout,*) '' + CALL debug( 'isfcav_mlt qhc :', pqhc (:,:) ) + CALL debug( 'isfcav_mlt qoce :', pqoce(:,:) ) + CALL debug( 'isfcav_mlt qfwf :', pqfwf(:,:) ) + IF(lwp) WRITE(numout,*) '' + END IF + ! + END SUBROUTINE isfcav_mlt + +! ------------------------------------------------------------------------------------------------------- +! -------------------------------- PRIVATE SUBROUTINE --------------------------------------------------- +! ------------------------------------------------------------------------------------------------------- + + SUBROUTINE isfcav_mlt_spe(kt, pstbl, & ! <<== in + & pqhc , pqoce, pqfwf ) ! ==>> out + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE isfcav_mlt_spe *** + !! + !! ** Purpose : - read ice shelf melt from forcing file + !! - compute ocea-ice heat flux (assuming it is equal to latent heat) + !! - compute heat content flux + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + INTEGER , INTENT(in ) :: kt ! current time step + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pstbl ! salinity in tbl + !!-------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature + !!-------------------------------------------------------------------- + ! + ! Compute freezing temperature + CALL eos_fzp( pstbl(:,:), ztfrz(:,:), REAL(risfdep(:,:),dp) ) + ! + ! read input file of fwf (from isf to oce; ie melt) + CALL fld_read ( kt, 1, sf_isfcav_fwf ) + ! + ! define fwf and qoce + ! ocean heat flux is assume to be equal to the latent heat + pqfwf(:,:) = sf_isfcav_fwf(1)%fnow(:,:,1) ! fwf ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean heat flux ( > 0 from isf to oce) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + ! output freezing point at the interface + CALL iom_put('isftfrz_cav', ztfrz(:,:) * mskisf_cav(:,:) ) + ! + END SUBROUTINE isfcav_mlt_spe + + SUBROUTINE isfcav_mlt_2eq(pgt , pttbl, pstbl, & ! <<== in + & pqhc, pqoce, pqfwf ) ! ==>> out + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE isfcav_mlt_2eq *** + !! + !! ** Purpose : Compute ice shelf fwf/heqt fluxes using ISOMIP formulation (Hunter et al., 2006) + !! + !! ** Method : The ice shelf melt latent heat is defined as being equal to the ocean/ice heat flux. + !! From this we can derived the fwf, ocean/ice heat flux and the heat content flux as being : + !! qfwf = Gammat * rho0 * Cp * ( Tw - Tfrz ) / Lf + !! qhoce = qlat + !! qhc = qfwf * Cp * Tfrz + !! + !! ** Reference : Hunter, J. R.: Specification for test models of ice shelf cavities, + !! Tech. Rep. June, Antarctic Climate & Ecosystems Cooperative Research Centre, available at: + !! http://staff.acecrc.org.au/~bkgalton/ISOMIP/test_cavities.pdf (last access: 21 July 2016), 2006. + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! hean content, ocean-ice heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt ! temperature exchange coeficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! temperature and salinity in top boundary layer + !!-------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing temperature + REAL(wp), DIMENSION(jpi,jpj) :: zthd ! thermal driving + !!-------------------------------------------------------------------- + ! + ! Calculate freezing temperature + CALL eos_fzp( pstbl(:,:), ztfrz(:,:), REAL(risfdep(:,:),dp) ) + ! + ! thermal driving + zthd (:,:) = ( pttbl(:,:) - ztfrz(:,:) ) * mskisf_cav(:,:) + ! + ! compute ocean-ice heat flux and then derive fwf assuming that ocean heat flux equal latent heat + pqfwf(:,:) = pgt(:,:) * rho0_rcp * zthd(:,:) / rLfusisf ! fresh water flux ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocea-ice flux ( > 0 from isf to oce) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + ! output thermal driving and freezinpoint at the ice shelf interface + CALL iom_put('isfthermald_cav', zthd ) + CALL iom_put('isftfrz_cav' , ztfrz(:,:) * mskisf_cav(:,:) ) + ! + END SUBROUTINE isfcav_mlt_2eq + + SUBROUTINE isfcav_mlt_3eq(pgt, pgs , pttbl, pstbl, & ! <<== in + & pqhc, pqoce, pqfwf ) ! ==>> out + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE isfcav_mlt_3eq *** + !! + !! ** Purpose : Compute ice shelf fwf/heqt fluxes using the 3 equation formulation + !! + !! ** Method : The melt rate is determined considering the heat balance, the salt balance + !! at the phase change interface and a linearisation of the equation of state. + !! + !! ** Reference : - Holland, D. M. and Jenkins, A., + !! Modeling Thermodynamic Ice-Ocean Interactions at the Base of an Ice Shelf, + !! J. Phys. Oceanogr., 29, 1999. + !! - Asay-Davis, X. S., Cornford, S. L., Durand, G., Galton-Fenzi, B. K., Gladstone, + !! R. M., Gudmundsson, G. H., Hattermann, T., Holland, D. M., Holland, D., Holland, + !! P. R., Martin, D. F., Mathiot, P., Pattyn, F., and Seroussi, H.: + !! Experimental design for three interrelated marine ice sheet and ocean model intercomparison projects: + !! MISMIP v. 3 (MISMIP +), ISOMIP v. 2 (ISOMIP +) and MISOMIP v. 1 (MISOMIP1), + !! Geosci. Model Dev., 9, 2471-2497, https://doi.org/10.5194/gmd-9-2471-2016, 2016. + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! latent heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt , pgs ! heat/salt exchange coeficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! mean temperature and salinity in top boundary layer + !!-------------------------------------------------------------------- + REAL(wp) :: zeps1,zeps2,zeps3,zeps4,zeps6,zeps7 ! dummy local scalar for quadratic equation resolution + REAL(wp) :: zaqe,zbqe,zcqe,zaqer,zdis,zsfrz,zcfac ! dummy local scalar for quadratic equation resolution + REAL(wp) :: zeps = 1.e-20 + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point + REAL(wp), DIMENSION(jpi,jpj) :: zqcon ! conductive flux through the ice shelf + REAL(wp), DIMENSION(jpi,jpj) :: zthd ! thermal driving + ! + INTEGER :: ji, jj ! dummy loop indices + !!-------------------------------------------------------------------- + ! + ! compute upward heat flux zhtflx and upward water flux zwflx + ! Resolution of a 3d equation from equation 24, 25 and 26 (note conduction through the ice has been added to Eq 24) + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + ! compute coeficient to solve the 2nd order equation + zeps1 = rho0_rcp * pgt(ji,jj) + zeps2 = rLfusisf * rho0 * pgs(ji,jj) + zeps3 = rhoisf * rcpisf * rkappa / MAX(risfdep(ji,jj),zeps) + zeps4 = risf_lamb2 + risf_lamb3 * risfdep(ji,jj) + zeps6 = zeps4 - pttbl(ji,jj) + zeps7 = zeps4 - rtsurf + ! + ! solve the 2nd order equation to find zsfrz + zaqe = risf_lamb1 * (zeps1 + zeps3) + zaqer = 0.5_wp / MIN(zaqe,-zeps) + zbqe = zeps1 * zeps6 + zeps3 * zeps7 - zeps2 + zcqe = zeps2 * pstbl(ji,jj) + zdis = zbqe * zbqe - 4.0_wp * zaqe * zcqe + ! + ! Presumably zdis can never be negative because gammas is very small compared to gammat + zsfrz=(-zbqe - SQRT(zdis)) * zaqer + IF ( zsfrz < 0.0_wp ) zsfrz=(-zbqe + SQRT(zdis)) * zaqer ! check this if this if is needed + ! + ! compute t freeze (eq. 25) + ztfrz(ji,jj) = zeps4 + risf_lamb1 * zsfrz + ! + ! thermal driving + zthd(ji,jj) = ( pttbl(ji,jj) - ztfrz(ji,jj) ) + ! + ! compute the upward water and heat flux (eq. 24 and eq. 26) + pqfwf(ji,jj) = - rho0 * pgs(ji,jj) * ( zsfrz - pstbl(ji,jj) ) / MAX(zsfrz,zeps) ! fresh water flux ( > 0 from isf to oce) + pqoce(ji,jj) = - rho0_rcp * pgt(ji,jj) * zthd (ji,jj) ! ocean-ice heat flux ( > 0 from isf to oce) + pqhc (ji,jj) = rcp * pqfwf(ji,jj) * ztfrz(ji,jj) ! heat content flux ( > 0 from isf to oce) + ! + zqcon(ji,jj) = zeps3 * ( ztfrz(ji,jj) - rtsurf ) + ! + END DO ; END DO + ! + ! output conductive heat flux through the ice + CALL iom_put('qconisf', zqcon(:,:) * mskisf_cav(:,:) ) + ! + ! output thermal driving and freezing point at the interface + CALL iom_put('isfthermald_cav', zthd (:,:) * mskisf_cav(:,:) ) + CALL iom_put('isftfrz_cav' , ztfrz(:,:) * mskisf_cav(:,:) ) + ! + END SUBROUTINE isfcav_mlt_3eq + + SUBROUTINE isfcav_mlt_oasis(kt, pstbl, & ! <<== in + & pqhc , pqoce, pqfwf ) ! ==>> out + !!---------------------------------------------------------------------- + !! *** ROUTINE isfcav_mlt_oasis *** + !! + !! ** Purpose : scale the fwf read from input file by the total amount received by the sbccpl interface + !! + !! ** Purpose : - read ice shelf melt from forcing file => pattern + !! - total amount of fwf is given by sbccpl (fwfisf_cpl) + !! - scale fwf and compute heat fluxes + !! + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + INTEGER , INTENT(in ) :: kt ! current time step + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pstbl ! salinity in tbl + !!-------------------------------------------------------------------- + REAL(wp) :: zfwf_fld, zfwf_oasis ! total fwf in the forcing fields (pattern) and from the oasis interface (amount) + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature + REAL(wp), DIMENSION(jpi,jpj) :: zfwf ! 2d fwf map after scaling + !!-------------------------------------------------------------------- + ! + ! Calculate freezing temperature + CALL eos_fzp( pstbl(:,:), ztfrz(:,:), REAL(risfdep(:,:),dp) ) + ! + ! read input file of fwf from isf to oce + CALL fld_read ( kt, 1, sf_isfcav_fwf ) + ! + ! ice shelf 2d map + zfwf(:,:) = sf_isfcav_fwf(1)%fnow(:,:,1) + ! + ! compute glob sum from input file + ! (PM) should consider delay sum as in fwb (1 time step offset if I well understood) + zfwf_fld = glob_sum('isfcav_mlt', e1e2t(:,:) * zfwf(:,:)) + ! + ! compute glob sum from atm->oce ice shelf fwf + ! (PM) should consider delay sum as in fwb (1 time step offset if I well understood) + zfwf_oasis = glob_sum('isfcav_mlt', e1e2t(:,:) * fwfisf_oasis(:,:)) + ! + ! scale fwf + zfwf(:,:) = zfwf(:,:) * zfwf_oasis / zfwf_fld + ! + ! define fwf and qoce + ! ocean heat flux is assume to be equal to the latent heat + pqfwf(:,:) = zfwf(:,:) ! fwf ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean heat flux ( > 0 from isf to oce) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + CALL iom_put('isftfrz_cav', ztfrz * mskisf_cav(:,:) ) + ! + END SUBROUTINE isfcav_mlt_oasis + +END MODULE isfcavmlt diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcpl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcpl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b80a69f8aac307be608d203ece754cc9c974f1a0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfcpl.f90 @@ -0,0 +1,787 @@ + + + + + + + + + + + + + +MODULE isfcpl + !!====================================================================== + !! *** MODULE isfcpl *** + !! + !! iceshelf coupling module : module managing the coupling between NEMO and an ice sheet model + !! + !!====================================================================== + !! History : 4.1 ! 2019-07 (P. Mathiot) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfrst : read/write iceshelf variables in/from restart + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE domqco , ONLY : dom_qco_zgr ! vertical scale factor interpolation + USE domutl , ONLY : dom_ngb ! find the closest grid point from a given lon/lat position + USE isf_oce ! ice shelf variable + USE isfutils, ONLY : debug + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lib_mpp , ONLY : mpp_sum, mpp_max ! mpp routine + ! + IMPLICIT NONE + + PRIVATE + + PUBLIC isfcpl_rst_write, isfcpl_init ! iceshelf restart read and write + PUBLIC isfcpl_ssh, isfcpl_tra, isfcpl_vol, isfcpl_cons ! iceshelf correction for ssh, tra, dyn and conservation + + TYPE isfcons + INTEGER :: ii ! i global + INTEGER :: jj ! j global + INTEGER :: kk ! k level + REAL(wp):: dvol ! volume increment + REAL(wp):: dsal ! salt increment + REAL(wp):: dtem ! heat increment + REAL(wp):: lon ! lon + REAL(wp):: lat ! lat + INTEGER :: ngb ! 0/1 (valid location or not (ie on halo or no neigbourg)) + END TYPE + ! + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE isfcpl_init(Kbb, Kmm, Kaa) + !!--------------------------------------------------------------------- + !! *** ROUTINE iscpl_init *** + !! + !! ** Purpose : correct ocean state for new wet cell and horizontal divergence + !! correction for the dynamical adjustement + !! + !! ** Action : - compute ssh on new wet cell + !! - compute T/S on new wet cell + !! - compute horizontal divergence correction as a volume flux + !! - compute the T/S/vol correction increment to keep trend to 0 + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + !!--------------------------------------------------------------------- + INTEGER :: id + !!---------------------------------------------------------------------- + ! + ! start on an euler time step + l_1st_euler = .TRUE. + ! + ! allocation and initialisation to 0 + CALL isf_alloc_cpl() + ! + ! check presence of variable needed for coupling + ! iom_varid return 0 if not found + id = 1 + id = id * iom_varid(numror, 'ssmask', ldstop = .false.) + id = id * iom_varid(numror, 'tmask' , ldstop = .false.) + id = id * iom_varid(numror, 'e3t_n' , ldstop = .false.) + id = id * iom_varid(numror, 'e3u_n' , ldstop = .false.) + id = id * iom_varid(numror, 'e3v_n' , ldstop = .false.) + IF(lwp) WRITE(numout,*) ' isfcpl_init:', id + IF (id == 0) THEN + IF(lwp) WRITE(numout,*) ' isfcpl_init: restart variables for ice sheet coupling are missing, skip coupling for this leg ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) '' + ELSE + ! extrapolation ssh + CALL isfcpl_ssh(Kbb, Kmm, Kaa) + ! + ! extrapolation tracer properties + CALL isfcpl_tra(Kmm) + ! + ! correction of the horizontal divergence and associated temp. and salt content flux + ! Need to : - include in the cpl cons the risfcpl_vol/tsc contribution + ! - decide how to manage thickness level change in conservation + CALL isfcpl_vol(Kmm) + ! + ! apply the 'conservation' method + IF ( ln_isfcpl_cons ) CALL isfcpl_cons(Kmm) + ! + END IF + ! + ! mask velocity properly (mask used in restart not compatible with new mask) + uu(:,:,:,Kmm) = uu(:,:,:,Kmm) * umask(:,:,:) + vv(:,:,:,Kmm) = vv(:,:,:,Kmm) * vmask(:,:,:) + ! + ! all before fields set to now values + ts (:,:,:,:,Kbb) = ts (:,:,:,:,Kmm) + uu (:,:,:,Kbb) = uu (:,:,:,Kmm) + vv (:,:,:,Kbb) = vv (:,:,:,Kmm) + ssh (:,:,Kbb) = ssh (:,:,Kmm) + END SUBROUTINE isfcpl_init + + + SUBROUTINE isfcpl_rst_write( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE iscpl_rst_write *** + !! + !! ** Purpose : write icesheet coupling variables in restart + !! + !!-------------------------- IN -------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!---------------------------------------------------------------------- + INTEGER :: jk ! loop index + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! for qco substitution + !!---------------------------------------------------------------------- + ! + DO jk = 1, jpk + ze3t(:,:,jk) = (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + ze3u(:,:,jk) = (e3u_0(:,:,jk)*(1._wp+r3u(:,:,Kmm)*umask(:,:,jk))) + ze3v(:,:,jk) = (e3v_0(:,:,jk)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,jk))) + ! + zgdepw(:,:,jk) = (gdepw_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) + END DO + ! + CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask ) + CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask ) + CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , ze3t ) + CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , ze3u ) + CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , ze3v ) + CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw ) + ! + END SUBROUTINE isfcpl_rst_write + + + SUBROUTINE isfcpl_ssh(Kbb, Kmm, Kaa) + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_ssh *** + !! + !! ** Purpose : basic guess of ssh in new wet cell + !! + !! ** Method : basic extrapolation from neigbourg cells + !! + !!---------------------------------------------------------------------- + !! + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jd, jk !! loop index + INTEGER :: jip1, jim1, jjp1, jjm1 + !! + REAL(wp):: zsummsk + REAL(wp), DIMENSION(jpi,jpj) :: zdssmask, zssmask0, zssmask_b, zssh + !!---------------------------------------------------------------------- + ! + CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b ) ! need to extrapolate T/S + + ! compute new ssh if we open a full water column + ! rude average of the closest neigbourgs (e1e2t not taking into account) + ! + zssh(:,:) = ssh(:,:,Kmm) + zssmask0(:,:) = zssmask_b(:,:) + ! + DO jd = 1, nn_drown + ! + zdssmask(:,:) = ssmask(:,:) - zssmask0(:,:) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + jip1=ji+1 ; jim1=ji-1 + jjp1=jj+1 ; jjm1=jj-1 + ! + zsummsk = zssmask0(jip1,jj) + zssmask0(jim1,jj) + zssmask0(ji,jjp1) + zssmask0(ji,jjm1) + ! + IF (zdssmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp) THEN + ssh(ji,jj,Kmm)=( zssh(jip1,jj)*zssmask0(jip1,jj) & + & + zssh(jim1,jj)*zssmask0(jim1,jj) & + & + zssh(ji,jjp1)*zssmask0(ji,jjp1) & + & + zssh(ji,jjm1)*zssmask0(ji,jjm1)) / zsummsk + zssmask_b(ji,jj) = 1._wp + ENDIF + END DO ; END DO + CALL lbc_lnk( 'isfcpl', ssh(:,:,Kmm), 'T', 1.0_dp) + CALL lbc_lnk( 'isfcpl', zssmask_b(:,:), 'T', 1.0_wp ) + ! + zssh(:,:) = ssh(:,:,Kmm) + zssmask0(:,:) = zssmask_b(:,:) + ! + ! + END DO + ! + ! update ssh(:,:,Kmm) + ssh(:,:,Kmm) = zssh(:,:) * ssmask(:,:) + ! + ssh(:,:,Kbb) = ssh(:,:,Kmm) + ! + IF ( ln_isfdebug ) CALL debug('isfcpl_ssh: sshn',REAL(ssh(:,:,Kmm),sp)) + ! + ! recompute the vertical scale factor, depth and water thickness + IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)' + IF(lwp) write(numout,*) '~~~~~~~~~~~' + CALL dom_qco_zgr(Kbb, Kmm) + ! + END SUBROUTINE isfcpl_ssh + + + SUBROUTINE isfcpl_tra(Kmm) + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_tra *** + !! + !! ** Purpose : compute new tn, sn in case of evolving geometry of ice shelves + !! + !! ** Method : tn, sn : basic extrapolation from neigbourg cells + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b + !REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: pdepw_b !! depth w before + !! + INTEGER :: ji, jj, jk, jd !! loop index + INTEGER :: jip1, jim1, jjp1, jjm1, jkp1, jkm1 + !! + REAL(wp):: zsummsk + REAL(wp):: zdz, zdzm1, zdzp1 + !! + REAL(wp), DIMENSION(jpi,jpj) :: zdmask + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask0, zwmaskn + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask1, zwmaskb, ztmp3d + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts0 + !!---------------------------------------------------------------------- + ! + CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b ) ! need to extrapolate T/S + !CALL iom_get( numror, jpdom_auto, 'wmask' , zwmask_b ) ! need to extrapolate T/S + !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:) ) ! need to interpol vertical profile (vvl) + ! + ! + ! compute new T/S (interpolation) if vvl only for common wet cell in before and after wmask + !PM: Is this IF needed since change to VVL by default + !bugged : to be corrected (PM) + ! back up original t/s/mask + !tsb (:,:,:,:) = ts(:,:,:,:,Kmm) + ! + ! compute new T/S (interpolation) if vvl only for common wet cell in before and after wmask + +! IF (.NOT.ln_linssh) THEN +! DO jk = 2,jpk-1 +! DO jj = 1,jpj +! DO ji = 1,jpi +! IF (wmask(ji,jj,jk) * zwmaskb(ji,jj,jk) == 1._wp .AND. (tmask(ji,jj,1)==0._wp .OR. ztmask_b(ji,jj,1)==0._wp) ) THEN +! +! !compute weight +! zdzp1 = MAX(0._wp,pdepw_b(ji,jj,jk+1) - (gdepw_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm)))) +! zdzm1 = MAX(0._wp,(gdepw_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm))) - pdepw_b(ji,jj,jk )) +! zdz = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) - zdzp1 - zdzm1 ! if isf : e3t = (gdepw_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm)))- (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) +! +! IF (zdz .LT. 0._wp) THEN +! CALL ctl_stop( 'STOP', 'rst_iscpl : unable to compute the interpolation' ) +! END IF +! +! ts(ji,jj,jk,jp_tem,Kmm) = ( zdzp1*ts(ji,jj,jk+1,jp_tem,Kbb) & +! & + zdz *ts(ji,jj,jk ,jp_tem,Kbb) & +! & + zdzm1*ts(ji,jj,jk-1,jp_tem,Kbb) )/(e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) +! +! ts(ji,jj,jk,jp_sal,Kmm) = ( zdzp1*ts(ji,jj,jk+1,jp_sal,Kbb) & +! & + zdz *ts(ji,jj,jk ,jp_sal,Kbb) & +! & + zdzm1*ts(ji,jj,jk-1,jp_sal,Kbb) )/(e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) +! +! END IF +! END DO +! END DO +! END DO +! END IF + + zts0(:,:,:,:) = ts(:,:,:,:,Kmm) + ztmask0(:,:,:) = ztmask_b(:,:,:) + ztmask1(:,:,:) = ztmask_b(:,:,:) + ! + ! iterate the extrapolation processes nn_drown times + DO jd = 1,nn_drown ! resolution dependent (OK for ISOMIP+ case) + DO jk = 1,jpk-1 + ! + ! define new wet cell + zdmask(:,:) = tmask(:,:,jk) - ztmask0(:,:,jk); + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + jip1=ji+1; jim1=ji-1; + jjp1=jj+1; jjm1=jj-1; + ! + ! check if a wet neigbourg cell is present + zsummsk = ztmask0(jip1,jj ,jk) + ztmask0(jim1,jj ,jk) & + + ztmask0(ji ,jjp1,jk) + ztmask0(ji ,jjm1,jk) + ! + ! if neigbourg wet cell available at the same level + IF ( zdmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp ) THEN + ! + ! horizontal basic extrapolation + ts(ji,jj,jk,1,Kmm)=( zts0(jip1,jj ,jk,1) * ztmask0(jip1,jj ,jk) & + & + zts0(jim1,jj ,jk,1) * ztmask0(jim1,jj ,jk) & + & + zts0(ji ,jjp1,jk,1) * ztmask0(ji ,jjp1,jk) & + & + zts0(ji ,jjm1,jk,1) * ztmask0(ji ,jjm1,jk) ) / zsummsk + ts(ji,jj,jk,2,Kmm)=( zts0(jip1,jj ,jk,2) * ztmask0(jip1,jj ,jk) & + & + zts0(jim1,jj ,jk,2) * ztmask0(jim1,jj ,jk) & + & + zts0(ji ,jjp1,jk,2) * ztmask0(ji ,jjp1,jk) & + & + zts0(ji ,jjm1,jk,2) * ztmask0(ji ,jjm1,jk) ) / zsummsk + ! + ! update mask for next pass + ztmask1(ji,jj,jk)=1 + ! + ! in case no neigbourg wet cell available at the same level + ! check if a wet cell is available below + ELSEIF (zdmask(ji,jj) == 1._wp .AND. zsummsk == 0._wp) THEN + ! + ! vertical extrapolation if horizontal extrapolation failed + jkm1=max(1,jk-1) ; jkp1=min(jpk,jk+1) + ! + ! check if a wet neigbourg cell is present + zsummsk = ztmask0(ji,jj,jkm1) + ztmask0(ji,jj,jkp1) + IF (zdmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp ) THEN + ts(ji,jj,jk,1,Kmm)=( zts0(ji,jj,jkp1,1)*ztmask0(ji,jj,jkp1) & + & + zts0(ji,jj,jkm1,1)*ztmask0(ji,jj,jkm1)) / zsummsk + ts(ji,jj,jk,2,Kmm)=( zts0(ji,jj,jkp1,2)*ztmask0(ji,jj,jkp1) & + & + zts0(ji,jj,jkm1,2)*ztmask0(ji,jj,jkm1)) / zsummsk + ! + ! update mask for next pass + ztmask1(ji,jj,jk)=1._wp + END IF + END IF + END DO ; END DO + END DO + ! + CALL lbc_lnk( 'isfcpl', ts(:,:,:,jp_tem,Kmm), 'T', 1.0_dp, ts(:,:,:,jp_sal,Kmm), 'T', 1.0_dp) + CALL lbc_lnk( 'isfcpl', ztmask1, 'T', 1.0_wp) + ! + ! update temperature and salinity and mask + zts0(:,:,:,:) = ts(:,:,:,:,Kmm) + ztmask0(:,:,:) = ztmask1(:,:,:) + ! + ! + END DO ! nn_drown + ! + ! mask new ts(:,:,:,:,Kmm) field + ts(:,:,:,jp_tem,Kmm) = zts0(:,:,:,jp_tem) * tmask(:,:,:) + ts(:,:,:,jp_sal,Kmm) = zts0(:,:,:,jp_sal) * tmask(:,:,:) + ! + ! sanity check + ! ----------------------------------------------------------------------------------------- + ! case we open a cell but no neigbour cells available to get an estimate of T and S + DO jk = 1, jpk-1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + IF (tmask(ji,jj,jk) == 1._wp .AND. ts(ji,jj,jk,2,Kmm) == 0._wp) & + & CALL ctl_stop('STOP', 'failing to fill all new weet cell, & + & try increase nn_drown or activate XXXX & + & in your domain cfg computation' ) + END DO ; END DO ; END DO + ! + END SUBROUTINE isfcpl_tra + + + SUBROUTINE isfcpl_vol(Kmm) + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_vol *** + !! + !! ** Purpose : compute the correction of the local divergence to apply + !! during the first time step after the coupling. + !! + !! ** Method : - compute horizontal vol div. before/after coupling + !! - compute vertical input + !! - compute correction + !! + !!---------------------------------------------------------------------- + !! + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk + INTEGER :: ikb, ikt + !! + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zqvolb, zqvoln ! vol flux div. before/after coupling + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3u_b, ze3v_b ! vertical scale factor before/after coupling + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b ! mask before coupling + !!---------------------------------------------------------------------- + ! + CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b ) + CALL iom_get( numror, jpdom_auto, 'e3u_n' , ze3u_b ) + CALL iom_get( numror, jpdom_auto, 'e3v_n' , ze3v_b ) + ! + ! 1.0: compute horizontal volume flux divergence difference before-after coupling + ! + DO jk = 1, jpk ! Horizontal slab + ! 1.1: get volume flux before coupling (>0 out) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zqvolb(ji,jj,jk) = & + & ( e2u(ji ,jj ) * ze3u_b(ji ,jj ,jk) * uu(ji ,jj ,jk,Kmm) & + & - e2u(ji-1,jj ) * ze3u_b(ji-1,jj ,jk) * uu(ji-1,jj ,jk,Kmm) & + & + e1v(ji ,jj ) * ze3v_b(ji ,jj ,jk) * vv(ji ,jj ,jk,Kmm) & + & - e1v(ji ,jj-1) * ze3v_b(ji ,jj-1,jk) * vv(ji ,jj-1,jk,Kmm) ) & + & * ztmask_b(ji,jj,jk) + END DO ; END DO + ! + ! 1.2: get volume flux after coupling (>0 out) + ! properly mask velocity + ! (velocity are still mask with old mask at this stage) + uu(:,:,jk,Kmm) = uu(:,:,jk,Kmm) * umask(:,:,jk) + vv(:,:,jk,Kmm) = vv(:,:,jk,Kmm) * vmask(:,:,jk) + ! compute volume flux divergence after coupling + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zqvoln(ji,jj,jk) = & + & ( e2u(ji ,jj ) * (e3u_0(ji ,jj ,jk)*(1._wp+r3u(ji ,jj ,Kmm)*umask(ji ,jj ,jk))) * uu(ji ,jj ,jk,Kmm) & + & - e2u(ji-1,jj ) * (e3u_0(ji-1,jj ,jk)*(1._wp+r3u(ji-1,jj ,Kmm)*umask(ji-1,jj ,jk))) * uu(ji-1,jj ,jk,Kmm) & + & + e1v(ji ,jj ) * (e3v_0(ji ,jj ,jk)*(1._wp+r3v(ji ,jj ,Kmm)*vmask(ji ,jj ,jk))) * vv(ji ,jj ,jk,Kmm) & + & - e1v(ji ,jj-1) * (e3v_0(ji ,jj-1,jk)*(1._wp+r3v(ji ,jj-1,Kmm)*vmask(ji ,jj-1,jk))) * vv(ji ,jj-1,jk,Kmm) ) & + & * tmask(ji,jj,jk) + ! + ! 1.3: get 3d volume flux difference (before - after cpl) (>0 out) + ! correction to add is _b - _n + risfcpl_vol(ji,jj,jk) = zqvolb(ji,jj,jk) - zqvoln(ji,jj,jk) + END DO ; END DO + END DO + ! + ! 2.0: include the contribution of the vertical velocity in the volume flux correction + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ! + ikt = mikt(ji,jj) + IF ( ikt > 1 .AND. ssmask(ji,jj) == 1 ) THEN + risfcpl_vol(ji,jj,ikt) = risfcpl_vol(ji,jj,ikt) + SUM(zqvolb(ji,jj,1:ikt-1)) ! test sign + ENDIF + ! + END DO ; END DO + ! + CALL lbc_lnk( 'isfcpl', risfcpl_vol, 'T', 1.0_wp ) + ! + ! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh) + ! + ! 3.1: mask volume flux divergence correction + risfcpl_vol(:,:,:) = risfcpl_vol(:,:,:) * tmask(:,:,:) + ! + ! 3.2: get 3d tr(:,:,:,:,Krhs) increment to apply at the first time step + ! temperature and salt content flux computed using local ts(:,:,:,:,Kmm) + ! (very simple advection scheme) + ! (>0 out) + risfcpl_tsc(:,:,:,jp_tem) = -risfcpl_vol(:,:,:) * ts(:,:,:,jp_tem,Kmm) + risfcpl_tsc(:,:,:,jp_sal) = -risfcpl_vol(:,:,:) * ts(:,:,:,jp_sal,Kmm) + ! + ! 3.3: ssh correction (for dynspg_ts) + risfcpl_ssh(:,:) = 0.0 + DO jk = 1,jpk + risfcpl_ssh(:,:) = risfcpl_ssh(:,:) + risfcpl_vol(:,:,jk) * r1_e1e2t(:,:) + END DO + ! + END SUBROUTINE isfcpl_vol + + + SUBROUTINE isfcpl_cons(Kmm) + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_cons *** + !! + !! ** Purpose : compute the corrective increment in volume/salt/heat to put back the vol/heat/salt + !! removed or added during the coupling processes (wet or dry new cell) + !! + !! ** Method : - compare volume/heat/salt before and after + !! - look for the closest wet cells (share amoung neigbourgs if there are) + !! - build the correction increment to applied at each time step + !! + !!---------------------------------------------------------------------- + ! + TYPE(isfcons), DIMENSION(:),ALLOCATABLE :: zisfpts ! list of point receiving a correction + ! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!---------------------------------------------------------------------- + INTEGER :: ji , jj , jk , jproc ! loop index + INTEGER :: jip1 , jim1, jjp1, jjm1 ! dummy indices + INTEGER :: iig , ijg, ik ! dummy indices + INTEGER :: jisf ! start, end and current position in the increment array + INTEGER :: ingb, ifind ! 0/1 target found or need to be found + INTEGER :: nisfl_area ! global number of cell concerned by the wet->dry case + INTEGER, DIMENSION(jpnij) :: nisfl ! local number of cell concerned by the wet->dry case + ! + REAL(wp) :: z1_sum, z1_rdtiscpl + REAL(wp) :: zdtem, zdsal, zdvol, zratio ! tem, sal, vol increment + REAL(wp) :: zlon , zlat ! target location + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b ! mask before + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t_b ! scale factor before + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zt_b ! scale factor before + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zs_b ! scale factor before + !!---------------------------------------------------------------------- + + !============================================================================== + ! 1.0: initialisation + !============================================================================== + + ! get restart variable + CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b(:,:,:) ) ! need to extrapolate T/S + CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) ) + CALL iom_get( numror, jpdom_auto, 'tn' , zt_b(:,:,:) ) + CALL iom_get( numror, jpdom_auto, 'sn' , zs_b(:,:,:) ) + + ! compute run length + nstp_iscpl = nitend - nit000 + 1 + rdt_iscpl = nstp_iscpl * rn_Dt + z1_rdtiscpl = 1._wp / rdt_iscpl + + IF (lwp) WRITE(numout,*) ' nb of stp for cons = ', nstp_iscpl + IF (lwp) WRITE(numout,*) ' coupling time step = ', rdt_iscpl + + ! initialisation correction + risfcpl_cons_vol = 0.0 + risfcpl_cons_ssh = 0.0 + risfcpl_cons_tsc = 0.0 + + !============================================================================== + ! 2.0: diagnose the heat, salt and volume input and compute the correction variable + ! for case where we wet a cell or cell still wet (no change in cell status) + !============================================================================== + + DO jk = 1,jpk-1 + DO jj = Njs0,Nje0 + DO ji = Nis0,Nie0 + + ! volume diff + zdvol = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * tmask (ji,jj,jk) & + & - ze3t_b(ji,jj,jk ) * ztmask_b(ji,jj,jk) + + ! heat diff + zdtem = ts (ji,jj,jk,jp_tem,Kmm) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * tmask (ji,jj,jk) & + - zt_b(ji,jj,jk) * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) + + ! salt diff + zdsal = ts(ji,jj,jk,jp_sal,Kmm) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * tmask (ji,jj,jk) & + - zs_b(ji,jj,jk) * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) + + ! volume, heat and salt differences in each cell (>0 means correction is an outward flux) + ! in addition to the geometry change unconservation, need to add the divergence correction as it is flux across the boundary + risfcpl_cons_vol(ji,jj,jk) = ( zdvol * e1e2t(ji,jj) + risfcpl_vol(ji,jj,jk) ) * z1_rdtiscpl + risfcpl_cons_tsc(ji,jj,jk,jp_sal) = ( - zdsal * e1e2t(ji,jj) + risfcpl_tsc(ji,jj,jk,jp_sal) ) * z1_rdtiscpl + risfcpl_cons_tsc(ji,jj,jk,jp_tem) = ( - zdtem * e1e2t(ji,jj) + risfcpl_tsc(ji,jj,jk,jp_tem) ) * z1_rdtiscpl + + END DO + END DO + END DO + ! + !============================================================================== + ! 3.0: diagnose the heat, salt and volume input and compute the correction variable + ! for case where we close a cell + !============================================================================== + ! + ! compute the total number of point receiving a correction increment for each processor + ! local + nisfl(:)=0 + DO jk = 1,jpk-1 + DO jj = Njs0,Nje0 + DO ji = Nis0,Nie0 + jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ; + IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN + nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp) + ENDIF + ENDDO + ENDDO + ENDDO + ! + ! global + CALL mpp_sum('isfcpl',nisfl ) + ! + ! allocate list of point receiving correction + ALLOCATE(zisfpts(nisfl(narea))) + ! + zisfpts(:) = isfcons(0,0,0,-HUGE(1.0), -HUGE(1.0), -HUGE(1.0), -HUGE(1.0), -HUGE(1.0), 0) + ! + ! start computing the correction and fill zisfpts + ! local + jisf = 0 + DO jk = 1,jpk-1 + DO jj = Njs0,Nje0 + DO ji = Nis0,Nie0 + IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN + + jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ; + + zdvol = risfcpl_cons_vol(ji,jj,jk ) + zdsal = risfcpl_cons_tsc(ji,jj,jk,jp_sal) + zdtem = risfcpl_cons_tsc(ji,jj,jk,jp_tem) + + IF ( SUM( tmask(jim1:jip1,jjm1:jjp1,jk) ) > 0._wp ) THEN + ! spread correction amoung neigbourg wet cells (horizontal direction first) + ! as it is a rude correction corner and lateral cell have the same weight + ! + z1_sum = 1._wp / SUM( tmask(jim1:jip1,jjm1:jjp1,jk) ) + ! + ! lateral cells + IF (tmask(jip1,jj ,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jj , jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(jim1,jj ,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jj , jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(ji ,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, ji , jjp1, jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(ji ,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, ji , jjm1, jk, zdvol, zdsal, zdtem, z1_sum) + ! + ! corner cells + IF (tmask(jip1,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jjm1, jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(jim1,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jjm1, jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(jim1,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jjp1, jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(jip1,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jjp1, jk, zdvol, zdsal, zdtem, z1_sum) + ! + ELSE IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN + ! spread correction amoung neigbourg wet cells (vertical direction) + CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1.0_wp, 0) + ELSE + ! need to find where to put correction in later on + CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1.0_wp, 1) + END IF + END IF + END DO + END DO + END DO + ! + ! share data among all processes because for some point we need to find the closest wet point (could be on other process) + DO jproc=1,jpnij + ! + ! share total number of isf point treated for proc jproc + IF (jproc==narea) THEN + nisfl_area=nisfl(jproc) + ELSE + nisfl_area=0 + END IF + CALL mpp_max('isfcpl',nisfl_area) + ! + DO jisf = 1,nisfl_area + ! + IF (jproc==narea) THEN + ! indices (conversion to global indices and sharing) + iig = zisfpts(jisf)%ii ; ijg = zisfpts(jisf)%jj ; ik = zisfpts(jisf)%kk + ! + ! data + zdvol = zisfpts(jisf)%dvol ; zdsal = zisfpts(jisf)%dsal ; zdtem = zisfpts(jisf)%dtem + ! + ! location + zlat = zisfpts(jisf)%lat ; zlon = zisfpts(jisf)%lon + ! + ! find flag + ingb = zisfpts(jisf)%ngb + ELSE + iig =0 ; ijg =0 ; ik =0 + zdvol=-HUGE(1.0) ; zdsal=-HUGE(1.0) ; zdtem=-HUGE(1.0) + zlat =-HUGE(1.0) ; zlon =-HUGE(1.0) + ingb = 0 + END IF + ! + ! share data (need synchronisation of data as get_correction call a global com) + CALL mpp_max('isfcpl',iig) ; CALL mpp_max('isfcpl',ijg) ; CALL mpp_max('isfcpl',ik) + CALL mpp_max('isfcpl',zdvol) ; CALL mpp_max('isfcpl',zdsal) ; CALL mpp_max('isfcpl',zdtem) + CALL mpp_max('isfcpl',zlat) ; CALL mpp_max('isfcpl',zlon) + CALL mpp_max('isfcpl',ingb) + ! + ! fill the 3d correction array + CALL get_correction(iig, ijg, ik, zlon, zlat, zdvol, zdsal, zdtem, ingb) + END DO + END DO + ! + !============================================================================== + ! 4.0: finalisation and compute ssh equivalent of the volume correction + !============================================================================== + ! + ! mask + risfcpl_cons_vol(:,:,: ) = risfcpl_cons_vol(:,:,: ) * tmask(:,:,:) + risfcpl_cons_tsc(:,:,:,jp_sal) = risfcpl_cons_tsc(:,:,:,jp_sal) * tmask(:,:,:) + risfcpl_cons_tsc(:,:,:,jp_tem) = risfcpl_cons_tsc(:,:,:,jp_tem) * tmask(:,:,:) + ! + ! add lbclnk + CALL lbc_lnk( 'isfcpl', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, & + & risfcpl_cons_vol(:,:,:) , 'T', 1.0_wp) + ! + ! ssh correction (for dynspg_ts) + DO jk = 1,jpk + risfcpl_cons_ssh(:,:) = risfcpl_cons_ssh(:,:) + risfcpl_cons_vol(:,:,jk) + END DO + risfcpl_cons_ssh(:,:) = risfcpl_cons_ssh(:,:) * r1_e1e2t(:,:) + ! + END SUBROUTINE isfcpl_cons + ! + SUBROUTINE update_isfpts(sisfpts, kpts, ki, kj, kk, pdvol, pdsal, pdtem, pratio, kfind) + !!--------------------------------------------------------------------- + !! *** ROUTINE update_isfpts *** + !! + !! ** Purpose : if a cell become dry, we need to put the corrective increment elsewhere + !! + !! ** Action : update the list of point + !! + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + TYPE(isfcons), DIMENSION(:), INTENT(inout) :: sisfpts + INTEGER, INTENT(inout) :: kpts + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: ki, kj, kk ! target location (kfind=0) + ! ! or source location (kfind=1) + INTEGER, INTENT(in ), OPTIONAL :: kfind ! 0 target cell already found + ! ! 1 target to be determined + REAL(wp), INTENT(in ) :: pdvol, pdsal, pdtem, pratio ! vol/sal/tem increment + ! ! and ratio in case increment span over multiple cells. + !!---------------------------------------------------------------------- + INTEGER :: ifind + !!---------------------------------------------------------------------- + ! + ! increment position + kpts = kpts + 1 + ! + ! define if we need to look for closest valid wet cell (no neighbours or neigbourg on halo) + IF ( PRESENT(kfind) ) THEN + ifind = kfind + ELSE + ifind = ( 1 - tmask_i(ki,kj) ) * tmask(ki,kj,kk) + END IF + ! + ! update isfpts structure + sisfpts(kpts) = isfcons(mig(ki), mjg(kj), kk, pratio * pdvol, pratio * pdsal, pratio * pdtem, glamt(ki,kj), gphit(ki,kj), ifind ) + ! + END SUBROUTINE update_isfpts + ! + SUBROUTINE get_correction( ki, kj, kk, plon, plat, pvolinc, psalinc, pteminc, kfind) + !!--------------------------------------------------------------------- + !! *** ROUTINE get_correction *** + !! + !! ** Action : - Find the closest valid cell if needed (wet and not on the halo) + !! - Scale the correction depending of pratio (case where multiple wet neigbourgs) + !! - Fill the correction array + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ki, kj, kk, kfind ! target point indices + REAL(wp), INTENT(in) :: plon, plat ! target point lon/lat + REAL(wp), INTENT(in) :: pvolinc, pteminc,psalinc ! correction increment for vol/temp/salt + !!---------------------------------------------------------------------- + INTEGER :: jj, ji, iig, ijg + !!---------------------------------------------------------------------- + ! + ! define global indice of correction location + iig = ki ; ijg = kj + IF ( kfind == 1 ) CALL dom_ngb( plon, plat, iig, ijg,'T', kk) + ! + ! fill the correction array + DO jj = mj0(ijg),mj1(ijg) + DO ji = mi0(iig),mi1(iig) + ! correct the vol_flx and corresponding heat/salt flx in the closest cell + risfcpl_cons_vol(ji,jj,kk) = risfcpl_cons_vol(ji,jj,kk ) + pvolinc + risfcpl_cons_tsc(ji,jj,kk,jp_sal) = risfcpl_cons_tsc(ji,jj,kk,jp_sal) + psalinc + risfcpl_cons_tsc(ji,jj,kk,jp_tem) = risfcpl_cons_tsc(ji,jj,kk,jp_tem) + pteminc + END DO + END DO + + END SUBROUTINE get_correction + +END MODULE isfcpl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfdiags.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfdiags.f90 new file mode 100644 index 0000000000000000000000000000000000000000..191f16f8ffd12190401090e36110453d51865ebe --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfdiags.f90 @@ -0,0 +1,144 @@ + + + + + + + + + + + + + +MODULE isfdiags + !!====================================================================== + !! *** MODULE isfdiags *** + !! ice shelf diagnostics module : manage the 2d and 3d flux outputs from the ice shelf module + !!====================================================================== + !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav + !! X.X ! 2006-02 (C. Wang ) Original code bg03 + !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_isf : update sbc under ice shelf + !!---------------------------------------------------------------------- + + USE in_out_manager ! I/O manager + USE dom_oce + USE isf_oce ! ice shelf variable + USE iom ! + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_diags_flx + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE isf_diags_flx(Kmm, ktop, kbot, phtbl, pfrac, cdisf, pqfwf, pqoce, pqlat, pqhc) + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_diags_flx *** + !! + !! ** Purpose : manage the 2d and 3d flux outputs of the ice shelf module + !! from isf to oce fwf, latent heat, heat content fluxes + !! + !!---------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + INTEGER , DIMENSION(jpi,jpj), INTENT(in) :: ktop , kbot ! top and bottom level of the tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqfwf, pqoce, pqlat, pqhc ! 2d var to map in 3d + CHARACTER(LEN=3), INTENT(in) :: cdisf ! parametrisation or interactive melt + !!--------------------------------------------------------------------- + CHARACTER(LEN=256) :: cvarqfwf , cvarqoce , cvarqlat , cvarqhc + CHARACTER(LEN=256) :: cvarqfwf3d, cvarqoce3d, cvarqlat3d, cvarqhc3d + !!--------------------------------------------------------------------- + ! + ! output melt + cvarqfwf = 'fwfisf_'//cdisf ; cvarqfwf3d = 'fwfisf3d_'//cdisf + cvarqoce = 'qoceisf_'//cdisf ; cvarqoce3d = 'qoceisf3d_'//cdisf + cvarqlat = 'qlatisf_'//cdisf ; cvarqlat3d = 'qlatisf3d_'//cdisf + cvarqhc = 'qhcisf_'//cdisf ; cvarqhc3d = 'qhcisf3d_'//cdisf + ! + ! output 2d melt rate, latent heat and heat content flux from the injected water + CALL iom_put( TRIM(cvarqfwf), pqfwf(:,:) ) ! mass flux ( > 0 from isf to oce) + CALL iom_put( TRIM(cvarqoce), pqoce(:,:) ) ! oce to ice flux ( > 0 from isf to oce) + CALL iom_put( TRIM(cvarqlat), pqlat(:,:) ) ! latent heat flux ( > 0 from isf to oce) + CALL iom_put( TRIM(cvarqhc) , pqhc (:,:) ) ! heat content flux ( > 0 from isf to oce) + ! + ! output 3d Diagnostics + IF ( iom_use( TRIM(cvarqfwf3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqfwf3d) , pqfwf(:,:)) + IF ( iom_use( TRIM(cvarqoce3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqoce3d) , pqoce(:,:)) + IF ( iom_use( TRIM(cvarqlat3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqlat3d) , pqoce(:,:)) + IF ( iom_use( TRIM(cvarqhc3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqhc3d) , pqhc (:,:)) + ! + END SUBROUTINE isf_diags_flx + + SUBROUTINE isf_diags_2dto3d(Kmm, ktop, kbot, phtbl, pfrac, cdvar, pvar2d) + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_diags_2dto3d *** + !! + !! ** Purpose : compute the 3d flux outputs as they are injected into NEMO + !! (ie uniformaly spread into the top boundary layer or parametrisation layer) + !! + !!---------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + INTEGER , DIMENSION(jpi,jpj), INTENT(in) :: ktop , kbot ! top and bottom level of the tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pvar2d ! 2d var to map in 3d + CHARACTER(LEN=*), INTENT(in) :: cdvar + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! loop indices + INTEGER :: ikt, ikb ! top and bottom level of the tbl + REAL(wp), DIMENSION(jpi,jpj) :: zvar2d ! + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvar3d ! 3d var to output + !!--------------------------------------------------------------------- + ! + ! compute 3d output + zvar2d(:,:) = pvar2d(:,:) / phtbl(:,:) + zvar3d(:,:,:) = 0._wp + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ikt = ktop(ji,jj) + ikb = kbot(ji,jj) + DO jk = ikt, ikb - 1 + zvar3d(ji,jj,jk) = zvar2d(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO + zvar3d(ji,jj,ikb) = zvar2d(ji,jj) * (e3t_0(ji,jj,ikb)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,ikb))) * pfrac(ji,jj) + END DO ; END DO + ! + CALL iom_put( TRIM(cdvar) , zvar3d(:,:,:)) + ! + END SUBROUTINE isf_diags_2dto3d + +END MODULE isfdiags diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfdynatf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfdynatf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cdeb9db878ce2046f2211d3b1c9f8416a77ab697 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfdynatf.f90 @@ -0,0 +1,119 @@ + + + + + + + + + + + + + +MODULE isfdynatf + !!========================================================================= + !! *** MODULE isfnxt *** + !! Ice shelf update: compute the dynatf ice shelf contribution + !!========================================================================= + !! History : OPA ! 2019-09 (P. Mathiot) Original code + !!------------------------------------------------------------------------- + + !!------------------------------------------------------------------------- + !! isfnxt : apply correction needed for the ice shelf to ensure conservation + !!------------------------------------------------------------------------- + + USE isf_oce + + USE phycst , ONLY: r1_rho0 ! physical constant + USE dom_oce ! time and space domain + USE oce, ONLY : ssh ! sea-surface height for qco substitution + + USE in_out_manager + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_dynatf + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE isf_dynatf ( kt, Kmm, pe3t_f, pcoef ) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_dynatf *** + !! + !! ** Purpose : compute the ice shelf volume filter correction for cavity, param, ice sheet coupling case + !! + !!-------------------------- OUT ------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3t_f ! time filtered scale factor to be corrected + ! + REAL(wp) , INTENT(in ) :: pcoef ! rn_atfp * rn_Dt * r1_rho0 + !!-------------------------------------------------------------------- + INTEGER :: jk ! loop index + !!-------------------------------------------------------------------- + ! + ! ice shelf cavity + IF ( ln_isfcav_mlt ) CALL isf_dynatf_mlt(Kmm, pe3t_f, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, fwfisf_cav, fwfisf_cav_b, pcoef) + ! + ! ice shelf parametrised + IF ( ln_isfpar_mlt ) CALL isf_dynatf_mlt(Kmm, pe3t_f, misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, fwfisf_par, fwfisf_par_b, pcoef) + ! + IF ( ln_isfcpl .AND. ln_rstart .AND. kt == nit000+1 ) THEN + DO jk = 1, jpkm1 + pe3t_f(:,:,jk) = pe3t_f(:,:,jk) - pcoef * risfcpl_vol(:,:,jk) * r1_e1e2t(:,:) + END DO + END IF + ! + END SUBROUTINE isf_dynatf + + SUBROUTINE isf_dynatf_mlt ( Kmm, pe3t_f, ktop, kbot, phtbl, pfrac, pfwf, pfwf_b, pcoef ) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_dynatf_mlt *** + !! + !! ** Purpose : compute the ice shelf volume filter correction for cavity or param + !! + !!-------------------------- IN ------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3t_f ! time-filtered scale factor to be corrected + INTEGER , DIMENSION(jpi,jpj) , INTENT(in ) :: ktop , kbot ! top and bottom level of tbl + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfrac, phtbl ! fraction of bottom cell included in tbl, tbl thickness + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf , pfwf_b ! now/before fwf + REAL(wp), INTENT(in ) :: pcoef ! rn_atfp * rn_Dt * r1_rho0 + !!---------------------------------------------------------------------- + INTEGER :: ji,jj,jk + REAL(wp), DIMENSION(jpi,jpj) :: zfwfinc + !!---------------------------------------------------------------------- + ! + ! compute fwf conservation correction + zfwfinc(:,:) = pcoef * ( pfwf_b(:,:) - pfwf(:,:) ) / ( (ht_0(:,:)*(1._wp+r3t(:,:,Kmm))) + 1._wp - ssmask(:,:) ) * r1_rho0 + ! + ! add the increment + DO jk = 1, jpkm1 + pe3t_f(:,:,jk) = pe3t_f(:,:,jk) + tmask(:,:,jk) * zfwfinc(:,:) & + & * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + END DO + ! + END SUBROUTINE isf_dynatf_mlt + +END MODULE isfdynatf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfhdiv.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfhdiv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3b8f038787d2ef39507039e8ee588bdba3485013 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfhdiv.f90 @@ -0,0 +1,173 @@ + + + + + + + + + + + + + +MODULE isfhdiv + !!====================================================================== + !! *** MODULE isfhdiv *** + !! ice shelf horizontal divergence module : update the horizontal divergence + !! with the ice shelf melt and coupling correction + !!====================================================================== + !! History : 4.0 ! 2019-09 (P. Mathiot) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isf_hdiv : update the horizontal divergence with the ice shelf + !! melt and coupling correction + !!---------------------------------------------------------------------- + + USE isf_oce ! ice shelf + + USE dom_oce ! time and space domain + USE phycst , ONLY: r1_rho0 ! physical constant + USE in_out_manager ! + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_hdiv + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE isf_hdiv( kt, Kmm, phdiv ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE isf_hdiv *** + !! + !! ** Purpose : update the horizontal divergence with the ice shelf contribution + !! (parametrisation, explicit, ice sheet coupling conservation + !! increment) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: phdiv ! horizontal divergence + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + IF ( ln_isf ) THEN + ! + ! ice shelf cavity contribution + IF ( ln_isfcav_mlt ) CALL isf_hdiv_mlt(misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, fwfisf_cav, fwfisf_cav_b, phdiv) + ! + ! ice shelf parametrisation contribution + IF ( ln_isfpar_mlt ) CALL isf_hdiv_mlt(misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, fwfisf_par, fwfisf_par_b, phdiv) + ! + ! ice sheet coupling contribution + IF ( ln_isfcpl .AND. kt /= 0 ) THEN + ! + ! Dynamical stability at start up after change in under ice shelf cavity geometry is achieve by correcting the divergence. + ! This is achieved by applying a volume flux in order to keep the horizontal divergence after remapping + ! the same as at the end of the latest time step. So correction need to be apply at nit000 (euler time step) and + ! half of it at nit000+1 (leap frog time step). + IF ( kt == nit000 ) CALL isf_hdiv_cpl(Kmm, risfcpl_vol , phdiv) + IF ( kt == nit000+1 ) CALL isf_hdiv_cpl(Kmm, risfcpl_vol*0.5_wp, phdiv) + ! + ! correct divergence every time step to remove any trend due to coupling + ! conservation option + IF ( ln_isfcpl_cons ) CALL isf_hdiv_cpl(Kmm, risfcpl_cons_vol, phdiv) + ! + END IF + ! + END IF + ! + END SUBROUTINE isf_hdiv + + SUBROUTINE isf_hdiv_mlt(ktop, kbot, phtbl, pfrac, pfwf, pfwf_b, phdiv) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE sbc_isf_div *** + !! + !! ** Purpose : update the horizontal divergence with the ice shelf inflow + !! + !! ** Method : pfwf is positive (outflow) and expressed as kg/m2/s + !! increase the divergence + !! + !! ** Action : phdivn increased by the ice shelf outflow + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phdiv + !!---------------------------------------------------------------------- + INTEGER , DIMENSION(jpi,jpj), INTENT(in ) :: ktop , kbot + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pfrac, phtbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pfwf , pfwf_b + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikt, ikb + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zhdiv + !!---------------------------------------------------------------------- + ! + !== fwf distributed over several levels ==! + ! + ! compute integrated divergence correction + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls) + zhdiv(ji,jj) = 0.5_wp * ( pfwf(ji,jj) + pfwf_b(ji,jj) ) * r1_rho0 / phtbl(ji,jj) + END DO ; END DO + ! + ! update divergence at each level affected by ice shelf top boundary layer + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls-1)*nthr) + ikt = ktop(ji,jj) + ikb = kbot(ji,jj) + ! level fully include in the ice shelf boundary layer + DO jk = ikt, ikb - 1 + phdiv(ji,jj,jk) = phdiv(ji,jj,jk) - zhdiv(ji,jj) + END DO + ! level partially include in ice shelf boundary layer + phdiv(ji,jj,ikb) = phdiv(ji,jj,ikb) - zhdiv(ji,jj) * pfrac(ji,jj) + END DO ; END DO + ! + END SUBROUTINE isf_hdiv_mlt + + SUBROUTINE isf_hdiv_cpl(Kmm, pqvol, phdiv) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE isf_hdiv_cpl *** + !! + !! ** Purpose : update the horizontal divergence with the ice shelf + !! coupling conservation increment + !! + !! ** Method : pqvol is positive (outflow) and expressed as m3/s + !! increase the divergence + !! + !! ** Action : phdivn increased by the ice shelf outflow + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phdiv + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pqvol + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk + !!---------------------------------------------------------------------- + ! + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls-1)*nthr) + phdiv(ji,jj,jk) = phdiv(ji,jj,jk) + pqvol(ji,jj,jk) * r1_e1e2t(ji,jj) & + & / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + END SUBROUTINE isf_hdiv_cpl + +END MODULE isfhdiv diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfload.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfload.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b9e75ae21161bd13c72c1951d1694cd84d1330d7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfload.f90 @@ -0,0 +1,146 @@ + + + + + + + + + + + + + +MODULE isfload + !!====================================================================== + !! *** MODULE isfload *** + !! Ice Shelves : compute ice shelf load (needed for the hpg) + !!====================================================================== + !! History : 4.1 ! 2019-09 (P. Mathiot) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isf_load : compute ice shelf load + !!---------------------------------------------------------------------- + + USE isf_oce, ONLY: cn_isfload, rn_isfload_T, rn_isfload_S ! ice shelf variables + + USE dom_oce ! vertical scale factor + USE eosbn2 , ONLY: eos ! eos routine + + USE lib_mpp, ONLY: ctl_stop ! ctl_stop routine + USE in_out_manager ! + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_load ! called by isfstp.F90 + ! + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isf_load ( Kmm, pisfload ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE isf_load *** + !! + !! ** Purpose : compute the ice shelf load + !! + !!-------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pisfload ! ice shelf load + !!---------------------------------------------------------------------- + ! + ! quality test: ice shelf in a stratify/uniform ocean should not drive any flow. + ! the smaller the residual flow is, the better it is. + ! + ! type of ice shelf cavity + SELECT CASE ( cn_isfload ) + CASE ( 'uniform' ) + CALL isf_load_uniform ( Kmm, pisfload ) + CASE DEFAULT + CALL ctl_stop('STOP','method cn_isfload to compute ice shelf load does not exist (isomip), check your namelist') + END SELECT + ! + END SUBROUTINE isf_load + + + SUBROUTINE isf_load_uniform( Kmm, pload ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE isf_load *** + !! + !! ** Purpose : compute the ice shelf load + !! + !! ** Method : The ice shelf is assumed to be in hydro static equilibrium + !! in water at -1.9 C and 34.4 PSU. Weight of the ice shelf is + !! integrated from top to bottom. + !! + !!-------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pload ! ice shelf load + ! + INTEGER :: ji, jj, jk + INTEGER :: ikt + REAL(wp), DIMENSION(jpi,jpj) :: zrhdtop_isf ! water density displaced by the ice shelf (at the interface) + REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts_top ! water properties displaced by the ice shelf + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrhd ! water density displaced by the ice shelf + !!---------------------------------------------------------------------- + ! + ! !- assume water displaced by the ice shelf is at T=rn_isfload_T and S=rn_isfload_S (rude) + zts_top(:,:,jp_tem) = rn_isfload_T ; zts_top(:,:,jp_sal) = rn_isfload_S + ! + DO jk = 1, jpk !- compute density of the water displaced by the ice shelf + CALL eos( zts_top(:,:,:), REAL((gdept_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))),sp), zrhd(:,:,jk) ) + END DO + ! + ! !- compute rhd at the ice/oce interface (ice shelf side) + CALL eos( zts_top , risfdep, zrhdtop_isf ) + ! + ! !- Surface value + ice shelf gradient + pload(:,:) = 0._wp ! compute pressure due to ice shelf load + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ikt = mikt(ji,jj) + ! + IF ( ikt > 1 ) THEN + ! ! top layer of the ice shelf + pload(ji,jj) = pload(ji,jj) & + & + zrhd (ji,jj,1) * (e3w_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))) + ! + DO jk = 2, ikt-1 ! core layers of the ice shelf + pload(ji,jj) = pload(ji,jj) + (zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) & + & * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + END DO + ! ! deepest part of the ice shelf (between deepest T point and ice/ocean interface + pload(ji,jj) = pload(ji,jj) + ( zrhdtop_isf(ji,jj) + zrhd(ji,jj,ikt-1) ) & + & * ( risfdep(ji,jj) - (gdept_0(ji,jj,ikt-1)*(1._wp+r3t(ji,jj,Kmm))) ) + ! + END IF + END DO ; END DO + ! + END SUBROUTINE isf_load_uniform + + !!====================================================================== +END MODULE isfload diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfpar.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfpar.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a661ade22fc7b358ef300f5062a9ccfab4d6704f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfpar.f90 @@ -0,0 +1,212 @@ + + + + + + + + + + + + + +MODULE isfpar + !!====================================================================== + !! *** MODULE isfpar *** + !! ice shelf module : update ocean boundary condition under ice + !! shelf + !!====================================================================== + !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav + !! X.X ! 2006-02 (C. Wang ) Original code bg03 + !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization + !! 4.1 ! 2019-09 (P. Mathiot) Restructuration + !! 4.2 ! 2021-05 (C. Ethe ) Test and fix oasis case + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfpar : compute ice shelf melt using a prametrisation of ice shelf cavities + !!---------------------------------------------------------------------- + USE isf_oce ! ice shelf + ! + USE isfrst , ONLY: isfrst_write, isfrst_read ! ice shelf restart read/write subroutine + USE isftbl , ONLY: isf_tbl_ktop, isf_tbl_lvl ! ice shelf top boundary layer properties subroutine + USE isfparmlt, ONLY: isfpar_mlt ! ice shelf melt formulation subroutine + USE isfdiags , ONLY: isf_diags_flx ! ice shelf diags subroutine + USE isfutils , ONLY: debug, read_2dcstdta ! ice shelf debug subroutine + ! + USE dom_oce , ONLY: bathy ! ocean space and time domain + USE par_oce , ONLY: jpi,jpj ! ocean space and time domain + USE phycst , ONLY: r1_rho0_rcp ! physical constants + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE fldread ! read input field at current time step + + IMPLICIT NONE + PRIVATE + + PUBLIC isf_par, isf_par_init + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isf_par( kt, Kmm, ptsc, pqfwf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_par *** + !! + !! ** Purpose : compute the heat and fresh water due to ice shelf melting/freezing using a parametrisation + !! + !! ** Comment : in isf_par and all its call tree, + !! 'tbl' means parametrisation layer (ie how the far field temperature/salinity is computed) + !! instead of in a proper top boundary layer as at the ice shelf ocean interface + !! as the action to compute the properties of the tbl or the parametrisation layer are the same, + !! (ie average T/S over a specific depth (can be across multiple levels)) + !! the name tbl was kept. + !! + !! ** Convention : all fluxes are from isf to oce + !! + !!--------------------------------------------------------------------- + !!-------------------------- OUT -------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: pqfwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(inout) :: ptsc + !!-------------------------- IN -------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!--------------------------------------------------------------------- + INTEGER :: ji, jj + REAL(wp), DIMENSION(jpi,jpj) :: zqoce, zqhc, zqlat, zqh + !!--------------------------------------------------------------------- + ! + ! compute heat content, latent heat and melt fluxes (2d) + CALL isfpar_mlt( kt, Kmm, zqhc, zqoce, pqfwf ) + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! compute heat and water flux (from isf to oce) + pqfwf(ji,jj) = pqfwf(ji,jj) * mskisf_par(ji,jj) + zqoce(ji,jj) = zqoce(ji,jj) * mskisf_par(ji,jj) + zqhc (ji,jj) = zqhc(ji,jj) * mskisf_par(ji,jj) + ! + ! compute latent heat flux (from isf to oce) + zqlat(ji,jj) = - pqfwf(ji,jj) * rLfusisf ! 2d latent heat flux (W/m2) + ! + ! total heat flux (from isf to oce) + zqh(ji,jj) = ( zqhc (ji,jj) + zqoce(ji,jj) ) + ! + ! set temperature content + ptsc(ji,jj,jp_tem) = zqh(ji,jj) * r1_rho0_rcp + END DO ; END DO + ! + ! output fluxes + CALL isf_diags_flx( Kmm, misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, 'par', pqfwf, zqoce, zqlat, zqhc) + ! + ! write restart variables (qoceisf, qhcisf, fwfisf for now and before) + IF (lrst_oce) CALL isfrst_write(kt, 'par', ptsc, pqfwf) + ! + IF ( ln_isfdebug ) THEN + IF(lwp) WRITE(numout,*) + CALL debug('isf_par: ptsc T',ptsc(:,:,1)) + CALL debug('isf_par: ptsc S',ptsc(:,:,2)) + CALL debug('isf_par: pqfwf fwf',pqfwf(:,:)) + IF(lwp) WRITE(numout,*) + END IF + ! + END SUBROUTINE isf_par + + SUBROUTINE isf_par_init + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_par_init *** + !! + !! ** Purpose : initialisation of the variable needed for the parametrisation of ice shelf melt + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr + REAL(wp), DIMENSION(jpi,jpj) :: ztblmax, ztblmin + !!---------------------------------------------------------------------- + ! + ! allocation + CALL isf_alloc_par() + ! + ! initialisation + misfkt_par(:,:) = 1 ; misfkb_par(:,:) = 1 + rhisf_tbl_par(:,:) = 1e-20 ; rfrac_tbl_par(:,:) = 0.0_wp + ! + ! define isf tbl tickness, top and bottom indice + CALL read_2dcstdta(TRIM(sn_isfpar_zmax%clname), TRIM(sn_isfpar_zmax%clvar), ztblmax) + CALL read_2dcstdta(TRIM(sn_isfpar_zmin%clname), TRIM(sn_isfpar_zmin%clvar), ztblmin) + ! + ! mask ice shelf parametrisation location + ztblmax(:,:) = ztblmax(:,:) * ssmask(:,:) + ztblmin(:,:) = ztblmin(:,:) * ssmask(:,:) + ! + ! if param used under an ice shelf overwrite ztblmin by the ice shelf draft + WHERE ( risfdep > 0._wp .AND. ztblmin > 0._wp ) + ztblmin(:,:) = risfdep(:,:) + END WHERE + ! + ! ensure ztblmax <= bathy + WHERE ( ztblmax(:,:) > bathy(:,:) ) + ztblmax(:,:) = bathy(:,:) + END WHERE + ! + ! compute ktop and update ztblmin to gdepw_0(misfkt_par) + CALL isf_tbl_ktop(ztblmin, misfkt_par) ! out: misfkt_par + ! ! inout: ztblmin + ! + ! initial tbl thickness + rhisf0_tbl_par(:,:) = ztblmax(:,:) - ztblmin(:,:) + ! + ! define iceshelf parametrisation mask + mskisf_par = 0 + WHERE ( rhisf0_tbl_par(:,:) > 0._wp ) + mskisf_par(:,:) = 1._wp + END WHERE + ! + ! read par variable from restart + IF ( ln_rstart ) CALL isfrst_read('par', risf_par_tsc, fwfisf_par, risf_par_tsc_b, fwfisf_par_b) + ! + SELECT CASE ( TRIM(cn_isfpar_mlt) ) + ! + CASE ( 'spe' ) + ! + ALLOCATE( sf_isfpar_fwf(1), STAT=ierr ) + ALLOCATE( sf_isfpar_fwf(1)%fnow(jpi,jpj,1), sf_isfpar_fwf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_isfpar_fwf, (/ sn_isfpar_fwf /), cn_isfdir, 'isf_par_init', 'read fresh water flux isf data', 'namisf' ) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> ice melt read from forcing field (cn_isfmlt_par = spe)' + ! + CASE ( 'bg03' ) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> bg03 parametrisation (cn_isfmlt_par = bg03)' + ! + ! read effective length + CALL read_2dcstdta(TRIM(sn_isfpar_Leff%clname), TRIM(sn_isfpar_Leff%clvar), risfLeff) + risfLeff = risfLeff*1000.0_wp !: convertion in m + ! + CASE ( 'oasis' ) + ! + ALLOCATE( sf_isfpar_fwf(1), STAT=ierr ) + ALLOCATE( sf_isfpar_fwf(1)%fnow(jpi,jpj,1), sf_isfpar_fwf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_isfpar_fwf, (/ sn_isfpar_fwf /), cn_isfdir, 'isf_par_init', 'read fresh water flux isf data', 'namisf' ) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> isf melt provided by OASIS (cn_isfmlt_par = oasis)' + ! + CASE DEFAULT + CALL ctl_stop( 'sbc_isf_init: wrong value of nn_isf' ) + END SELECT + ! + END SUBROUTINE isf_par_init + +END MODULE isfpar diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfparmlt.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfparmlt.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ed0ef0c0559366532e626b9c7182e4901a70af78 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfparmlt.f90 @@ -0,0 +1,262 @@ + + + + + + + + + + + + + +MODULE isfparmlt + !!====================================================================== + !! *** MODULE isfparmlt *** + !! Ice shelf parametrisation module : update surface ocean boundary condition under ice + !! shelf using an ice shelf melt parametrisation + !!====================================================================== + !! History : 4.0 ! original code + !!---------------------------------------------------------------------- + + USE isf_oce ! ice shelf + USE isftbl , ONLY: isf_tbl ! ice shelf depth average + USE isfutils,ONLY: debug ! debug subroutine + + USE dom_oce ! ocean space and time domain + USE oce , ONLY: ts ! ocean dynamics and tracers + USE phycst , ONLY: rcp, rho0 ! physical constants + USE eosbn2 , ONLY: eos_fzp ! equation of state + + USE in_out_manager ! I/O manager + USE iom , ONLY: iom_put ! I/O library + USE fldread , ONLY: fld_read, FLD, FLD_N ! + USE lib_fortran, ONLY: glob_sum ! + USE lib_mpp , ONLY: ctl_stop ! + + IMPLICIT NONE + + PRIVATE + + PUBLIC isfpar_mlt + + + !! * Substitutions + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +! ------------------------------------------------------------------------------------------------------- +! -------------------------------- PUBLIC SUBROUTINE ---------------------------------------------------- +! ------------------------------------------------------------------------------------------------------- + + SUBROUTINE isfpar_mlt( kt, Kmm, pqhc, pqoce, pqfwf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE isfpar_mlt *** + !! + !! ** Purpose : Compute Salt and Heat fluxes related to ice_shelf + !! melting and freezing + !! + !! ** Method : 2 parameterizations are available according + !! 1 : Specified melt flux + !! 2 : Beckmann & Goose parameterization + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqfwf, pqoce, pqhc ! fresh water, ice-ocean heat and heat content fluxes + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!--------------------------------------------------------------------- + ! + ! Choose among the available ice shelf parametrisation + SELECT CASE ( cn_isfpar_mlt ) + CASE ( 'spe' ) ! specified runoff in depth (Mathiot et al., 2017 in preparation) + CALL isfpar_mlt_spe(kt, Kmm, pqhc, pqoce, pqfwf) + CASE ( 'bg03' ) ! Beckmann and Goosse parametrisation + CALL isfpar_mlt_bg03(kt, Kmm, pqhc, pqoce, pqfwf) + CASE ( 'oasis' ) + CALL isfpar_mlt_oasis( kt, Kmm, pqhc, pqoce, pqfwf) + CASE DEFAULT + CALL ctl_stop('STOP', 'unknown isf melt formulation : cn_isfpar (should not see this)') + END SELECT + ! + IF (ln_isfdebug) THEN + IF(lwp) WRITE(numout,*) '' + CALL debug( 'isfpar_mlt qhc :', pqhc (:,:) ) + CALL debug( 'isfpar_mlt qoce :', pqoce(:,:) ) + CALL debug( 'isfpar_mlt qfwf :', pqfwf(:,:) ) + IF(lwp) WRITE(numout,*) '' + END IF + ! + END SUBROUTINE isfpar_mlt + +! ------------------------------------------------------------------------------------------------------- +! -------------------------------- PRIVATE SUBROUTINE --------------------------------------------------- +! ------------------------------------------------------------------------------------------------------- + + SUBROUTINE isfpar_mlt_spe(kt, Kmm, pqhc, pqoce, pqfwf) + !!--------------------------------------------------------------------- + !! *** ROUTINE isfpar_mlt_spe *** + !! + !! ** Purpose : prescribed ice shelf melting in case ice shelf cavities are closed. + !! data read into a forcing files. + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqhc, pqfwf, pqoce ! fresh water and ice-ocean heat fluxes + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!-------------------------------------------------------------------- + INTEGER :: jk + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz + !!-------------------------------------------------------------------- + ! + ! 0. ------------Read specified fwf from isf to oce + CALL fld_read ( kt, 1, sf_isfpar_fwf ) + ! + ! compute ptfrz + ! 1. ------------Mean freezing point + DO jk = 1,jpk + CALL eos_fzp(REAL(ts(:,:,jk,jp_sal,Kmm),sp), ztfrz3d(:,:,jk), (gdept_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)))) + END DO + CALL isf_tbl(Kmm, REAL(ztfrz3d,dp), ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) + ! + pqfwf(:,:) = sf_isfpar_fwf(1)%fnow(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean/ice shelf flux assume to be equal to latent heat flux ( > 0 from isf to oce) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + CALL iom_put('isftfrz_par', ztfrz(:,:) * mskisf_par(:,:) ) + ! + END SUBROUTINE isfpar_mlt_spe + + SUBROUTINE isfpar_mlt_bg03(kt, Kmm, pqhc, pqoce, pqfwf) + !!--------------------------------------------------------------------- + !! *** ROUTINE isfpar_mlt_bg03 *** + !! + !! ** Purpose : compute an estimate of ice shelf melting and + !! latent, ocean-ice and heat content heat fluxes + !! in case cavities are closed based on the far fields T and S properties. + !! + !! ** Method : The ice shelf melt is computed as proportional to the differences between the + !! mean temperature and mean freezing point in front of the ice shelf averaged + !! over the ice shelf min ice shelf draft and max ice shelf draft and the freezing point + !! + !! ** Reference : Beckmann and Goosse (2003), "A parameterization of ice shelf-ocean + !! interaction for climate models", Ocean Modelling 5(2003) 157-170. + !!---------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqhc, pqfwf, pqoce ! fresh water and ice-ocean heat fluxes + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!-------------------------------------------------------------------- + INTEGER :: jk + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d ! freezing point + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point + REAL(wp), DIMENSION(jpi,jpj) :: ztavg ! temperature avg + !!---------------------------------------------------------------------- + ! + ! 0. ------------Mean freezing point + DO jk = 1,jpk + CALL eos_fzp(REAL(ts(:,:,jk,jp_sal,Kmm),sp), ztfrz3d(:,:,jk), (gdept_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)))) + END DO + CALL isf_tbl(Kmm, REAL(ztfrz3d,dp), ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) + ! + ! 1. ------------Mean temperature + CALL isf_tbl(Kmm, ts(:,:,:,jp_tem,Kmm), ztavg, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) + ! + ! 2. ------------Net heat flux and fresh water flux due to the ice shelf + pqfwf(:,:) = rho0 * rcp * rn_isfpar_bg03_gt0 * risfLeff(:,:) * e1t(:,:) * (ztavg(:,:) - ztfrz(:,:) ) * r1_e1e2t(:,:) / rLfusisf ! ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean/ice shelf flux assume to be equal to latent heat flux ( > 0 from isf to oce) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + ! 3. ------------BG03 output + ! output ttbl + CALL iom_put('ttbl_par', ztavg(:,:) * mskisf_par(:,:) ) + ! + ! output thermal driving + CALL iom_put('isfthermald_par',( ztavg(:,:) - ztfrz(:,:) ) * mskisf_par(:,:)) + ! + ! output freezing point used to define the thermal driving and heat content fluxes + CALL iom_put('isftfrz_par', ztfrz(:,:) * mskisf_par(:,:) ) + ! + END SUBROUTINE isfpar_mlt_bg03 + + SUBROUTINE isfpar_mlt_oasis(kt, Kmm, pqhc , pqoce, pqfwf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE isfpar_mlt_oasis *** + !! + !! ** Purpose : scale the fwf read from input file by the total amount received by the sbccpl interface + !! + !! ** Purpose : - read ice shelf melt from forcing file and scale it by the input file total amount => pattern + !! - compute total amount of fwf given by sbccpl (fwfisf_oasis) + !! - scale fwf and compute heat fluxes + !! + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + INTEGER , INTENT(in ) :: kt ! current time step + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + !!-------------------------------------------------------------------- + INTEGER :: jk ! loop index + REAL(wp) :: zfwf_fld, zfwf_oasis ! total fwf in the forcing fields (pattern) and from the cpl interface (amount) + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature + REAL(wp), DIMENSION(jpi,jpj) :: zfwf ! 2d fwf map after scaling + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d + !!-------------------------------------------------------------------- + ! + ! 0. ------------Read specified runoff + CALL fld_read ( kt, 1, sf_isfpar_fwf ) + ! + ! 1. ------------Mean freezing point (needed for heat content flux) + DO jk = 1,jpk + CALL eos_fzp(REAL(ts(:,:,jk,jp_sal,Kmm),sp), ztfrz3d(:,:,jk), (gdept_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)))) + END DO + CALL isf_tbl(Kmm, REAL(ztfrz3d,dp), ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) + ! + ! 2. ------------Scale isf melt pattern with total amount from oasis + ! ice shelf 2d map of fwf from isf to oce + zfwf(:,:) = sf_isfpar_fwf(1)%fnow(:,:,1) + ! + ! compute glob sum from input file + ! (PM) should we consider delay sum as in fwb ? (it will offset by 1 time step if I understood well) + zfwf_fld = glob_sum('isfcav_mlt', e1e2t(:,:) * zfwf(:,:)) + ! + ! compute glob sum from atm->oce ice shelf fwf + ! (PM) should we consider delay sum as in fwb ? + zfwf_oasis = glob_sum('isfcav_mlt', e1e2t(:,:) * fwfisf_oasis(:,:)) + ! + ! scale fwf + zfwf(:,:) = zfwf(:,:) * zfwf_oasis / zfwf_fld + ! + ! 3. -----------Define fwf and qoce + ! ocean heat flux is assume to be equal to the latent heat + pqfwf(:,:) = zfwf(:,:) ! fwf ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean heat flux ( > 0 from isf to oce) (assumed to be the latent heat flux) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + CALL iom_put('isftfrz_par', ztfrz ) + ! + END SUBROUTINE isfpar_mlt_oasis + +END MODULE isfparmlt diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfrst.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfrst.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5e8f2e3c9a1a25bde46c6cf52630c767070477bc --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfrst.f90 @@ -0,0 +1,112 @@ + + + + + + + + + + + + + +MODULE isfrst + !!====================================================================== + !! *** MODULE isfrst *** + !! iceshelf restart module :read/write iceshelf variables from/in restart + !!====================================================================== + !! History : 4.1 ! 2019-07 (P. Mathiot) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfrst : read/write iceshelf variables in/from restart + !!---------------------------------------------------------------------- + ! + USE par_oce, ONLY: jpi,jpj,jpk,jpts ! time and space domain + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + ! + IMPLICIT NONE + + PRIVATE + + PUBLIC isfrst_read, isfrst_write ! iceshelf restart read and write + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isfrst_read( cdisf, ptsc, pfwf, ptsc_b, pfwf_b ) + !!--------------------------------------------------------------------- + !! + !! isfrst_read : read iceshelf variables from restart + !! + !!-------------------------- OUT -------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pfwf_b + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT( out) :: ptsc_b + !!-------------------------- IN -------------------------------------- + CHARACTER(LEN=3) , INTENT(in ) :: cdisf + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc + !!---------------------------------------------------------------------- + CHARACTER(LEN=256) :: cfwf_b, chc_b, csc_b + !!---------------------------------------------------------------------- + ! + ! define variable name + cfwf_b = 'fwfisf_'//TRIM(cdisf)//'_b' + chc_b = 'isf_hc_'//TRIM(cdisf)//'_b' + csc_b = 'isf_sc_'//TRIM(cdisf)//'_b' + ! + ! read restart + IF( .NOT.l_1st_euler ) THEN + IF(lwp) WRITE(numout,*) ' nit000-1 isf tracer content forcing fields read in the restart file' + CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:) ) ! before ice shelf melt + CALL iom_get( numror, jpdom_auto, chc_b , ptsc_b (:,:,jp_tem) ) ! before ice shelf heat flux + CALL iom_get( numror, jpdom_auto, csc_b , ptsc_b (:,:,jp_sal) ) ! before ice shelf heat flux + ELSE + pfwf_b(:,:) = pfwf(:,:) + ptsc_b(:,:,:) = ptsc(:,:,:) + ENDIF + ! + END SUBROUTINE isfrst_read + + + SUBROUTINE isfrst_write( kt, cdisf, ptsc, pfwf ) + !!--------------------------------------------------------------------- + !! + !! isfrst_write : write iceshelf variables in restart + !! + !!-------------------------- IN -------------------------------------- + INTEGER , INTENT(in ) :: kt + CHARACTER(LEN=3) , INTENT(in ) :: cdisf + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc + !!--------------------------------------------------------------------- + CHARACTER(LEN=256) :: cfwf_b, chc_b, csc_b + !!--------------------------------------------------------------------- + ! + ! ocean output print + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'isf : isf fwf and heat fluxes written in ocean restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + ! + ! define variable name + cfwf_b = 'fwfisf_'//TRIM(cdisf)//'_b' + chc_b = 'isf_hc_'//TRIM(cdisf)//'_b' + csc_b = 'isf_sc_'//TRIM(cdisf)//'_b' + ! + ! write restart variable + CALL iom_rstput( kt, nitrst, numrow, cfwf_b, pfwf(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, chc_b , ptsc(:,:,jp_tem) ) + CALL iom_rstput( kt, nitrst, numrow, csc_b , ptsc(:,:,jp_sal) ) + ! + END SUBROUTINE isfrst_write + + !!====================================================================== +END MODULE isfrst diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfstp.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfstp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..36be12b94d036354844861a870da19a5c30e82dc --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfstp.f90 @@ -0,0 +1,326 @@ + + + + + + + + + + + + + +MODULE isfstp + !!====================================================================== + !! *** MODULE isfstp *** + !! Ice Shelves : compute iceshelf load, melt and heat flux + !!====================================================================== + !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav + !! X.X ! 2006-02 (C. Wang ) Original code bg03 + !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization + !! 4.1 ! 2019-09 (P. Mathiot) Split param/explicit ice shelf and re-organisation + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfstp : compute iceshelf melt and heat flux + !!---------------------------------------------------------------------- + USE isf_oce ! isf variables + USE isfload, ONLY: isf_load ! ice shelf load + USE isftbl , ONLY: isf_tbl_lvl ! ice shelf boundary layer + USE isfpar , ONLY: isf_par, isf_par_init ! ice shelf parametrisation + USE isfcav , ONLY: isf_cav, isf_cav_init ! ice shelf cavity + USE isfcpl , ONLY: isfcpl_rst_write, isfcpl_init ! isf variables + + USE dom_oce ! ocean space and time domain + USE oce , ONLY: ssh ! sea surface height + USE domvvl, ONLY: ln_vvl_zstar ! zstar logical + USE zdfdrg, ONLY: r_Cdmin_top, r_ke0_top ! vertical physics: top/bottom drag coef. + ! + USE lib_mpp, ONLY: ctl_stop, ctl_nam + USE fldread, ONLY: FLD, FLD_N + USE in_out_manager ! I/O manager + USE timing + + IMPLICIT NONE + PRIVATE + + PUBLIC isf_stp, isf_init, isf_nam ! routine called in sbcmod and divhor + + !! * Substitutions + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: isfstp.F90 15529 2021-11-23 15:00:19Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isf_stp( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_stp *** + !! + !! ** Purpose : compute total heat flux and total fwf due to ice shelf melt + !! + !! ** Method : For each case (parametrisation or explicity cavity) : + !! - define the before fields + !! - compute top boundary layer properties + !! (in case of parametrisation, this is the + !! depth range model array used to compute mean far fields properties) + !! - compute fluxes + !! - write restart variables + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: jk ! loop index + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t ! 3D workspace + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('isf') + ! + !======================================================================= + ! 1.: compute melt and associated heat fluxes in the ice shelf cavities + !======================================================================= + ! + IF ( ln_isfcav_mlt ) THEN + ! + ! 1.1: before time step + IF ( kt /= nit000 ) THEN + risf_cav_tsc_b (:,:,:) = risf_cav_tsc (:,:,:) + fwfisf_cav_b(:,:) = fwfisf_cav(:,:) + END IF + ! + ! 1.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl) + rhisf_tbl_cav(:,:) = rn_htbl * mskisf_cav(:,:) + DO jk = 1, jpk + ze3t(:,:,jk) = (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + END DO + CALL isf_tbl_lvl( REAL((ht_0(:,:)*(1._wp+r3t(:,:,Kmm))),sp), ze3t , misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) + ! + ! 1.3: compute ice shelf melt + CALL isf_cav( kt, Kmm, risf_cav_tsc, fwfisf_cav ) + ! + END IF + ! + !================================================================================= + ! 2.: compute melt and associated heat fluxes for not resolved ice shelf cavities + !================================================================================= + ! + IF ( ln_isfpar_mlt ) THEN + ! + ! 2.1: before time step + IF ( kt /= nit000 ) THEN + risf_par_tsc_b(:,:,:) = risf_par_tsc(:,:,:) + fwfisf_par_b (:,:) = fwfisf_par (:,:) + END IF + ! + ! 2.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl) + ! by simplicity, we assume the top level where param applied do not change with time (done in init part) + rhisf_tbl_par(:,:) = rhisf0_tbl_par(:,:) + DO jk = 1, jpk + ze3t(:,:,jk) = (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + END DO + CALL isf_tbl_lvl( REAL((ht_0(:,:)*(1._wp+r3t(:,:,Kmm))),sp), ze3t , misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) + ! + ! 2.3: compute ice shelf melt + CALL isf_par( kt, Kmm, risf_par_tsc, fwfisf_par ) + ! + END IF + ! + !================================================================================== + ! 3.: output specific restart variable in case of coupling with an ice sheet model + !================================================================================== + ! + IF ( ln_isfcpl .AND. lrst_oce ) CALL isfcpl_rst_write(kt, Kmm) + ! + IF( ln_timing ) CALL timing_stop('isf') + ! + END SUBROUTINE isf_stp + + + SUBROUTINE isf_init( Kbb, Kmm, Kaa ) + !!--------------------------------------------------------------------- + !! *** ROUTINE isfstp_init *** + !! + !! ** Purpose : Initialisation of the ice shelf public variables + !! + !! ** Method : Read the namisf namelist, check option compatibility and set derived parameters + !! + !! ** Action : - read namisf parameters + !! - allocate memory + !! - output print + !! - ckeck option compatibility + !! - call cav/param/isfcpl init routine + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + !!---------------------------------------------------------------------- + ! + ! constrain: l_isfoasis need to be known + ! + CALL isf_nam() ! Read namelist + ! + CALL isf_alloc() ! Allocate public array + ! + CALL isf_ctl() ! check option compatibility + ! + IF( ln_isfcav ) CALL isf_load( Kmm, risfload ) ! compute ice shelf load + ! + ! terminate routine now if no ice shelf melt formulation specify + IF( ln_isf ) THEN + ! + IF( ln_isfcav_mlt ) CALL isf_cav_init() ! initialisation melt in the cavity + ! + IF( ln_isfpar_mlt ) CALL isf_par_init() ! initialisation parametrised melt + ! + IF( ln_isfcpl ) CALL isfcpl_init( Kbb, Kmm, Kaa ) ! initialisation ice sheet coupling + ! + END IF + + END SUBROUTINE isf_init + + + SUBROUTINE isf_ctl() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_ctl *** + !! + !! ** Purpose : output print and option compatibility check + !! + !!---------------------------------------------------------------------- + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'isf_init : ice shelf initialisation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namisf :' + ! + WRITE(numout,*) ' ice shelf cavity (open or parametrised) ln_isf = ', ln_isf + WRITE(numout,*) + ! + IF ( ln_isf ) THEN + CALL ctl_stop( 'STOP', 'isf_ctl: ice shelf requires both ln_isf=T AND key_isf activated' ) + WRITE(numout,*) ' Add debug print in isf module ln_isfdebug = ', ln_isfdebug + WRITE(numout,*) + WRITE(numout,*) ' melt inside the cavity ln_isfcav_mlt = ', ln_isfcav_mlt + IF ( ln_isfcav_mlt) THEN + WRITE(numout,*) ' melt formulation cn_isfcav_mlt= ', TRIM(cn_isfcav_mlt) + WRITE(numout,*) ' thickness of the top boundary layer rn_htbl = ', rn_htbl + WRITE(numout,*) ' gamma formulation cn_gammablk = ', TRIM(cn_gammablk) + IF ( TRIM(cn_gammablk) .NE. 'spe' ) THEN + WRITE(numout,*) ' gammat coefficient rn_gammat0 = ', rn_gammat0 + WRITE(numout,*) ' gammas coefficient rn_gammas0 = ', rn_gammas0 + WRITE(numout,*) ' top background ke used (from namdrg_top) rn_ke0 = ', r_ke0_top + WRITE(numout,*) ' top drag coef. used (from namdrg_top) rn_Cd0 = ', r_Cdmin_top + END IF + END IF + WRITE(numout,*) '' + ! + WRITE(numout,*) ' ice shelf melt parametrisation ln_isfpar_mlt = ', ln_isfpar_mlt + IF ( ln_isfpar_mlt ) THEN + WRITE(numout,*) ' isf parametrisation formulation cn_isfpar_mlt = ', TRIM(cn_isfpar_mlt) + END IF + WRITE(numout,*) '' + ! + WRITE(numout,*) ' Coupling to an ice sheet model ln_isfcpl = ', ln_isfcpl + IF ( ln_isfcpl ) THEN + WRITE(numout,*) ' conservation activated ln_isfcpl_cons = ', ln_isfcpl_cons + WRITE(numout,*) ' number of call of the extrapolation loop = ', nn_drown + ENDIF + WRITE(numout,*) '' + ! + ELSE + ! + IF ( ln_isfcav ) THEN + WRITE(numout,*) '' + WRITE(numout,*) ' W A R N I N G: ice shelf cavities are open BUT no melt will be computed or read from file !' + WRITE(numout,*) '' + END IF + ! + END IF + + IF (ln_isfcav) THEN + WRITE(numout,*) ' Ice shelf load method cn_isfload = ', TRIM(cn_isfload) + WRITE(numout,*) ' Temperature used to compute the ice shelf load = ', rn_isfload_T + WRITE(numout,*) ' Salinity used to compute the ice shelf load = ', rn_isfload_S + END IF + WRITE(numout,*) '' + FLUSH(numout) + + END IF + ! + + !--------------------------------------------------------------------------------------------------------------------- + ! sanity check ! issue ln_isfcav not yet known as well as l_isfoasis => move this call in isf_stp ? + ! melt in the cavity without cavity + IF ( ln_isfcav_mlt .AND. (.NOT. ln_isfcav) ) & + & CALL ctl_stop('ice shelf melt in the cavity activated (ln_isfcav_mlt) but no cavity detected in domcfg (ln_isfcav), STOP' ) + ! + ! ice sheet coupling without cavity + IF ( ln_isfcpl .AND. (.NOT. ln_isfcav) ) & + & CALL ctl_stop('coupling with an ice sheet model detected (ln_isfcpl) but no cavity detected in domcfg (ln_isfcav), STOP' ) + ! + IF ( ln_isfcpl .AND. ln_isfcpl_cons .AND. ln_linssh ) & + & CALL ctl_stop( 'The coupling between NEMO and an ice sheet model with the conservation option does not work with the linssh option' ) + ! + IF ( l_isfoasis .AND. .NOT. ln_isf ) CALL ctl_stop( ' OASIS send ice shelf fluxes to NEMO but NEMO does not have the isf module activated' ) + ! + IF ( l_isfoasis .AND. ln_isf ) THEN + ! + ! NEMO coupled to ATMO model with isf cavity need oasis method for melt computation + IF ( ln_isfcav_mlt .AND. TRIM(cn_isfcav_mlt) /= 'oasis' ) CALL ctl_stop( 'cn_isfcav_mlt = oasis is the only option availble if fwf send by oasis' ) + IF ( ln_isfpar_mlt .AND. TRIM(cn_isfpar_mlt) /= 'oasis' ) CALL ctl_stop( 'cn_isfpar_mlt = oasis is the only option availble if fwf send by oasis' ) + ! + ! oasis melt computation with cavity open and cavity parametrised (not coded) + IF ( ln_isfcav_mlt .AND. ln_isfpar_mlt ) THEN + IF ( TRIM(cn_isfpar_mlt) == 'oasis' .AND. TRIM(cn_isfcav_mlt) == 'oasis' ) CALL ctl_stop( 'cn_isfpar_mlt = oasis and cn_isfcav_mlt = oasis not coded' ) + END IF + ! + ! compatibility ice shelf and vvl + IF( .NOT. ln_vvl_zstar .AND. ln_isf ) CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' ) + ! + END IF + END SUBROUTINE isf_ctl + + + SUBROUTINE isf_nam + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_nam *** + !! + !! ** Purpose : Read ice shelf namelist cfg and ref + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !!---------------------------------------------------------------------- + NAMELIST/namisf/ ln_isf , & + & cn_gammablk , rn_gammat0 , rn_gammas0 , rn_htbl, sn_isfcav_fwf, & + & ln_isfcav_mlt , cn_isfcav_mlt , sn_isfcav_fwf , & + & ln_isfpar_mlt , cn_isfpar_mlt , sn_isfpar_fwf , & + & sn_isfpar_zmin, sn_isfpar_zmax, sn_isfpar_Leff, & + & ln_isfcpl , nn_drown , ln_isfcpl_cons, ln_isfdebug, & + & cn_isfload , rn_isfload_T , rn_isfload_S , cn_isfdir , & + & rn_isfpar_bg03_gt0 + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namisf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namisf in reference namelist' ) + ! + READ ( numnam_cfg, namisf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namisf in configuration namelist' ) + IF(lwm) WRITE ( numond, namisf ) + + END SUBROUTINE isf_nam + !! + !!====================================================================== +END MODULE isfstp diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isftbl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isftbl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2c16c70fb73cca3325491e45aa0beca1e7356949 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isftbl.f90 @@ -0,0 +1,303 @@ + + + + + + + + + + + + + +MODULE isftbl + !!====================================================================== + !! *** MODULE isftbl *** + !! isftbl module : compute properties of top boundary layer + !!====================================================================== + !! History : 4.1 ! 2019-09 (P. Mathiot) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isftbl : routine to compute : + !! - geometry of the ice shelf tbl (isf_tbl_lvl, isftbl_ktop, isftbl_kbot) + !! (top and bottom level, thickness and fraction of deepest level affected) + !! - tbl averaged properties (isf_tbl, isf_tbl_avg) + !!---------------------------------------------------------------------- + + USE isf_oce ! ice shelf variables + + USE dom_oce ! vertical scale factor and depth + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_tbl, isf_tbl_avg, isf_tbl_lvl, isf_tbl_ktop, isf_tbl_kbot + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE isf_tbl( Kmm, pvarin, pvarout, cd_ptin, ktop, phtbl, kbot, pfrac ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE isf_tbl *** + !! + !! ** Purpose : compute mean T/S/U/V in the boundary layer at T- point + !! + !! ** Method : Average properties over a specific thickness + !! + !! ** Reference : inspired from : Losch, Modeling ice shelf cavities in a z coordinate ocean general circulation model + !! https://doi.org/10.1029/2007JC004368 , 2008 + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pvarout ! 2d average of pvarin + !!-------------------------- IN ------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + CHARACTER(len=1) , INTENT(in ) :: cd_ptin ! point of variable in/out + REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pvarin ! 3d variable to average over the tbl + INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl ! tbl thickness + !!-------------------------- IN OPTIONAL ----------------------------- + INTEGER, DIMENSION(jpi,jpj), OPTIONAL, INTENT(in ) :: kbot ! bottom level + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in ) :: pfrac ! fraction of bottom cell affected by tbl + !!-------------------------------------------------------------------- + INTEGER :: ji, jj ! loop index + INTEGER , DIMENSION(jpi,jpj) :: ikbot ! bottom level of the tbl + REAL(wp), DIMENSION(jpi,jpj) :: zvarout ! 2d average of pvarin + REAL(wp), DIMENSION(jpi,jpj) :: zhtbl ! thickness of the tbl + REAL(wp), DIMENSION(jpi,jpj) :: zfrac ! thickness of the tbl + INTEGER :: jk ! loop index + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t,ze3u,ze3v ! e3 + !!-------------------------------------------------------------------- + ! + SELECT CASE ( cd_ptin ) + CASE ( 'U' ) + ! + ! copy phtbl (phtbl is INTENT in as we don't want to change it) + zhtbl = phtbl + ! + DO jk = 1, jpk + ze3u(:,:,jk) = (e3u_0(:,:,jk)*(1._wp+r3u(:,:,Kmm)*umask(:,:,jk))) + END DO + ! compute tbl lvl and thickness + CALL isf_tbl_lvl( (hu_0(:,:)*(1._wp+r3u(:,:,Kmm))), ze3u, ktop, ikbot, zhtbl, zfrac ) + ! + ! compute tbl property at U point + CALL isf_tbl_avg( miku, ikbot, zhtbl, zfrac, ze3u, pvarin, zvarout ) + ! + ! compute tbl property at T point + pvarout(1,:) = 0._wp + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls) + pvarout(ji,jj) = 0.5_wp * (zvarout(ji,jj) + zvarout(ji-1,jj)) + END DO ; END DO + ! lbclnk not needed as a final communication is done after the computation of fwf + ! + CASE ( 'V' ) + ! + ! copy phtbl (phtbl is INTENT in as we don't want to change it) + zhtbl = phtbl + ! + DO jk = 1, jpk + ze3v(:,:,jk) = (e3v_0(:,:,jk)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,jk))) + END DO + ! compute tbl lvl and thickness + CALL isf_tbl_lvl( (hv_0(:,:)*(1._wp+r3v(:,:,Kmm))), ze3v, ktop, ikbot, zhtbl, zfrac ) + ! + ! compute tbl property at V point + CALL isf_tbl_avg( mikv, ikbot, zhtbl, zfrac, ze3v, pvarin, zvarout ) + ! + ! pvarout is an averaging of wet point + pvarout(:,1) = 0._wp + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + pvarout(ji,jj) = 0.5_wp * (zvarout(ji,jj) + zvarout(ji,jj-1)) + END DO ; END DO + ! lbclnk not needed as a final communication is done after the computation of fwf + ! + CASE ( 'T' ) + ! + ! compute tbl property at T point + DO jk = 1, jpk + ze3t(:,:,jk) = (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + END DO + CALL isf_tbl_avg( ktop, kbot, phtbl, pfrac, ze3t, pvarin, pvarout ) + ! + END SELECT + ! + END SUBROUTINE isf_tbl + + SUBROUTINE isf_tbl_avg( ktop, kbot, phtbl, pfrac, pe3, pvarin, pvarout ) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_tbl_avg *** + !! + !! ** Purpose : compute mean property in the boundary layer + !! + !! ** Method : Depth average is made between the top level ktop and the bottom level kbot + !! over a thickness phtbl. The bottom level is partially counted (pfrac). + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pvarout ! tbl property averaged over phtbl between level ktop and kbot + !!-------------------------- IN ------------------------------------- + INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop, kbot ! top and bottom level of the top boundary layer + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl, pfrac ! fraction of bottom level to be affected by the tbl + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pvarin ! tbl property to average between ktop, kbot over phtbl + !!-------------------------------------------------------------------- + INTEGER :: ji,jj,jk ! loop indices + INTEGER :: ikt, ikb ! top and bottom levels + !!-------------------------------------------------------------------- + ! + ! compute tbl top.bottom level and thickness + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + ! tbl top/bottom indices initialisation + ikt = ktop(ji,jj) ; ikb = kbot(ji,jj) + ! + ! level fully include in the ice shelf boundary layer + pvarout(ji,jj) = SUM( pvarin(ji,jj,ikt:ikb-1) * pe3(ji,jj,ikt:ikb-1) ) / phtbl(ji,jj) + ! + ! level partially include in ice shelf boundary layer + pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,ikb) * pe3(ji,jj,ikb) / phtbl(ji,jj) * pfrac(ji,jj) + ! + END DO ; END DO + + END SUBROUTINE isf_tbl_avg + + SUBROUTINE isf_tbl_lvl( phw, pe3, ktop, kbot, phtbl, pfrac ) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_tbl_lvl *** + !! + !! ** Purpose : - compute bottom level off the top boundary layer + !! - thickness of the top boundary layer + !! - fraction of the bottom level affected by the tbl + !! + !!-------------------------- OUT -------------------------------------- + INTEGER, DIMENSION(jpi,jpj) , INTENT( out) :: kbot ! bottom level of the top boundary layer + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pfrac ! fraction of bottom level in the tbl + !!-------------------------- IN -------------------------------------- + INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level of the top boundary layer + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phw ! water column thickness + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor + !!-------------------------- INOUT ------------------------------------ + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: phtbl ! top boundary layer thickness + !!--------------------------------------------------------------------- + INTEGER :: ji,jj,jk + INTEGER :: ikt, ikb + !!--------------------------------------------------------------------- + ! + ! get htbl + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + ! tbl top/bottom indices initialisation + ikt = ktop(ji,jj) + ! + ! limit the tbl to water thickness. + phtbl(ji,jj) = MIN( phtbl(ji,jj), phw(ji,jj) ) + ! + ! thickness of boundary layer must be at least the top level thickness + phtbl(ji,jj) = MAX( phtbl(ji,jj), pe3(ji,jj,ikt) ) + ! + END DO ; END DO + ! + ! get ktbl + CALL isf_tbl_kbot(ktop, phtbl, pe3, kbot) + ! + ! get pfrac + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + ! tbl top/bottom indices initialisation + ikt = ktop(ji,jj) ; ikb = kbot(ji,jj) + ! + ! proportion of the bottom cell included in ice shelf boundary layer + pfrac(ji,jj) = ( phtbl(ji,jj) - SUM( pe3(ji,jj,ikt:ikb-1) ) ) / pe3(ji,jj,ikb) + ! + END DO ; END DO + ! + END SUBROUTINE isf_tbl_lvl + ! + SUBROUTINE isf_tbl_kbot(ktop, phtbl, pe3, kbot) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_tbl_bot *** + !! + !! ** Purpose : compute bottom level of the isf top boundary layer + !! + !!-------------------------- OUT ------------------------------------- + INTEGER, DIMENSION(jpi,jpj) , INTENT( out) :: kbot ! bottom level of the top boundary layer + !!-------------------------- IN ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl ! top boundary layer thickness + INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level of the top boundary layer + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor + !!-------------------------------------------------------------------- + INTEGER :: ji, jj + INTEGER :: ikt, ikb + !!-------------------------------------------------------------------- + ! + ! phtbl need to be bounded by water column thickness before + ! test: if htbl = water column thickness, should return mbathy + ! test: if htbl = 0 should return ktop (phtbl cap to pe3t(ji,jj,1)) + ! + ! get ktbl + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + ! determine the deepest level influenced by the boundary layer + ikt = ktop(ji,jj) + ikb = ikt + DO WHILE ( SUM(pe3(ji,jj,ikt:ikb-1)) < phtbl(ji,jj ) ) ; ikb = ikb + 1 ; END DO + kbot(ji,jj) = ikb - 1 + ! + END DO ; END DO + ! + END SUBROUTINE isf_tbl_kbot + ! + SUBROUTINE isf_tbl_ktop(pdep, ktop) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_tbl_top *** + !! + !! ** Purpose : compute top level of the isf top boundary layer in case of an ice shelf parametrisation + !! + !!-------------------------- OUT ------------------------------------- + INTEGER, DIMENSION(jpi,jpj), INTENT( out) :: ktop ! top level affected by the ice shelf parametrisation + !!-------------------------- IN ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pdep ! top depth of the parametrisation influence + !!-------------------------------------------------------------------- + INTEGER :: ji,jj + INTEGER :: ikt + !!-------------------------------------------------------------------- + ! + ! if we need to recompute the top level at every time stepcompute top level (z*, z~) + ! in case of weak ht variation we can assume the top level of htbl to be constant + ! => only done using gdepw_0 + ! be sure pdep is already correctly bounded + ! test: this routine run on isfdraft should return mikt + ! test: this routine run with pdep = 0 should return 1 + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! comput ktop + ikt = 2 + DO WHILE ( gdepw_0(ji,jj,ikt) <= pdep(ji,jj ) ) ; ikt = ikt + 1 ; END DO + ktop(ji,jj) = ikt - 1 + ! + ! update pdep + pdep(ji,jj) = gdepw_0(ji,jj,ktop(ji,jj)) + END DO ; END DO + ! + END SUBROUTINE isf_tbl_ktop + +END MODULE isftbl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfutils.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfutils.f90 new file mode 100644 index 0000000000000000000000000000000000000000..69af98c840a4da123eac8e461391b0b72032c113 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/isfutils.f90 @@ -0,0 +1,176 @@ + + + + + + + + + + + + + +MODULE isfutils + !!====================================================================== + !! *** MODULE isfutils *** + !! istutils module : miscelenious useful routines + !!====================================================================== + !! History : 4.1 ! 2019-09 (P. Mathiot) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfutils : - read_2dcstdta to read a constant input file with iom_get + !! - debug to print array sum, min, max in ocean.output + !!---------------------------------------------------------------------- + USE par_kind + USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_global ! read input file + USE lib_fortran , ONLY: glob_sum, glob_min, glob_max ! compute global value + USE par_oce , ONLY: jpi,jpj,jpk, jpnij, Nis0, Nie0, Njs0, Nje0 ! domain size + USE dom_oce , ONLY: narea ! local domain + USE in_out_manager, ONLY: lwp, numout ! miscelenious + USE lib_mpp + + IMPLICIT NONE + + PRIVATE + + INTERFACE debug + MODULE PROCEDURE debug2d, debug3d + END INTERFACE debug + + PUBLIC read_2dcstdta, debug + + +CONTAINS + + SUBROUTINE read_2dcstdta(cdfile, cdvar, pvar) + !!-------------------------------------------------------------------- + !! *** ROUTINE read_2dcstdta *** + !! + !! ** Purpose : read input file + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pvar ! output variable + !!-------------------------- IN ------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdfile ! input file name + CHARACTER(len=*) , INTENT(in ) :: cdvar ! variable name + !!-------------------------------------------------------------------- + INTEGER :: inum + !!-------------------------------------------------------------------- + + CALL iom_open( TRIM(cdfile), inum ) + CALL iom_get( inum, jpdom_global, TRIM(cdvar), pvar) + CALL iom_close(inum) + + END SUBROUTINE read_2dcstdta + + SUBROUTINE debug2d(cdtxt,pvar) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_debug2d *** + !! + !! ** Purpose : add debug print for 2d variables + !! + !!-------------------------- IN ------------------------------------- + CHARACTER(LEN=*) , INTENT(in ) :: cdtxt + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pvar + !!-------------------------------------------------------------------- + REAL(wp) :: zmin, zmax, zsum + INTEGER(i8) :: imodd, ip + INTEGER :: imods + INTEGER :: isums, idums + INTEGER :: ji,jj,jk + INTEGER, DIMENSION(jpnij) :: itmps + !!-------------------------------------------------------------------- + ! + ! global min/max/sum to check data range and NaN + zsum =glob_sum( 'debug', REAL(pvar(:,:),dp) ) + zmin = glob_min( 'debug',REAL(pvar(:,:),dp) ) + zmax = glob_max( 'debug', REAL(pvar(:,:),dp) ) + ! + ! basic check sum to check reproducibility + ! TRANSFER function find out the integer corresponding to pvar(i,j) bit pattern + ! MOD allow us to keep only the latest digits during the sum + ! imod is not choosen to be very large as at the end there is a classic mpp_sum + imodd=65521 ! highest prime number < 2**16 with i8 type + imods=65521 ! highest prime number < 2**16 with default integer for mpp_sum subroutine + isums=0 ; itmps(:)=0 ; + ! + ! local MOD sum + DO jj=Njs0,Nje0 + DO ji=Nis0,Nie0 + idums = ABS(MOD(TRANSFER(pvar(ji,jj), ip),imodd)) + itmps(narea) = MOD(itmps(narea) + idums, imods) + END DO + END DO + ! + ! global MOD sum + CALL mpp_max('debug',itmps(:)) + DO jk = 1,jpnij + isums = MOD(isums + itmps(jk),imods) + END DO + ! + ! print out + IF (lwp) THEN + WRITE(numout,*) TRIM(cdtxt),' (min, max, sum, tag) : ',zmin, zmax, zsum, isums + CALL FLUSH(numout) + END IF + ! + END SUBROUTINE debug2d + + SUBROUTINE debug3d(cdtxt,pvar) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_debug3d *** + !! + !! ** Purpose : add debug print for 3d variables + !! + !!-------------------------- IN ------------------------------------- + CHARACTER(LEN=*) , INTENT(in ) :: cdtxt + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pvar + !!-------------------------------------------------------------------- + REAL(wp) :: zmin, zmax, zsum + INTEGER(i8) :: imodd, ip + INTEGER :: imods + INTEGER :: isums, idums + INTEGER :: ji,jj,jk + INTEGER, DIMENSION(jpnij) :: itmps + !!-------------------------------------------------------------------- + ! + ! global min/max/sum to check data range and NaN + zsum = glob_sum( 'debug', pvar(:,:,:) ) + zmin = glob_min( 'debug', pvar(:,:,:) ) + zmax = glob_max( 'debug', pvar(:,:,:) ) + ! + ! basic check sum to check reproducibility + ! TRANSFER function find out the integer corresponding to pvar(i,j) bit pattern + ! MOD allow us to keep only the latest digits during the sum + ! imod is not choosen to be very large as at the end there is a classic mpp_sum + imodd=65521 ! highest prime number < 2**16 with i8 type + imods=65521 ! highest prime number < 2**16 with default integer for mpp_sum subroutine + itmps=0; isums=0 + ! + ! local MOD sum + DO jk=1,jpk + DO jj=Njs0,Nje0 + DO ji=Nis0,Nie0 + idums = ABS(MOD(TRANSFER(pvar(ji,jj,jk), ip),imodd)) + itmps(narea) = MOD(itmps(narea) + idums, imods) + END DO + END DO + END DO + ! + ! global MOD sum + CALL mpp_max('debug',itmps) + DO jk = 1,jpnij + isums = MOD(isums+itmps(jk),imods) + END DO + ! + ! print out + IF (lwp) THEN + WRITE(numout,*) TRIM(cdtxt),' (min, max, sum, tag) : ',zmin, zmax, zsum, isums + CALL FLUSH(numout) + END IF + ! + END SUBROUTINE debug3d + +END MODULE isfutils diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/istate.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/istate.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dc7205347e1b5ec511e4acc8406259864f3ae4f2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/istate.f90 @@ -0,0 +1,176 @@ + + + + + + + + + + + + + +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 + + + IMPLICIT NONE + PRIVATE + + PUBLIC istate_init ! routine called by nemogcm.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: istate.F90 15052 2021-06-24 14:39:14Z smasson $ + !! 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( 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) + ! + 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_0(:,:,jk)*(1._wp+r3t(:,:,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._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 + ! + ! Initialize "now" and "before" barotropic velocities: + ! Do it whatever the free surface method, these arrays being eventually used + ! + 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 jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + uu_b(ji,jj,Kmm) = uu_b(ji,jj,Kmm) + (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * uu(ji,jj,jk,Kmm) * umask(ji,jj,jk) + vv_b(ji,jj,Kmm) = vv_b(ji,jj,Kmm) + (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * vv(ji,jj,jk,Kmm) * vmask(ji,jj,jk) + ! + uu_b(ji,jj,Kbb) = uu_b(ji,jj,Kbb) + (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kbb)*umask(ji,jj,jk))) * uu(ji,jj,jk,Kbb) * umask(ji,jj,jk) + vv_b(ji,jj,Kbb) = vv_b(ji,jj,Kbb) + (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kbb)*vmask(ji,jj,jk))) * vv(ji,jj,jk,Kbb) * vmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm))) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm))) + ! + uu_b(:,:,Kbb) = uu_b(:,:,Kbb) * (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kbb))) + vv_b(:,:,Kbb) = vv_b(:,:,Kbb) * (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kbb))) + ! + END SUBROUTINE istate_init + + !!====================================================================== +END MODULE istate diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/julian.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/julian.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0533aadf59167755a967f5c63d0c06c5b9cbbd2c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/julian.f90 @@ -0,0 +1,248 @@ + + + + + + + + + + + + + +MODULE julian + !!====================================================================== + !! *** MODULE julian *** + !! Ocean : Julian data utilities + !!===================================================================== + + !!---------------------------------------------------------------------- + !! jul2greg : Convert relative time to date + !! greg2jul : Convert date to relative time + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp, & + & dp + !USE in_out_manager ! I/O manager + USE lib_mpp, ONLY : & + & ctl_warn, ctl_stop + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + PUBLIC jul2greg, & ! Convert relative time to date + & greg2jul ! Convert date to relative time + + !! $Id: julian.F90 5215 2015-04-15 16:11:56Z nicolasmartin $ +CONTAINS + +RECURSIVE SUBROUTINE jul2greg( ksec, kminut, khour, kday, kmonth, kyear, & + & prelday, krefdate ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE jul2greg *** + !! + !! ** Purpose : Take the relative time in days and re-express in terms of + !! seconds, minutes, hours, days, month, year. + !! + !! ** Method : Reference date : 19500101 + !! + !! ** Action : + !! + !! History + !! ! 06-04 (A. Vidard) Original + !! ! 06-05 (A. Vidard) Reformatted and refdate + !! ! 06-10 (A. Weaver) Cleanup + !! ! 2014-09 (D. Lea) Change to use FLOOR to deal with negative prelday + !!----------------------------------------------------------------------- + + ! * Arguments + INTEGER, INTENT(IN), OPTIONAL :: & + & krefdate + INTEGER, INTENT(OUT) :: & + & ksec, & + & kminut, & + & khour, & + & kday, & + & kmonth, & + & kyear + REAL(KIND=dp), INTENT(IN) :: & + & prelday + + !! * Local declarations + INTEGER, PARAMETER :: & + & jpgreg = 2299161, & + & jporef = 2433283, & + & jparef = 2415021 + INTEGER :: & + & ijulian, & + & ij1, & + & ija, & + & ijb, & + & ijc, & + & ijd, & + & ije, & + & isec, & + & imin, & + & ihou, & + & iday, & + & imon, & + & iyea, & + & iref + REAL(KIND=wp) :: & + & zday, & + & zref + CHARACTER(len=200) :: & + & cerr + + ! Main computation + IF ( PRESENT( krefdate ) ) THEN + + SELECT CASE ( krefdate ) + + CASE( 0 ) + iref = jpgreg + + CASE( 19500101 ) + iref = jporef + + CASE( 19000101 ) + iref = jparef + + CASE DEFAULT + WRITE(cerr,'(A,I8.8)')'jul2greg: Unknown krefdate:', krefdate + CALL ctl_stop( cerr ) + + END SELECT + + ELSE + iref = jporef + ENDIF + + zday = prelday + ksec = FLOOR( 86400. * MOD( zday, 1. ) ) + + IF ( ksec < 0. ) ksec = 86400. + ksec + + khour = ksec / 3600 + kminut = ( ksec - 3600 * khour ) / 60 + ksec = MOD( ksec , 60 ) + + ijulian = iref + INT( zday ) + IF ( zday < 0. ) ijulian = ijulian - 1 + + ! If input date after 10/15/1582 : + IF ( ijulian >= jpgreg ) THEN + ij1 = INT( ( DBLE( ijulian - 1867216 ) - 0.25 ) / 36524.25 ) + ija = ijulian + 1 + ij1 - INT( ( 0.25 * ij1 ) ) + ELSE + ija = ijulian + ENDIF + + ijb = ija + 1524 + ijc = INT( 6680. + ( DBLE ( ijb - 2439870 ) - 122.1 ) / 365.25 ) + ijd = 365 * ijc + INT( 0.25 * ijc ) + ije = INT( ( ijb - ijd ) / 30.6001 ) + kday = ijb - ijd - INT( 30.6001 * ije ) + kmonth = ije - 1 + IF ( kmonth > 12 ) kmonth = kmonth - 12 + kyear = ijc - 4715 + IF ( kmonth > 2 ) kyear = kyear - 1 + IF ( kyear <= 0 ) kyear = kyear - 1 + + END SUBROUTINE jul2greg + +SUBROUTINE greg2jul( ksec, kmin, khour, kday, kmonth, kyear, pjulian, & + & krefdate ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE greg2jul *** + !! + !! ** Purpose : Produce the time relative to the current date and time. + !! + !! ** Method : The units are days, so hours and minutes transform to + !! fractions of a day. + !! + !! Reference date : 19500101 + !! ** Action : + !! + !! History : + !! ! 06-04 (A. Vidard) Original + !! ! 06-04 (A. Vidard) Reformatted + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + ! * Arguments + INTEGER, INTENT(IN) :: & + & ksec, & + & kmin, & + & khour, & + & kday, & + & kmonth, & + & kyear + REAL(KIND=dp), INTENT(OUT) :: & + & pjulian + INTEGER, INTENT(IN), OPTIONAL :: & + & krefdate + + !! * Local declarations + INTEGER, PARAMETER :: & + & jpgreg = 15 + 31 * ( 10 + 12 * 1582 ), & ! Gregorian calendar introduction date + & jporef = 2433283, & ! Julian reference date: 19500101 + & jparef = 2415021, & ! Julian reference date: 19000101 + & jpgref = 2299161 ! Julian reference date start of Gregorian calender + INTEGER :: & + & ija, & + & ijy, & + & ijm, & + & ijultmp, & + & ijyear, & + & iref + CHARACTER(len=200) :: & + & cerr + + IF ( PRESENT( krefdate ) ) THEN + SELECT CASE ( krefdate ) + + CASE( 0 ) + iref = jpgref + + CASE( 19500101 ) + iref = jporef + + CASE( 19000101 ) + iref = jparef + + CASE DEFAULT + WRITE(cerr,'(A,I8.8)')'greg2jul: Unknown krefdate:', krefdate + CALL ctl_stop( cerr ) + + END SELECT + + ELSE + iref = jporef + ENDIF + + ! Main computation + ijyear = kyear + IF ( ijyear < 0 ) ijyear = ijyear + 1 + IF ( kmonth > 2 ) THEN + ijy = ijyear + ijm = kmonth + 1 + ELSE + ijy = ijyear - 1 + ijm = kmonth + 13 + ENDIF + ijultmp = INT( 365.25 * ijy ) + INT( 30.6001 * ijm ) + kday + 1720995 + IF ( kday + 31 * ( kmonth + 12 * ijyear ) >= jpgreg ) THEN + ija = INT( 0.01 * ijy ) + ijultmp = ijultmp + 2 - ija + INT( 0.25 * ija ) + ENDIF + pjulian = ( ijultmp - iref ) + ( ( 60 * khour + kmin ) * 60 + ksec ) / 86400. + + END SUBROUTINE greg2jul + +END MODULE julian diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lbclnk.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lbclnk.f90 new file mode 100644 index 0000000000000000000000000000000000000000..411813fead95861f1fc98c2d25807b61699af83a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lbclnk.f90 @@ -0,0 +1,2576 @@ + + + + + + + + + + + + + +MODULE lbclnk + !!====================================================================== + !! *** MODULE lbclnk *** + !! NEMO : lateral boundary conditions + !!===================================================================== + !! History : OPA ! 1997-06 (G. Madec) Original code + !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module + !! 3.2 ! 2009-03 (R. Benshila) External north fold treatment + !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk + !! 3.4 ! 2012-12 (R. Bourdalle-Badie, G. Reffray) add a C1D case + !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi + !! 4.0 ! 2017-03 (G. Madec) automatique allocation of array size (use with any 3rd dim size) + !! - ! 2017-04 (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather) + !! - ! 2017-05 (G. Madec) create generic.h90 files to generate all lbc and north fold routines + !!---------------------------------------------------------------------- + !! define the generic interfaces of lib_mpp routines + !!---------------------------------------------------------------------- + !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp + !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE lib_mpp ! distributed memory computing library + USE lbcnfd ! north fold + USE in_out_manager ! I/O manager + USE MPI + + IMPLICIT NONE + PRIVATE + + INTERFACE lbc_lnk + MODULE PROCEDURE lbc_lnk_call_2d_sp, lbc_lnk_call_3d_sp, lbc_lnk_call_4d_sp + MODULE PROCEDURE lbc_lnk_call_2d_dp, lbc_lnk_call_3d_dp, lbc_lnk_call_4d_dp + END INTERFACE + + INTERFACE lbc_lnk_pt2pt + MODULE PROCEDURE lbc_lnk_pt2pt_sp, lbc_lnk_pt2pt_dp + END INTERFACE + + INTERFACE lbc_lnk_neicoll + MODULE PROCEDURE lbc_lnk_neicoll_sp ,lbc_lnk_neicoll_dp + END INTERFACE + ! + INTERFACE lbc_lnk_icb + MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp + END INTERFACE + + PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions + PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions + + REAL(dp), DIMENSION(:), ALLOCATABLE :: buffsnd_dp, buffrcv_dp ! MPI send/recv buffers + REAL(sp), DIMENSION(:), ALLOCATABLE :: buffsnd_sp, buffrcv_sp ! + INTEGER, DIMENSION(8) :: nreq_p2p ! request id for MPI_Isend in point-2-point communication + + !! * Substitutions + !!# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lbclnk.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + !!---------------------------------------------------------------------- + !! *** lbc_lnk_call_[234]d_[sd]p *** + !! + !! * Dummy Argument : + !! in ==> cdname ! name of the calling subroutine (for monitoring) + !! ptab ! array to be loaded (2D, 3D or 4D) + !! cd_nat ! nature of pt2d array grid-points + !! psgn ! sign used across the north fold boundary + !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers + !! cdna_ptr ! nature of ptab array grid-points + !! psgn_ptr ! sign used across the north fold boundary + !! kfld ! number of elements that has been attributed + !!---------------------------------------------------------------------- + ! + !!---------------------------------------------------------------------- + !! + !! *** lbc_lnk_call_[234]d_[sd]p *** + !! *** load_ptr_[234]d_[sd]p *** + !! + !!---------------------------------------------------------------------- + !! + !! ---- SINGLE PRECISION VERSIONS + !! + + SUBROUTINE lbc_lnk_call_2d_sp( & + & cdname & + & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & + & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & + & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & + & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & + & , pt17, cdna17, psgn17, pt18, cdna18, psgn18, pt19, cdna19, psgn19, pt20, cdna20, psgn20 & + & , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24 & + & , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28 & + & , pt29, cdna29, psgn29, pt30, cdna30, psgn30 & + & , kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + !!--------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(sp), DIMENSION(:,:) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied + REAL(sp), DIMENSION(:,:), OPTIONAL, TARGET, CONTIGUOUS, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , & + & pt9 , pt10, pt11, pt12, pt13, pt14, pt15, & + & pt16, pt17, pt18, pt19, pt20, pt21, pt22, & + & pt23, pt24, pt25, pt26, pt27, pt28, pt29, & + & pt30 + CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points + CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , & + & cdna9 , cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, & + & cdna16, cdna17, cdna18, cdna19, cdna20, cdna21, cdna22, & + & cdna23, cdna24, cdna25, cdna26, cdna27, cdna28, cdna29, & + & cdna30 + REAL(sp) , INTENT(in ) :: psgn1 ! sign used across the north fold + REAL(sp) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , & + & psgn9 , psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, & + & psgn16, psgn17, psgn18, psgn19, psgn20, psgn21, psgn22, & + & psgn23, psgn24, psgn25, psgn26, psgn27, psgn28, psgn29, & + & psgn30 + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(sp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL , INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out + LOGICAL , OPTIONAL , INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + !! + INTEGER :: kfld ! number of elements that will be attributed + TYPE(PTR_4d_sp), DIMENSION(30) :: ptab_ptr ! pointer array + CHARACTER(len=1) , DIMENSION(30) :: cdna_ptr ! nature of ptab_ptr grid-points + REAL(sp) , DIMENSION(30) :: psgn_ptr ! sign used across the north fold boundary + !!--------------------------------------------------------------------- + ! + kfld = 0 ! initial array of pointer size + ! + ! ! Load the first array + CALL load_ptr_2d_sp( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + ! ! Look if more arrays are added + IF( PRESENT(psgn2 ) ) CALL load_ptr_2d_sp( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn3 ) ) CALL load_ptr_2d_sp( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn4 ) ) CALL load_ptr_2d_sp( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn5 ) ) CALL load_ptr_2d_sp( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn6 ) ) CALL load_ptr_2d_sp( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn7 ) ) CALL load_ptr_2d_sp( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn8 ) ) CALL load_ptr_2d_sp( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn9 ) ) CALL load_ptr_2d_sp( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn10) ) CALL load_ptr_2d_sp( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn11) ) CALL load_ptr_2d_sp( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn12) ) CALL load_ptr_2d_sp( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn13) ) CALL load_ptr_2d_sp( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn14) ) CALL load_ptr_2d_sp( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn15) ) CALL load_ptr_2d_sp( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn16) ) CALL load_ptr_2d_sp( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn17) ) CALL load_ptr_2d_sp( pt17, cdna17, psgn17, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn18) ) CALL load_ptr_2d_sp( pt18, cdna18, psgn18, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn19) ) CALL load_ptr_2d_sp( pt19, cdna19, psgn19, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn20) ) CALL load_ptr_2d_sp( pt20, cdna20, psgn20, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn21) ) CALL load_ptr_2d_sp( pt21, cdna21, psgn21, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn22) ) CALL load_ptr_2d_sp( pt22, cdna22, psgn22, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn23) ) CALL load_ptr_2d_sp( pt23, cdna23, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn24) ) CALL load_ptr_2d_sp( pt24, cdna24, psgn24, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn25) ) CALL load_ptr_2d_sp( pt25, cdna25, psgn25, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn26) ) CALL load_ptr_2d_sp( pt26, cdna26, psgn26, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn27) ) CALL load_ptr_2d_sp( pt27, cdna27, psgn27, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn28) ) CALL load_ptr_2d_sp( pt28, cdna28, psgn28, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn29) ) CALL load_ptr_2d_sp( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn30) ) CALL load_ptr_2d_sp( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + IF( nn_comm == 1 ) THEN + CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ELSE + CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ENDIF + ! + END SUBROUTINE lbc_lnk_call_2d_sp + + + SUBROUTINE load_ptr_2d_sp( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + !!--------------------------------------------------------------------- + REAL(sp), DIMENSION(:,:), TARGET, INTENT(inout), CONTIGUOUS :: ptab ! arrays on which the lbc is applied + CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points + REAL(sp) , INTENT(in ) :: psgn ! sign used across the north fold boundary + TYPE(PTR_4d_sp), DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers + CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points + REAL(sp) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary + INTEGER , INTENT(inout) :: kfld ! number of elements that has been attributed + !!--------------------------------------------------------------------- + ! + kfld = kfld + 1 + ptab_ptr(kfld)%pt4d(1:SIZE(ptab, dim=1),1:SIZE(ptab, dim=2),1:1,1:1) => ptab + cdna_ptr(kfld) = cdna + psgn_ptr(kfld) = psgn + ! + END SUBROUTINE load_ptr_2d_sp + + + SUBROUTINE lbc_lnk_call_3d_sp( & + & cdname & + & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & + & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & + & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & + & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & + & , pt17, cdna17, psgn17, pt18, cdna18, psgn18, pt19, cdna19, psgn19, pt20, cdna20, psgn20 & + & , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24 & + & , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28 & + & , pt29, cdna29, psgn29, pt30, cdna30, psgn30 & + & , kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + !!--------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(sp), DIMENSION(:,:,:) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied + REAL(sp), DIMENSION(:,:,:), OPTIONAL, TARGET, CONTIGUOUS, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , & + & pt9 , pt10, pt11, pt12, pt13, pt14, pt15, & + & pt16, pt17, pt18, pt19, pt20, pt21, pt22, & + & pt23, pt24, pt25, pt26, pt27, pt28, pt29, & + & pt30 + CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points + CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , & + & cdna9 , cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, & + & cdna16, cdna17, cdna18, cdna19, cdna20, cdna21, cdna22, & + & cdna23, cdna24, cdna25, cdna26, cdna27, cdna28, cdna29, & + & cdna30 + REAL(sp) , INTENT(in ) :: psgn1 ! sign used across the north fold + REAL(sp) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , & + & psgn9 , psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, & + & psgn16, psgn17, psgn18, psgn19, psgn20, psgn21, psgn22, & + & psgn23, psgn24, psgn25, psgn26, psgn27, psgn28, psgn29, & + & psgn30 + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(sp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL , INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out + LOGICAL , OPTIONAL , INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + !! + INTEGER :: kfld ! number of elements that will be attributed + TYPE(PTR_4d_sp), DIMENSION(30) :: ptab_ptr ! pointer array + CHARACTER(len=1) , DIMENSION(30) :: cdna_ptr ! nature of ptab_ptr grid-points + REAL(sp) , DIMENSION(30) :: psgn_ptr ! sign used across the north fold boundary + !!--------------------------------------------------------------------- + ! + kfld = 0 ! initial array of pointer size + ! + ! ! Load the first array + CALL load_ptr_3d_sp( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + ! ! Look if more arrays are added + IF( PRESENT(psgn2 ) ) CALL load_ptr_3d_sp( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn3 ) ) CALL load_ptr_3d_sp( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn4 ) ) CALL load_ptr_3d_sp( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn5 ) ) CALL load_ptr_3d_sp( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn6 ) ) CALL load_ptr_3d_sp( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn7 ) ) CALL load_ptr_3d_sp( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn8 ) ) CALL load_ptr_3d_sp( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn9 ) ) CALL load_ptr_3d_sp( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn10) ) CALL load_ptr_3d_sp( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn11) ) CALL load_ptr_3d_sp( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn12) ) CALL load_ptr_3d_sp( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn13) ) CALL load_ptr_3d_sp( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn14) ) CALL load_ptr_3d_sp( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn15) ) CALL load_ptr_3d_sp( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn16) ) CALL load_ptr_3d_sp( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn17) ) CALL load_ptr_3d_sp( pt17, cdna17, psgn17, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn18) ) CALL load_ptr_3d_sp( pt18, cdna18, psgn18, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn19) ) CALL load_ptr_3d_sp( pt19, cdna19, psgn19, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn20) ) CALL load_ptr_3d_sp( pt20, cdna20, psgn20, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn21) ) CALL load_ptr_3d_sp( pt21, cdna21, psgn21, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn22) ) CALL load_ptr_3d_sp( pt22, cdna22, psgn22, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn23) ) CALL load_ptr_3d_sp( pt23, cdna23, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn24) ) CALL load_ptr_3d_sp( pt24, cdna24, psgn24, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn25) ) CALL load_ptr_3d_sp( pt25, cdna25, psgn25, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn26) ) CALL load_ptr_3d_sp( pt26, cdna26, psgn26, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn27) ) CALL load_ptr_3d_sp( pt27, cdna27, psgn27, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn28) ) CALL load_ptr_3d_sp( pt28, cdna28, psgn28, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn29) ) CALL load_ptr_3d_sp( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn30) ) CALL load_ptr_3d_sp( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + IF( nn_comm == 1 ) THEN + CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ELSE + CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ENDIF + ! + END SUBROUTINE lbc_lnk_call_3d_sp + + + SUBROUTINE load_ptr_3d_sp( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + !!--------------------------------------------------------------------- + REAL(sp), DIMENSION(:,:,:), TARGET, INTENT(inout), CONTIGUOUS :: ptab ! arrays on which the lbc is applied + CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points + REAL(sp) , INTENT(in ) :: psgn ! sign used across the north fold boundary + TYPE(PTR_4d_sp), DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers + CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points + REAL(sp) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary + INTEGER , INTENT(inout) :: kfld ! number of elements that has been attributed + !!--------------------------------------------------------------------- + ! + kfld = kfld + 1 + ptab_ptr(kfld)%pt4d(1:SIZE(ptab, dim=1),1:SIZE(ptab, dim=2),1:SIZE(ptab, dim=3),1:1) => ptab + cdna_ptr(kfld) = cdna + psgn_ptr(kfld) = psgn + ! + END SUBROUTINE load_ptr_3d_sp + + + SUBROUTINE lbc_lnk_call_4d_sp( & + & cdname & + & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & + & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & + & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & + & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & + & , pt17, cdna17, psgn17, pt18, cdna18, psgn18, pt19, cdna19, psgn19, pt20, cdna20, psgn20 & + & , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24 & + & , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28 & + & , pt29, cdna29, psgn29, pt30, cdna30, psgn30 & + & , kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + !!--------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(sp), DIMENSION(:,:,:,:) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied + REAL(sp), DIMENSION(:,:,:,:), OPTIONAL, TARGET, CONTIGUOUS, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , & + & pt9 , pt10, pt11, pt12, pt13, pt14, pt15, & + & pt16, pt17, pt18, pt19, pt20, pt21, pt22, & + & pt23, pt24, pt25, pt26, pt27, pt28, pt29, & + & pt30 + CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points + CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , & + & cdna9 , cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, & + & cdna16, cdna17, cdna18, cdna19, cdna20, cdna21, cdna22, & + & cdna23, cdna24, cdna25, cdna26, cdna27, cdna28, cdna29, & + & cdna30 + REAL(sp) , INTENT(in ) :: psgn1 ! sign used across the north fold + REAL(sp) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , & + & psgn9 , psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, & + & psgn16, psgn17, psgn18, psgn19, psgn20, psgn21, psgn22, & + & psgn23, psgn24, psgn25, psgn26, psgn27, psgn28, psgn29, & + & psgn30 + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(sp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL , INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out + LOGICAL , OPTIONAL , INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + !! + INTEGER :: kfld ! number of elements that will be attributed + TYPE(PTR_4d_sp), DIMENSION(30) :: ptab_ptr ! pointer array + CHARACTER(len=1) , DIMENSION(30) :: cdna_ptr ! nature of ptab_ptr grid-points + REAL(sp) , DIMENSION(30) :: psgn_ptr ! sign used across the north fold boundary + !!--------------------------------------------------------------------- + ! + kfld = 0 ! initial array of pointer size + ! + ! ! Load the first array + CALL load_ptr_4d_sp( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + ! ! Look if more arrays are added + IF( PRESENT(psgn2 ) ) CALL load_ptr_4d_sp( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn3 ) ) CALL load_ptr_4d_sp( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn4 ) ) CALL load_ptr_4d_sp( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn5 ) ) CALL load_ptr_4d_sp( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn6 ) ) CALL load_ptr_4d_sp( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn7 ) ) CALL load_ptr_4d_sp( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn8 ) ) CALL load_ptr_4d_sp( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn9 ) ) CALL load_ptr_4d_sp( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn10) ) CALL load_ptr_4d_sp( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn11) ) CALL load_ptr_4d_sp( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn12) ) CALL load_ptr_4d_sp( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn13) ) CALL load_ptr_4d_sp( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn14) ) CALL load_ptr_4d_sp( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn15) ) CALL load_ptr_4d_sp( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn16) ) CALL load_ptr_4d_sp( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn17) ) CALL load_ptr_4d_sp( pt17, cdna17, psgn17, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn18) ) CALL load_ptr_4d_sp( pt18, cdna18, psgn18, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn19) ) CALL load_ptr_4d_sp( pt19, cdna19, psgn19, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn20) ) CALL load_ptr_4d_sp( pt20, cdna20, psgn20, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn21) ) CALL load_ptr_4d_sp( pt21, cdna21, psgn21, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn22) ) CALL load_ptr_4d_sp( pt22, cdna22, psgn22, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn23) ) CALL load_ptr_4d_sp( pt23, cdna23, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn24) ) CALL load_ptr_4d_sp( pt24, cdna24, psgn24, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn25) ) CALL load_ptr_4d_sp( pt25, cdna25, psgn25, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn26) ) CALL load_ptr_4d_sp( pt26, cdna26, psgn26, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn27) ) CALL load_ptr_4d_sp( pt27, cdna27, psgn27, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn28) ) CALL load_ptr_4d_sp( pt28, cdna28, psgn28, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn29) ) CALL load_ptr_4d_sp( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn30) ) CALL load_ptr_4d_sp( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + IF( nn_comm == 1 ) THEN + CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ELSE + CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ENDIF + ! + END SUBROUTINE lbc_lnk_call_4d_sp + + + SUBROUTINE load_ptr_4d_sp( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + !!--------------------------------------------------------------------- + REAL(sp), DIMENSION(:,:,:,:), TARGET, INTENT(inout), CONTIGUOUS :: ptab ! arrays on which the lbc is applied + CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points + REAL(sp) , INTENT(in ) :: psgn ! sign used across the north fold boundary + TYPE(PTR_4d_sp), DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers + CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points + REAL(sp) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary + INTEGER , INTENT(inout) :: kfld ! number of elements that has been attributed + !!--------------------------------------------------------------------- + ! + kfld = kfld + 1 + ptab_ptr(kfld)%pt4d(1:SIZE(ptab, dim=1),1:SIZE(ptab, dim=2),1:SIZE(ptab, dim=3),1:SIZE(ptab, dim=4)) => ptab + cdna_ptr(kfld) = cdna + psgn_ptr(kfld) = psgn + ! + END SUBROUTINE load_ptr_4d_sp + + !! + !! ---- DOUBLE PRECISION VERSIONS + !! + + SUBROUTINE lbc_lnk_call_2d_dp( & + & cdname & + & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & + & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & + & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & + & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & + & , pt17, cdna17, psgn17, pt18, cdna18, psgn18, pt19, cdna19, psgn19, pt20, cdna20, psgn20 & + & , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24 & + & , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28 & + & , pt29, cdna29, psgn29, pt30, cdna30, psgn30 & + & , kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + !!--------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp), DIMENSION(:,:) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied + REAL(dp), DIMENSION(:,:), OPTIONAL, TARGET, CONTIGUOUS, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , & + & pt9 , pt10, pt11, pt12, pt13, pt14, pt15, & + & pt16, pt17, pt18, pt19, pt20, pt21, pt22, & + & pt23, pt24, pt25, pt26, pt27, pt28, pt29, & + & pt30 + CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points + CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , & + & cdna9 , cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, & + & cdna16, cdna17, cdna18, cdna19, cdna20, cdna21, cdna22, & + & cdna23, cdna24, cdna25, cdna26, cdna27, cdna28, cdna29, & + & cdna30 + REAL(dp) , INTENT(in ) :: psgn1 ! sign used across the north fold + REAL(dp) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , & + & psgn9 , psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, & + & psgn16, psgn17, psgn18, psgn19, psgn20, psgn21, psgn22, & + & psgn23, psgn24, psgn25, psgn26, psgn27, psgn28, psgn29, & + & psgn30 + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(dp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL , INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out + LOGICAL , OPTIONAL , INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + !! + INTEGER :: kfld ! number of elements that will be attributed + TYPE(PTR_4d_dp), DIMENSION(30) :: ptab_ptr ! pointer array + CHARACTER(len=1) , DIMENSION(30) :: cdna_ptr ! nature of ptab_ptr grid-points + REAL(dp) , DIMENSION(30) :: psgn_ptr ! sign used across the north fold boundary + !!--------------------------------------------------------------------- + ! + kfld = 0 ! initial array of pointer size + ! + ! ! Load the first array + CALL load_ptr_2d_dp( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + ! ! Look if more arrays are added + IF( PRESENT(psgn2 ) ) CALL load_ptr_2d_dp( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn3 ) ) CALL load_ptr_2d_dp( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn4 ) ) CALL load_ptr_2d_dp( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn5 ) ) CALL load_ptr_2d_dp( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn6 ) ) CALL load_ptr_2d_dp( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn7 ) ) CALL load_ptr_2d_dp( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn8 ) ) CALL load_ptr_2d_dp( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn9 ) ) CALL load_ptr_2d_dp( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn10) ) CALL load_ptr_2d_dp( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn11) ) CALL load_ptr_2d_dp( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn12) ) CALL load_ptr_2d_dp( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn13) ) CALL load_ptr_2d_dp( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn14) ) CALL load_ptr_2d_dp( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn15) ) CALL load_ptr_2d_dp( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn16) ) CALL load_ptr_2d_dp( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn17) ) CALL load_ptr_2d_dp( pt17, cdna17, psgn17, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn18) ) CALL load_ptr_2d_dp( pt18, cdna18, psgn18, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn19) ) CALL load_ptr_2d_dp( pt19, cdna19, psgn19, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn20) ) CALL load_ptr_2d_dp( pt20, cdna20, psgn20, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn21) ) CALL load_ptr_2d_dp( pt21, cdna21, psgn21, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn22) ) CALL load_ptr_2d_dp( pt22, cdna22, psgn22, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn23) ) CALL load_ptr_2d_dp( pt23, cdna23, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn24) ) CALL load_ptr_2d_dp( pt24, cdna24, psgn24, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn25) ) CALL load_ptr_2d_dp( pt25, cdna25, psgn25, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn26) ) CALL load_ptr_2d_dp( pt26, cdna26, psgn26, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn27) ) CALL load_ptr_2d_dp( pt27, cdna27, psgn27, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn28) ) CALL load_ptr_2d_dp( pt28, cdna28, psgn28, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn29) ) CALL load_ptr_2d_dp( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn30) ) CALL load_ptr_2d_dp( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + IF( nn_comm == 1 ) THEN + CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ELSE + CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ENDIF + ! + END SUBROUTINE lbc_lnk_call_2d_dp + + + SUBROUTINE load_ptr_2d_dp( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + !!--------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:), TARGET, INTENT(inout), CONTIGUOUS :: ptab ! arrays on which the lbc is applied + CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points + REAL(dp) , INTENT(in ) :: psgn ! sign used across the north fold boundary + TYPE(PTR_4d_dp), DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers + CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points + REAL(dp) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary + INTEGER , INTENT(inout) :: kfld ! number of elements that has been attributed + !!--------------------------------------------------------------------- + ! + kfld = kfld + 1 + ptab_ptr(kfld)%pt4d(1:SIZE(ptab, dim=1),1:SIZE(ptab, dim=2),1:1,1:1) => ptab + cdna_ptr(kfld) = cdna + psgn_ptr(kfld) = psgn + ! + END SUBROUTINE load_ptr_2d_dp + + + SUBROUTINE lbc_lnk_call_3d_dp( & + & cdname & + & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & + & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & + & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & + & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & + & , pt17, cdna17, psgn17, pt18, cdna18, psgn18, pt19, cdna19, psgn19, pt20, cdna20, psgn20 & + & , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24 & + & , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28 & + & , pt29, cdna29, psgn29, pt30, cdna30, psgn30 & + & , kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + !!--------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp), DIMENSION(:,:,:) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied + REAL(dp), DIMENSION(:,:,:), OPTIONAL, TARGET, CONTIGUOUS, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , & + & pt9 , pt10, pt11, pt12, pt13, pt14, pt15, & + & pt16, pt17, pt18, pt19, pt20, pt21, pt22, & + & pt23, pt24, pt25, pt26, pt27, pt28, pt29, & + & pt30 + CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points + CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , & + & cdna9 , cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, & + & cdna16, cdna17, cdna18, cdna19, cdna20, cdna21, cdna22, & + & cdna23, cdna24, cdna25, cdna26, cdna27, cdna28, cdna29, & + & cdna30 + REAL(dp) , INTENT(in ) :: psgn1 ! sign used across the north fold + REAL(dp) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , & + & psgn9 , psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, & + & psgn16, psgn17, psgn18, psgn19, psgn20, psgn21, psgn22, & + & psgn23, psgn24, psgn25, psgn26, psgn27, psgn28, psgn29, & + & psgn30 + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(dp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL , INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out + LOGICAL , OPTIONAL , INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + !! + INTEGER :: kfld ! number of elements that will be attributed + TYPE(PTR_4d_dp), DIMENSION(30) :: ptab_ptr ! pointer array + CHARACTER(len=1) , DIMENSION(30) :: cdna_ptr ! nature of ptab_ptr grid-points + REAL(dp) , DIMENSION(30) :: psgn_ptr ! sign used across the north fold boundary + !!--------------------------------------------------------------------- + ! + kfld = 0 ! initial array of pointer size + ! + ! ! Load the first array + CALL load_ptr_3d_dp( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + ! ! Look if more arrays are added + IF( PRESENT(psgn2 ) ) CALL load_ptr_3d_dp( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn3 ) ) CALL load_ptr_3d_dp( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn4 ) ) CALL load_ptr_3d_dp( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn5 ) ) CALL load_ptr_3d_dp( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn6 ) ) CALL load_ptr_3d_dp( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn7 ) ) CALL load_ptr_3d_dp( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn8 ) ) CALL load_ptr_3d_dp( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn9 ) ) CALL load_ptr_3d_dp( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn10) ) CALL load_ptr_3d_dp( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn11) ) CALL load_ptr_3d_dp( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn12) ) CALL load_ptr_3d_dp( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn13) ) CALL load_ptr_3d_dp( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn14) ) CALL load_ptr_3d_dp( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn15) ) CALL load_ptr_3d_dp( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn16) ) CALL load_ptr_3d_dp( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn17) ) CALL load_ptr_3d_dp( pt17, cdna17, psgn17, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn18) ) CALL load_ptr_3d_dp( pt18, cdna18, psgn18, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn19) ) CALL load_ptr_3d_dp( pt19, cdna19, psgn19, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn20) ) CALL load_ptr_3d_dp( pt20, cdna20, psgn20, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn21) ) CALL load_ptr_3d_dp( pt21, cdna21, psgn21, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn22) ) CALL load_ptr_3d_dp( pt22, cdna22, psgn22, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn23) ) CALL load_ptr_3d_dp( pt23, cdna23, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn24) ) CALL load_ptr_3d_dp( pt24, cdna24, psgn24, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn25) ) CALL load_ptr_3d_dp( pt25, cdna25, psgn25, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn26) ) CALL load_ptr_3d_dp( pt26, cdna26, psgn26, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn27) ) CALL load_ptr_3d_dp( pt27, cdna27, psgn27, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn28) ) CALL load_ptr_3d_dp( pt28, cdna28, psgn28, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn29) ) CALL load_ptr_3d_dp( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn30) ) CALL load_ptr_3d_dp( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + IF( nn_comm == 1 ) THEN + CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ELSE + CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ENDIF + ! + END SUBROUTINE lbc_lnk_call_3d_dp + + + SUBROUTINE load_ptr_3d_dp( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + !!--------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), TARGET, INTENT(inout), CONTIGUOUS :: ptab ! arrays on which the lbc is applied + CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points + REAL(dp) , INTENT(in ) :: psgn ! sign used across the north fold boundary + TYPE(PTR_4d_dp), DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers + CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points + REAL(dp) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary + INTEGER , INTENT(inout) :: kfld ! number of elements that has been attributed + !!--------------------------------------------------------------------- + ! + kfld = kfld + 1 + ptab_ptr(kfld)%pt4d(1:SIZE(ptab, dim=1),1:SIZE(ptab, dim=2),1:SIZE(ptab, dim=3),1:1) => ptab + cdna_ptr(kfld) = cdna + psgn_ptr(kfld) = psgn + ! + END SUBROUTINE load_ptr_3d_dp + + + SUBROUTINE lbc_lnk_call_4d_dp( & + & cdname & + & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & + & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & + & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & + & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & + & , pt17, cdna17, psgn17, pt18, cdna18, psgn18, pt19, cdna19, psgn19, pt20, cdna20, psgn20 & + & , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24 & + & , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28 & + & , pt29, cdna29, psgn29, pt30, cdna30, psgn30 & + & , kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + !!--------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp), DIMENSION(:,:,:,:) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied + REAL(dp), DIMENSION(:,:,:,:), OPTIONAL, TARGET, CONTIGUOUS, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , & + & pt9 , pt10, pt11, pt12, pt13, pt14, pt15, & + & pt16, pt17, pt18, pt19, pt20, pt21, pt22, & + & pt23, pt24, pt25, pt26, pt27, pt28, pt29, & + & pt30 + CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points + CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , & + & cdna9 , cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, & + & cdna16, cdna17, cdna18, cdna19, cdna20, cdna21, cdna22, & + & cdna23, cdna24, cdna25, cdna26, cdna27, cdna28, cdna29, & + & cdna30 + REAL(dp) , INTENT(in ) :: psgn1 ! sign used across the north fold + REAL(dp) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , & + & psgn9 , psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, & + & psgn16, psgn17, psgn18, psgn19, psgn20, psgn21, psgn22, & + & psgn23, psgn24, psgn25, psgn26, psgn27, psgn28, psgn29, & + & psgn30 + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(dp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL , INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out + LOGICAL , OPTIONAL , INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + !! + INTEGER :: kfld ! number of elements that will be attributed + TYPE(PTR_4d_dp), DIMENSION(30) :: ptab_ptr ! pointer array + CHARACTER(len=1) , DIMENSION(30) :: cdna_ptr ! nature of ptab_ptr grid-points + REAL(dp) , DIMENSION(30) :: psgn_ptr ! sign used across the north fold boundary + !!--------------------------------------------------------------------- + ! + kfld = 0 ! initial array of pointer size + ! + ! ! Load the first array + CALL load_ptr_4d_dp( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + ! ! Look if more arrays are added + IF( PRESENT(psgn2 ) ) CALL load_ptr_4d_dp( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn3 ) ) CALL load_ptr_4d_dp( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn4 ) ) CALL load_ptr_4d_dp( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn5 ) ) CALL load_ptr_4d_dp( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn6 ) ) CALL load_ptr_4d_dp( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn7 ) ) CALL load_ptr_4d_dp( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn8 ) ) CALL load_ptr_4d_dp( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn9 ) ) CALL load_ptr_4d_dp( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn10) ) CALL load_ptr_4d_dp( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn11) ) CALL load_ptr_4d_dp( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn12) ) CALL load_ptr_4d_dp( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn13) ) CALL load_ptr_4d_dp( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn14) ) CALL load_ptr_4d_dp( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn15) ) CALL load_ptr_4d_dp( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn16) ) CALL load_ptr_4d_dp( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn17) ) CALL load_ptr_4d_dp( pt17, cdna17, psgn17, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn18) ) CALL load_ptr_4d_dp( pt18, cdna18, psgn18, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn19) ) CALL load_ptr_4d_dp( pt19, cdna19, psgn19, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn20) ) CALL load_ptr_4d_dp( pt20, cdna20, psgn20, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn21) ) CALL load_ptr_4d_dp( pt21, cdna21, psgn21, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn22) ) CALL load_ptr_4d_dp( pt22, cdna22, psgn22, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn23) ) CALL load_ptr_4d_dp( pt23, cdna23, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn24) ) CALL load_ptr_4d_dp( pt24, cdna24, psgn24, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn25) ) CALL load_ptr_4d_dp( pt25, cdna25, psgn25, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn26) ) CALL load_ptr_4d_dp( pt26, cdna26, psgn26, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn27) ) CALL load_ptr_4d_dp( pt27, cdna27, psgn27, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn28) ) CALL load_ptr_4d_dp( pt28, cdna28, psgn28, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn29) ) CALL load_ptr_4d_dp( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn30) ) CALL load_ptr_4d_dp( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + IF( nn_comm == 1 ) THEN + CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ELSE + CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ENDIF + ! + END SUBROUTINE lbc_lnk_call_4d_dp + + + SUBROUTINE load_ptr_4d_dp( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + !!--------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:,:), TARGET, INTENT(inout), CONTIGUOUS :: ptab ! arrays on which the lbc is applied + CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points + REAL(dp) , INTENT(in ) :: psgn ! sign used across the north fold boundary + TYPE(PTR_4d_dp), DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers + CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points + REAL(dp) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary + INTEGER , INTENT(inout) :: kfld ! number of elements that has been attributed + !!--------------------------------------------------------------------- + ! + kfld = kfld + 1 + ptab_ptr(kfld)%pt4d(1:SIZE(ptab, dim=1),1:SIZE(ptab, dim=2),1:SIZE(ptab, dim=3),1:SIZE(ptab, dim=4)) => ptab + cdna_ptr(kfld) = cdna + psgn_ptr(kfld) = psgn + ! + END SUBROUTINE load_ptr_4d_dp + + ! + !!---------------------------------------------------------------------- + !! *** lbc_lnk_pt2pt_[sd]p *** + !! *** lbc_lnk_neicoll_[sd]p *** + !! + !! * Argument : dummy argument use in lbc_lnk_... routines + !! cdname : name of the calling subroutine (for monitoring) + !! ptab : pointer of arrays on which the boundary condition is applied + !! cd_nat : nature of array grid-points + !! psgn : sign used across the north fold boundary + !! kfld : number of pt3d arrays + !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) + !! pfillval : optional, background value (used with jpfillcopy) + !!---------------------------------------------------------------------- + !! + !! ---- SINGLE PRECISION VERSIONS + !! + SUBROUTINE lbc_lnk_pt2pt_sp( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + TYPE(PTR_4d_sp), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(sp), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(sp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc + LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + ! + INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ip0i, ip1i, im0i, im1i + INTEGER :: ip0j, ip1j, im0j, im1j + INTEGER :: ishti, ishtj, ishti2, ishtj2 + INTEGER :: ifill_nfd, icomm, ierr + INTEGER :: ihls, idxs, idxr, iszS, iszR + INTEGER, DIMENSION(4) :: iwewe, issnn + INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi + INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj + INTEGER, DIMENSION(8) :: ifill, iszall, ishtS, ishtR + INTEGER, DIMENSION(8) :: ireq ! mpi_request id + INTEGER, DIMENSION(8) :: iStag, iRtag ! Send and Recv mpi_tag id + REAL(sp) :: zland + LOGICAL, DIMENSION(8) :: llsend, llrecv + LOGICAL :: ll4only ! default: 8 neighbourgs + !!---------------------------------------------------------------------- + ! + ! ----------------------------------------- ! + ! 1. local variables initialization ! + ! ----------------------------------------- ! + ! + ipi = SIZE(ptab(1)%pt4d,1) + ipj = SIZE(ptab(1)%pt4d,2) + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) + ! + idxs = 1 ! initalize index for send buffer + idxr = 1 ! initalize index for recv buffer + icomm = mpi_comm_oce ! shorter name + ! + ! take care of optional parameters + ! + ihls = nn_hls ! default definition + IF( PRESENT( khls ) ) ihls = khls + IF( ihls > n_hlsmax ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipi /= Ni_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipj /= Nj_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + ! + ll4only = .FALSE. ! default definition + IF( PRESENT(ld4only) ) ll4only = ld4only + ! + zland = 0._wp ! land filling value: zero by default + IF( PRESENT( pfillval ) ) zland = pfillval ! set land value + ! + ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. + IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs + llsend(:) = lsend(:) ; llrecv(:) = lrecv(:) + ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' + CALL ctl_stop( 'STOP', ctmp1 ) + ELSE ! default neighbours + llsend(:) = mpiSnei(ihls,:) >= 0 + IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners + llrecv(:) = mpiRnei(ihls,:) >= 0 + IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners + ENDIF + ! + ! define ifill: which method should be used to fill each parts (sides+corners) of the halos + ! default definition + DO jn = 1, 4 + IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication + ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity + ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined + ELSE ; ifill(jn) = jpfillcst ! constant value (zland) + ENDIF + END DO + DO jn = 5, 8 + IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication + ELSE ; ifill(jn) = jpfillnothing! do nothing + ENDIF + END DO + ! + ! north fold treatment + IF( l_IdoNFold ) THEN + ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false. + ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo + ENDIF + + ! We first define the localization and size of the parts of the array that will be sent (s), received (r) + ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions. + ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array + ! + ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls + ! ! ________________________ + ip0i = 0 ! im0j = inner |__|__|__________|__|__| + ip1i = ihls ! im1j = inner - halo |__|__|__________|__|__| + im1i = ipi-2*ihls ! | | | | | | + im0i = ipi - ihls ! | | | | | | + ip0j = 0 ! | | | | | | + ip1j = ihls ! |__|__|__________|__|__| + im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__| + im0j = ipj - ihls ! ip0j = 0 |__|__|__________|__|__| + ! ! ip0i ip1i im1i im0i + ! + iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) + !cd sides: west east south north ; corners: so-we, so-ea, no-we, no-ea + isizei(1:4) = (/ ihls, ihls, ipi, ipi /) ; isizei(5:8) = ihls ! i- count + isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count + ishtSi(1:4) = (/ ip1i, im1i, ip0i, ip0i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data + ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data + ishtRi(1:4) = (/ ip0i, im0i, ip0i, ip0i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location + ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location + ishtPi(1:4) = (/ im1i, ip1i, ip0i, ip0i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity + ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity + ! + ! -------------------------------- ! + ! 2. Prepare MPI exchanges ! + ! -------------------------------- ! + ! + iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! any value but each one must be different + ! define iRtag with the corresponding iStag, e.g. data received at west where sent at east. + iRtag(jpwe) = iStag(jpea) ; iRtag(jpea) = iStag(jpwe) ; iRtag(jpso) = iStag(jpno) ; iRtag(jpno) = iStag(jpso) + iRtag(jpsw) = iStag(jpne) ; iRtag(jpse) = iStag(jpnw) ; iRtag(jpnw) = iStag(jpse) ; iRtag(jpne) = iStag(jpsw) + ! + iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf + ishtS(1) = 0 + DO jn = 2, 8 + ishtS(jn) = ishtS(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) ) + END DO + ishtR(1) = 0 + DO jn = 2, 8 + ishtR(jn) = ishtR(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) ) + END DO + + ! Allocate buffer arrays to be sent/received if needed + iszS = SUM(iszall, mask = llsend) ! send buffer size + IF( ALLOCATED(buffsnd_sp) ) THEN + CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! wait for Isend from the PREVIOUS call + IF( SIZE(buffsnd_sp) < iszS ) DEALLOCATE(buffsnd_sp) ! send buffer is too small + ENDIF + IF( .NOT. ALLOCATED(buffsnd_sp) ) ALLOCATE( buffsnd_sp(iszS) ) + iszR = SUM(iszall, mask = llrecv) ! recv buffer size + IF( ALLOCATED(buffrcv_sp) ) THEN + IF( SIZE(buffrcv_sp) < iszR ) DEALLOCATE(buffrcv_sp) ! recv buffer is too small + ENDIF + IF( .NOT. ALLOCATED(buffrcv_sp) ) ALLOCATE( buffrcv_sp(iszR) ) + ! + ! default definition when no communication is done. understood by mpi_waitall + nreq_p2p(:) = MPI_REQUEST_NULL ! WARNING: Must be done after the call to mpi_waitall just above + ! + ! ----------------------------------------------- ! + ! 3. Do east and west MPI_Isend if needed ! + ! ----------------------------------------------- ! + ! + DO jn = 1, 2 + + IF( llsend(jn) ) THEN + ishti = ishtSi(jn) + ishtj = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + buffsnd_sp(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) + idxs = idxs + 1 + END DO ; END DO ; END DO ; END DO ; END DO + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! non-blocking send of the west/east side using local buffer + CALL MPI_ISEND( buffsnd_sp(ishtS(jn)+1), iszall(jn), MPI_REAL, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + ENDIF + + END DO + ! + ! ----------------------------------- ! + ! 4. Fill east and west halos ! + ! ----------------------------------- ! + ! + DO jn = 1, 2 + + + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + SELECT CASE ( ifill(jn) ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! fill with data received by MPI + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! ! blocking receive of the west/east halo in local temporary arrays + CALL MPI_RECV( buffrcv_sp(ishtR(jn)+1), iszall(jn), MPI_REAL, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = buffrcv_sp(idxr) + idxr = idxr + 1 + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use periodicity + ishti2 = ishtPi(jn) + ishtj2 = ishtPj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + ishti2 = ishtSi(jn) + ishtj2 = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland + END DO ; END DO ; END DO ; END DO ; END DO + END SELECT + END DO + ! + ! ------------------------------------------------- ! + ! 5. Do north and south MPI_Isend if needed ! + ! ------------------------------------------------- ! + ! + DO jn = 3, 4 + + IF( llsend(jn) ) THEN + ishti = ishtSi(jn) + ishtj = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + buffsnd_sp(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) + idxs = idxs + 1 + END DO ; END DO ; END DO ; END DO ; END DO + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! non-blocking send of the west/east side using local buffer + CALL MPI_ISEND( buffsnd_sp(ishtS(jn)+1), iszall(jn), MPI_REAL, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + ENDIF + + END DO + ! + ! ------------------------------- ! + ! 6. north fold treatment ! + ! ------------------------------- ! + ! + ! Must be done after receiving data from East/West neighbourgs (as it is coded in mpp_nfd, to be changed one day...) + ! Do it after MPI_iSend to south/north neighbourgs so they won't wait (too much) to receive their data + ! Do if before MPI_Recv from south/north neighbourgs so we have more time to receive data + ! + IF( l_IdoNFold ) THEN + IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold + ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold + ENDIF + ENDIF + ! + ! ------------------------------------- ! + ! 7. Fill south and north halos ! + ! ------------------------------------- ! + ! + DO jn = 3, 4 + + + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + SELECT CASE ( ifill(jn) ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! fill with data received by MPI + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! ! blocking receive of the west/east halo in local temporary arrays + CALL MPI_RECV( buffrcv_sp(ishtR(jn)+1), iszall(jn), MPI_REAL, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = buffrcv_sp(idxr) + idxr = idxr + 1 + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use periodicity + ishti2 = ishtPi(jn) + ishtj2 = ishtPj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + ishti2 = ishtSi(jn) + ishtj2 = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland + END DO ; END DO ; END DO ; END DO ; END DO + END SELECT + END DO + ! + ! ----------------------------------------------- ! + ! 8. Specific problem in corner treatment ! + ! ( very rate case... ) ! + ! ----------------------------------------------- ! + ! + DO jn = 5, 8 + + IF( llsend(jn) ) THEN + ishti = ishtSi(jn) + ishtj = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + buffsnd_sp(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) + idxs = idxs + 1 + END DO ; END DO ; END DO ; END DO ; END DO + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! non-blocking send of the west/east side using local buffer + CALL MPI_ISEND( buffsnd_sp(ishtS(jn)+1), iszall(jn), MPI_REAL, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + ENDIF + + END DO + DO jn = 5, 8 + + + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + SELECT CASE ( ifill(jn) ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! fill with data received by MPI + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! ! blocking receive of the west/east halo in local temporary arrays + CALL MPI_RECV( buffrcv_sp(ishtR(jn)+1), iszall(jn), MPI_REAL, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = buffrcv_sp(idxr) + idxr = idxr + 1 + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use periodicity + ishti2 = ishtPi(jn) + ishtj2 = ishtPj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + ishti2 = ishtSi(jn) + ishtj2 = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland + END DO ; END DO ; END DO ; END DO ; END DO + END SELECT + END DO + ! + ! -------------------------------------------- ! + ! 9. deallocate local temporary arrays ! + ! if they areg larger than jpi*jpj ! <- arbitrary max size... + ! -------------------------------------------- ! + ! + IF( iszR > jpi*jpj ) DEALLOCATE(buffrcv_sp) ! blocking receive -> can directly deallocate + IF( iszS > jpi*jpj ) THEN + CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! must wait before deallocate send buffer + DEALLOCATE(buffsnd_sp) + ENDIF + ! + END SUBROUTINE lbc_lnk_pt2pt_sp + + +SUBROUTINE lbc_lnk_neicoll_sp( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + TYPE(PTR_4d_sp), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(sp), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(sp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc + LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + ! + INTEGER :: ji, jj, jk , jl, jf, jn ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ip0i, ip1i, im0i, im1i + INTEGER :: ip0j, ip1j, im0j, im1j + INTEGER :: ishti, ishtj, ishti2, ishtj2 + INTEGER :: iszS, iszR + INTEGER :: ierr + INTEGER :: ihls, idx + INTEGER :: impi_nc + INTEGER :: ifill_nfd + INTEGER, DIMENSION(4) :: iwewe, issnn + INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi + INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj + INTEGER, DIMENSION(8) :: ifill, iszall + INTEGER, DIMENSION(8) :: jnf + INTEGER, DIMENSION(:), ALLOCATABLE :: iScnt, iRcnt ! number of elements to be sent/received + INTEGER, DIMENSION(:), ALLOCATABLE :: iSdpl, iRdpl ! displacement in halos arrays + LOGICAL, DIMENSION(8) :: llsend, llrecv + REAL(sp) :: zland + LOGICAL :: ll4only ! default: 8 neighbourgs + !!---------------------------------------------------------------------- + ! + ! ----------------------------------------- ! + ! 1. local variables initialization ! + ! ----------------------------------------- ! + ! + ipi = SIZE(ptab(1)%pt4d,1) + ipj = SIZE(ptab(1)%pt4d,2) + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) + ! + ! take care of optional parameters + ! + ihls = nn_hls ! default definition + IF( PRESENT( khls ) ) ihls = khls + IF( ihls > n_hlsmax ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipi /= Ni_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipj /= Nj_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + ! + ll4only = .FALSE. ! default definition + IF( PRESENT(ld4only) ) ll4only = ld4only + ! + impi_nc = mpi_nc_com8(ihls) ! default + IF( ll4only ) impi_nc = mpi_nc_com4(ihls) + ! + zland = 0._wp ! land filling value: zero by default + IF( PRESENT( pfillval ) ) zland = pfillval ! set land value + ! + ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. + IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs + CALL ctl_stop( 'STOP', 'mpp_nc_generic+lsend and lrecv not yet implemented') + ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' + CALL ctl_stop( 'STOP', ctmp1 ) + ELSE ! default neighbours + llsend(:) = mpiSnei(ihls,:) >= 0 + IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners + llrecv(:) = mpiRnei(ihls,:) >= 0 + IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners + ENDIF + ! + ! define ifill: which method should be used to fill each parts (sides+corners) of the halos + ! default definition + DO jn = 1, 8 + IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication + ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity + ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined + ELSE ; ifill(jn) = jpfillcst ! constant value (zland) + ENDIF + END DO + ! take care of "indirect self-periodicity" for the corners + DO jn = 5, 8 + IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn) = jpfillnothing ! no bi-perio but ew-perio: do corners later + IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn) = jpfillnothing ! no bi-perio but ns-perio: do corners later + END DO + ! north fold treatment + IF( l_IdoNFold ) THEN + ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false. + ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo + ENDIF + + ! We first define the localization and size of the parts of the array that will be sent (s), received (r) + ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions. + ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array + ! + ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls + ! ! ________________________ + ip0i = 0 ! im0j = inner |__|________________|__| + ip1i = ihls ! im1j = inner - halo | |__|__________|__| | + im1i = ipi-2*ihls ! | | | | | | + im0i = ipi - ihls ! | | | | | | + ip0j = 0 ! | | | | | | + ip1j = ihls ! | |__|__________|__| | + im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__| + im0j = ipj - ihls ! ip0j = 0 |__|________________|__| + ! ! ip0i ip1i im1i im0i + ! + iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) + ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea + isizei(1:4) = (/ ihls, ihls, Ni_0, Ni_0 /) ; isizei(5:8) = ihls ! i- count + isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count + ishtSi(1:4) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data + ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data + ishtRi(1:4) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location + ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location + ishtPi(1:4) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity + ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity + ! + ! -------------------------------- ! + ! 2. Prepare MPI exchanges ! + ! -------------------------------- ! + ! + ! Allocate local temporary arrays to be sent/received. + iszS = COUNT( llsend ) + iszR = COUNT( llrecv ) + ALLOCATE( iScnt(iszS), iRcnt(iszR), iSdpl(iszS), iRdpl(iszR) ) ! ok if iszS = 0 or iszR = 0 + iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf + iScnt(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false. + iRcnt(:) = PACK( iszall, mask = llrecv ) + IF( iszS > 0 ) iSdpl(1) = 0 + DO jn = 2,iszS + iSdpl(jn) = iSdpl(jn-1) + iScnt(jn-1) ! with _alltoallv: in units of sendtype + END DO + IF( iszR > 0 ) iRdpl(1) = 0 + DO jn = 2,iszR + iRdpl(jn) = iRdpl(jn-1) + iRcnt(jn-1) ! with _alltoallv: in units of sendtype + END DO + + ! Allocate buffer arrays to be sent/received if needed + iszS = SUM(iszall, mask = llsend) ! send buffer size + IF( ALLOCATED(buffsnd_sp) ) THEN + IF( SIZE(buffsnd_sp) < iszS ) DEALLOCATE(buffsnd_sp) ! send buffer is too small + ENDIF + IF( .NOT. ALLOCATED(buffsnd_sp) ) ALLOCATE( buffsnd_sp(iszS) ) + iszR = SUM(iszall, mask = llrecv) ! recv buffer size + IF( ALLOCATED(buffrcv_sp) ) THEN + IF( SIZE(buffrcv_sp) < iszR ) DEALLOCATE(buffrcv_sp) ! recv buffer is too small + ENDIF + IF( .NOT. ALLOCATED(buffrcv_sp) ) ALLOCATE( buffrcv_sp(iszR) ) + + ! fill sending buffer with ptab(jf)%pt4d + idx = 1 + DO jn = 1, 8 + IF( llsend(jn) ) THEN + ishti = ishtSi(jn) + ishtj = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + buffsnd_sp(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) + idx = idx + 1 + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + END DO + ! + ! ------------------------------------------------ ! + ! 3. Do all MPI exchanges in 1 unique call ! + ! ------------------------------------------------ ! + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + CALL mpi_neighbor_alltoallv (buffsnd_sp, iScnt, iSdpl, MPI_REAL, buffrcv_sp, iRcnt, iRdpl, MPI_REAL, impi_nc, ierr) + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ------------------------- ! + ! 4. Fill all halos ! + ! ------------------------- ! + ! + idx = 1 + ! MPI3 bug fix when domain decomposition has 2 columns/rows + IF (jpni .eq. 2) THEN + IF (jpnj .eq. 2) THEN + jnf(1:8) = (/ 2, 1, 4, 3, 8, 7, 6, 5 /) + ELSE + jnf(1:8) = (/ 2, 1, 3, 4, 6, 5, 8, 7 /) + ENDIF + ELSE + IF (jpnj .eq. 2) THEN + jnf(1:8) = (/ 1, 2, 4, 3, 7, 8, 5, 6 /) + ELSE + jnf(1:8) = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) + ENDIF + ENDIF + + DO jn = 1, 8 + ishti = ishtRi(jnf(jn)) + ishtj = ishtRj(jnf(jn)) + SELECT CASE ( ifill(jnf(jn)) ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! fill with data received by MPI + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = buffrcv_sp(idx) + idx = idx + 1 + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use periodicity + ishti2 = ishtPi(jnf(jn)) + ishtj2 = ishtPj(jnf(jn)) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + ishti2 = ishtSi(jnf(jn)) + ishtj2 = ishtSj(jnf(jn)) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland + END DO ; END DO ; END DO ; END DO ; END DO + END SELECT + END DO + + DEALLOCATE( iScnt, iRcnt, iSdpl, iRdpl ) + IF( iszS > jpi*jpj ) DEALLOCATE(buffsnd_sp) ! blocking Send -> can directly deallocate + IF( iszR > jpi*jpj ) DEALLOCATE(buffrcv_sp) ! blocking Recv -> can directly deallocate + + ! potential "indirect self-periodicity" for the corners + DO jn = 5, 8 + IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpwe) ) THEN ! no bi-perio but ew-perio: corners indirect definition + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + ishti2 = ishtPi(jn) ! use i- shift periodicity + ishtj2 = ishtRj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpso) ) THEN ! no bi-perio but ns-perio: corners indirect definition + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + ishti2 = ishtRi(jn) ! use i- shift recv location: use ns-perio -> ok as filling of the west and east halos now done + ishtj2 = ishtPj(jn) ! use j- shift periodicity + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + END DO + ! + ! ------------------------------- ! + ! 5. north fold treatment ! + ! ------------------------------- ! + ! + IF( l_IdoNFold ) THEN + IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold + ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold + ENDIF + ENDIF + ! + END SUBROUTINE lbc_lnk_neicoll_sp + !! + !! ---- DOUBLE PRECISION VERSIONS + !! + SUBROUTINE lbc_lnk_pt2pt_dp( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + TYPE(PTR_4d_dp), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(dp), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(dp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc + LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + ! + INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ip0i, ip1i, im0i, im1i + INTEGER :: ip0j, ip1j, im0j, im1j + INTEGER :: ishti, ishtj, ishti2, ishtj2 + INTEGER :: ifill_nfd, icomm, ierr + INTEGER :: ihls, idxs, idxr, iszS, iszR + INTEGER, DIMENSION(4) :: iwewe, issnn + INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi + INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj + INTEGER, DIMENSION(8) :: ifill, iszall, ishtS, ishtR + INTEGER, DIMENSION(8) :: ireq ! mpi_request id + INTEGER, DIMENSION(8) :: iStag, iRtag ! Send and Recv mpi_tag id + REAL(dp) :: zland + LOGICAL, DIMENSION(8) :: llsend, llrecv + LOGICAL :: ll4only ! default: 8 neighbourgs + !!---------------------------------------------------------------------- + ! + ! ----------------------------------------- ! + ! 1. local variables initialization ! + ! ----------------------------------------- ! + ! + ipi = SIZE(ptab(1)%pt4d,1) + ipj = SIZE(ptab(1)%pt4d,2) + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) + ! + idxs = 1 ! initalize index for send buffer + idxr = 1 ! initalize index for recv buffer + icomm = mpi_comm_oce ! shorter name + ! + ! take care of optional parameters + ! + ihls = nn_hls ! default definition + IF( PRESENT( khls ) ) ihls = khls + IF( ihls > n_hlsmax ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipi /= Ni_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipj /= Nj_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + ! + ll4only = .FALSE. ! default definition + IF( PRESENT(ld4only) ) ll4only = ld4only + ! + zland = 0._wp ! land filling value: zero by default + IF( PRESENT( pfillval ) ) zland = pfillval ! set land value + ! + ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. + IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs + llsend(:) = lsend(:) ; llrecv(:) = lrecv(:) + ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' + CALL ctl_stop( 'STOP', ctmp1 ) + ELSE ! default neighbours + llsend(:) = mpiSnei(ihls,:) >= 0 + IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners + llrecv(:) = mpiRnei(ihls,:) >= 0 + IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners + ENDIF + ! + ! define ifill: which method should be used to fill each parts (sides+corners) of the halos + ! default definition + DO jn = 1, 4 + IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication + ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity + ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined + ELSE ; ifill(jn) = jpfillcst ! constant value (zland) + ENDIF + END DO + DO jn = 5, 8 + IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication + ELSE ; ifill(jn) = jpfillnothing! do nothing + ENDIF + END DO + ! + ! north fold treatment + IF( l_IdoNFold ) THEN + ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false. + ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo + ENDIF + + ! We first define the localization and size of the parts of the array that will be sent (s), received (r) + ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions. + ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array + ! + ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls + ! ! ________________________ + ip0i = 0 ! im0j = inner |__|__|__________|__|__| + ip1i = ihls ! im1j = inner - halo |__|__|__________|__|__| + im1i = ipi-2*ihls ! | | | | | | + im0i = ipi - ihls ! | | | | | | + ip0j = 0 ! | | | | | | + ip1j = ihls ! |__|__|__________|__|__| + im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__| + im0j = ipj - ihls ! ip0j = 0 |__|__|__________|__|__| + ! ! ip0i ip1i im1i im0i + ! + iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) + !cd sides: west east south north ; corners: so-we, so-ea, no-we, no-ea + isizei(1:4) = (/ ihls, ihls, ipi, ipi /) ; isizei(5:8) = ihls ! i- count + isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count + ishtSi(1:4) = (/ ip1i, im1i, ip0i, ip0i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data + ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data + ishtRi(1:4) = (/ ip0i, im0i, ip0i, ip0i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location + ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location + ishtPi(1:4) = (/ im1i, ip1i, ip0i, ip0i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity + ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity + ! + ! -------------------------------- ! + ! 2. Prepare MPI exchanges ! + ! -------------------------------- ! + ! + iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! any value but each one must be different + ! define iRtag with the corresponding iStag, e.g. data received at west where sent at east. + iRtag(jpwe) = iStag(jpea) ; iRtag(jpea) = iStag(jpwe) ; iRtag(jpso) = iStag(jpno) ; iRtag(jpno) = iStag(jpso) + iRtag(jpsw) = iStag(jpne) ; iRtag(jpse) = iStag(jpnw) ; iRtag(jpnw) = iStag(jpse) ; iRtag(jpne) = iStag(jpsw) + ! + iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf + ishtS(1) = 0 + DO jn = 2, 8 + ishtS(jn) = ishtS(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) ) + END DO + ishtR(1) = 0 + DO jn = 2, 8 + ishtR(jn) = ishtR(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) ) + END DO + + ! Allocate buffer arrays to be sent/received if needed + iszS = SUM(iszall, mask = llsend) ! send buffer size + IF( ALLOCATED(buffsnd_dp) ) THEN + CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! wait for Isend from the PREVIOUS call + IF( SIZE(buffsnd_dp) < iszS ) DEALLOCATE(buffsnd_dp) ! send buffer is too small + ENDIF + IF( .NOT. ALLOCATED(buffsnd_dp) ) ALLOCATE( buffsnd_dp(iszS) ) + iszR = SUM(iszall, mask = llrecv) ! recv buffer size + IF( ALLOCATED(buffrcv_dp) ) THEN + IF( SIZE(buffrcv_dp) < iszR ) DEALLOCATE(buffrcv_dp) ! recv buffer is too small + ENDIF + IF( .NOT. ALLOCATED(buffrcv_dp) ) ALLOCATE( buffrcv_dp(iszR) ) + ! + ! default definition when no communication is done. understood by mpi_waitall + nreq_p2p(:) = MPI_REQUEST_NULL ! WARNING: Must be done after the call to mpi_waitall just above + ! + ! ----------------------------------------------- ! + ! 3. Do east and west MPI_Isend if needed ! + ! ----------------------------------------------- ! + ! + DO jn = 1, 2 + + IF( llsend(jn) ) THEN + ishti = ishtSi(jn) + ishtj = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + buffsnd_dp(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) + idxs = idxs + 1 + END DO ; END DO ; END DO ; END DO ; END DO + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! non-blocking send of the west/east side using local buffer + CALL MPI_ISEND( buffsnd_dp(ishtS(jn)+1), iszall(jn), MPI_DOUBLE_PRECISION, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + ENDIF + + END DO + ! + ! ----------------------------------- ! + ! 4. Fill east and west halos ! + ! ----------------------------------- ! + ! + DO jn = 1, 2 + + + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + SELECT CASE ( ifill(jn) ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! fill with data received by MPI + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! ! blocking receive of the west/east halo in local temporary arrays + CALL MPI_RECV( buffrcv_dp(ishtR(jn)+1), iszall(jn), MPI_DOUBLE_PRECISION, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = buffrcv_dp(idxr) + idxr = idxr + 1 + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use periodicity + ishti2 = ishtPi(jn) + ishtj2 = ishtPj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + ishti2 = ishtSi(jn) + ishtj2 = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland + END DO ; END DO ; END DO ; END DO ; END DO + END SELECT + END DO + ! + ! ------------------------------------------------- ! + ! 5. Do north and south MPI_Isend if needed ! + ! ------------------------------------------------- ! + ! + DO jn = 3, 4 + + IF( llsend(jn) ) THEN + ishti = ishtSi(jn) + ishtj = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + buffsnd_dp(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) + idxs = idxs + 1 + END DO ; END DO ; END DO ; END DO ; END DO + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! non-blocking send of the west/east side using local buffer + CALL MPI_ISEND( buffsnd_dp(ishtS(jn)+1), iszall(jn), MPI_DOUBLE_PRECISION, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + ENDIF + + END DO + ! + ! ------------------------------- ! + ! 6. north fold treatment ! + ! ------------------------------- ! + ! + ! Must be done after receiving data from East/West neighbourgs (as it is coded in mpp_nfd, to be changed one day...) + ! Do it after MPI_iSend to south/north neighbourgs so they won't wait (too much) to receive their data + ! Do if before MPI_Recv from south/north neighbourgs so we have more time to receive data + ! + IF( l_IdoNFold ) THEN + IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold + ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold + ENDIF + ENDIF + ! + ! ------------------------------------- ! + ! 7. Fill south and north halos ! + ! ------------------------------------- ! + ! + DO jn = 3, 4 + + + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + SELECT CASE ( ifill(jn) ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! fill with data received by MPI + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! ! blocking receive of the west/east halo in local temporary arrays + CALL MPI_RECV( buffrcv_dp(ishtR(jn)+1), iszall(jn), MPI_DOUBLE_PRECISION, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = buffrcv_dp(idxr) + idxr = idxr + 1 + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use periodicity + ishti2 = ishtPi(jn) + ishtj2 = ishtPj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + ishti2 = ishtSi(jn) + ishtj2 = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland + END DO ; END DO ; END DO ; END DO ; END DO + END SELECT + END DO + ! + ! ----------------------------------------------- ! + ! 8. Specific problem in corner treatment ! + ! ( very rate case... ) ! + ! ----------------------------------------------- ! + ! + DO jn = 5, 8 + + IF( llsend(jn) ) THEN + ishti = ishtSi(jn) + ishtj = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + buffsnd_dp(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) + idxs = idxs + 1 + END DO ; END DO ; END DO ; END DO ; END DO + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! non-blocking send of the west/east side using local buffer + CALL MPI_ISEND( buffsnd_dp(ishtS(jn)+1), iszall(jn), MPI_DOUBLE_PRECISION, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + ENDIF + + END DO + DO jn = 5, 8 + + + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + SELECT CASE ( ifill(jn) ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! fill with data received by MPI + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! ! blocking receive of the west/east halo in local temporary arrays + CALL MPI_RECV( buffrcv_dp(ishtR(jn)+1), iszall(jn), MPI_DOUBLE_PRECISION, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = buffrcv_dp(idxr) + idxr = idxr + 1 + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use periodicity + ishti2 = ishtPi(jn) + ishtj2 = ishtPj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + ishti2 = ishtSi(jn) + ishtj2 = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland + END DO ; END DO ; END DO ; END DO ; END DO + END SELECT + END DO + ! + ! -------------------------------------------- ! + ! 9. deallocate local temporary arrays ! + ! if they areg larger than jpi*jpj ! <- arbitrary max size... + ! -------------------------------------------- ! + ! + IF( iszR > jpi*jpj ) DEALLOCATE(buffrcv_dp) ! blocking receive -> can directly deallocate + IF( iszS > jpi*jpj ) THEN + CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! must wait before deallocate send buffer + DEALLOCATE(buffsnd_dp) + ENDIF + ! + END SUBROUTINE lbc_lnk_pt2pt_dp + + +SUBROUTINE lbc_lnk_neicoll_dp( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + TYPE(PTR_4d_dp), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(dp), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(dp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc + LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + ! + INTEGER :: ji, jj, jk , jl, jf, jn ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ip0i, ip1i, im0i, im1i + INTEGER :: ip0j, ip1j, im0j, im1j + INTEGER :: ishti, ishtj, ishti2, ishtj2 + INTEGER :: iszS, iszR + INTEGER :: ierr + INTEGER :: ihls, idx + INTEGER :: impi_nc + INTEGER :: ifill_nfd + INTEGER, DIMENSION(4) :: iwewe, issnn + INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi + INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj + INTEGER, DIMENSION(8) :: ifill, iszall + INTEGER, DIMENSION(8) :: jnf + INTEGER, DIMENSION(:), ALLOCATABLE :: iScnt, iRcnt ! number of elements to be sent/received + INTEGER, DIMENSION(:), ALLOCATABLE :: iSdpl, iRdpl ! displacement in halos arrays + LOGICAL, DIMENSION(8) :: llsend, llrecv + REAL(dp) :: zland + LOGICAL :: ll4only ! default: 8 neighbourgs + !!---------------------------------------------------------------------- + ! + ! ----------------------------------------- ! + ! 1. local variables initialization ! + ! ----------------------------------------- ! + ! + ipi = SIZE(ptab(1)%pt4d,1) + ipj = SIZE(ptab(1)%pt4d,2) + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) + ! + ! take care of optional parameters + ! + ihls = nn_hls ! default definition + IF( PRESENT( khls ) ) ihls = khls + IF( ihls > n_hlsmax ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipi /= Ni_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipj /= Nj_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + ! + ll4only = .FALSE. ! default definition + IF( PRESENT(ld4only) ) ll4only = ld4only + ! + impi_nc = mpi_nc_com8(ihls) ! default + IF( ll4only ) impi_nc = mpi_nc_com4(ihls) + ! + zland = 0._wp ! land filling value: zero by default + IF( PRESENT( pfillval ) ) zland = pfillval ! set land value + ! + ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. + IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs + CALL ctl_stop( 'STOP', 'mpp_nc_generic+lsend and lrecv not yet implemented') + ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' + CALL ctl_stop( 'STOP', ctmp1 ) + ELSE ! default neighbours + llsend(:) = mpiSnei(ihls,:) >= 0 + IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners + llrecv(:) = mpiRnei(ihls,:) >= 0 + IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners + ENDIF + ! + ! define ifill: which method should be used to fill each parts (sides+corners) of the halos + ! default definition + DO jn = 1, 8 + IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication + ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity + ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined + ELSE ; ifill(jn) = jpfillcst ! constant value (zland) + ENDIF + END DO + ! take care of "indirect self-periodicity" for the corners + DO jn = 5, 8 + IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn) = jpfillnothing ! no bi-perio but ew-perio: do corners later + IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn) = jpfillnothing ! no bi-perio but ns-perio: do corners later + END DO + ! north fold treatment + IF( l_IdoNFold ) THEN + ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false. + ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo + ENDIF + + ! We first define the localization and size of the parts of the array that will be sent (s), received (r) + ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions. + ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array + ! + ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls + ! ! ________________________ + ip0i = 0 ! im0j = inner |__|________________|__| + ip1i = ihls ! im1j = inner - halo | |__|__________|__| | + im1i = ipi-2*ihls ! | | | | | | + im0i = ipi - ihls ! | | | | | | + ip0j = 0 ! | | | | | | + ip1j = ihls ! | |__|__________|__| | + im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__| + im0j = ipj - ihls ! ip0j = 0 |__|________________|__| + ! ! ip0i ip1i im1i im0i + ! + iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) + ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea + isizei(1:4) = (/ ihls, ihls, Ni_0, Ni_0 /) ; isizei(5:8) = ihls ! i- count + isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count + ishtSi(1:4) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data + ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data + ishtRi(1:4) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location + ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location + ishtPi(1:4) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity + ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity + ! + ! -------------------------------- ! + ! 2. Prepare MPI exchanges ! + ! -------------------------------- ! + ! + ! Allocate local temporary arrays to be sent/received. + iszS = COUNT( llsend ) + iszR = COUNT( llrecv ) + ALLOCATE( iScnt(iszS), iRcnt(iszR), iSdpl(iszS), iRdpl(iszR) ) ! ok if iszS = 0 or iszR = 0 + iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf + iScnt(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false. + iRcnt(:) = PACK( iszall, mask = llrecv ) + IF( iszS > 0 ) iSdpl(1) = 0 + DO jn = 2,iszS + iSdpl(jn) = iSdpl(jn-1) + iScnt(jn-1) ! with _alltoallv: in units of sendtype + END DO + IF( iszR > 0 ) iRdpl(1) = 0 + DO jn = 2,iszR + iRdpl(jn) = iRdpl(jn-1) + iRcnt(jn-1) ! with _alltoallv: in units of sendtype + END DO + + ! Allocate buffer arrays to be sent/received if needed + iszS = SUM(iszall, mask = llsend) ! send buffer size + IF( ALLOCATED(buffsnd_dp) ) THEN + IF( SIZE(buffsnd_dp) < iszS ) DEALLOCATE(buffsnd_dp) ! send buffer is too small + ENDIF + IF( .NOT. ALLOCATED(buffsnd_dp) ) ALLOCATE( buffsnd_dp(iszS) ) + iszR = SUM(iszall, mask = llrecv) ! recv buffer size + IF( ALLOCATED(buffrcv_dp) ) THEN + IF( SIZE(buffrcv_dp) < iszR ) DEALLOCATE(buffrcv_dp) ! recv buffer is too small + ENDIF + IF( .NOT. ALLOCATED(buffrcv_dp) ) ALLOCATE( buffrcv_dp(iszR) ) + + ! fill sending buffer with ptab(jf)%pt4d + idx = 1 + DO jn = 1, 8 + IF( llsend(jn) ) THEN + ishti = ishtSi(jn) + ishtj = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + buffsnd_dp(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) + idx = idx + 1 + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + END DO + ! + ! ------------------------------------------------ ! + ! 3. Do all MPI exchanges in 1 unique call ! + ! ------------------------------------------------ ! + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + CALL mpi_neighbor_alltoallv (buffsnd_dp, iScnt, iSdpl, MPI_DOUBLE_PRECISION, buffrcv_dp, iRcnt, iRdpl, MPI_DOUBLE_PRECISION, impi_nc, ierr) + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ------------------------- ! + ! 4. Fill all halos ! + ! ------------------------- ! + ! + idx = 1 + ! MPI3 bug fix when domain decomposition has 2 columns/rows + IF (jpni .eq. 2) THEN + IF (jpnj .eq. 2) THEN + jnf(1:8) = (/ 2, 1, 4, 3, 8, 7, 6, 5 /) + ELSE + jnf(1:8) = (/ 2, 1, 3, 4, 6, 5, 8, 7 /) + ENDIF + ELSE + IF (jpnj .eq. 2) THEN + jnf(1:8) = (/ 1, 2, 4, 3, 7, 8, 5, 6 /) + ELSE + jnf(1:8) = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) + ENDIF + ENDIF + + DO jn = 1, 8 + ishti = ishtRi(jnf(jn)) + ishtj = ishtRj(jnf(jn)) + SELECT CASE ( ifill(jnf(jn)) ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! fill with data received by MPI + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = buffrcv_dp(idx) + idx = idx + 1 + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use periodicity + ishti2 = ishtPi(jnf(jn)) + ishtj2 = ishtPj(jnf(jn)) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + ishti2 = ishtSi(jnf(jn)) + ishtj2 = ishtSj(jnf(jn)) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland + END DO ; END DO ; END DO ; END DO ; END DO + END SELECT + END DO + + DEALLOCATE( iScnt, iRcnt, iSdpl, iRdpl ) + IF( iszS > jpi*jpj ) DEALLOCATE(buffsnd_dp) ! blocking Send -> can directly deallocate + IF( iszR > jpi*jpj ) DEALLOCATE(buffrcv_dp) ! blocking Recv -> can directly deallocate + + ! potential "indirect self-periodicity" for the corners + DO jn = 5, 8 + IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpwe) ) THEN ! no bi-perio but ew-perio: corners indirect definition + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + ishti2 = ishtPi(jn) ! use i- shift periodicity + ishtj2 = ishtRj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpso) ) THEN ! no bi-perio but ns-perio: corners indirect definition + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + ishti2 = ishtRi(jn) ! use i- shift recv location: use ns-perio -> ok as filling of the west and east halos now done + ishtj2 = ishtPj(jn) ! use j- shift periodicity + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + END DO + ! + ! ------------------------------- ! + ! 5. north fold treatment ! + ! ------------------------------- ! + ! + IF( l_IdoNFold ) THEN + IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold + ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold + ENDIF + ENDIF + ! + END SUBROUTINE lbc_lnk_neicoll_dp + + !!====================================================================== + !!--------------------------------------------------------------------- + !! *** routine mpp_lbc_north_icb *** + !! + !! ** Purpose : Ensure proper north fold horizontal bondary condition + !! in mpp configuration in case of jpn1 > 1 and for 2d + !! array with outer extra halo + !! + !! ** Method : North fold condition and mpp with more than one proc + !! in i-direction require a specific treatment. We gather + !! the 4+kextj northern lines of the global domain on 1 + !! processor and apply lbc north-fold on this sub array. + !! Then we scatter the north fold array back to the processors. + !! This routine accounts for an extra halo with icebergs + !! and assumes ghost rows and columns have been suppressed. + !! + !!---------------------------------------------------------------------- + + SUBROUTINE mpp_lbc_north_icb_sp( pt2d, cd_type, psgn, kextj) + !!--------------------------------------------------------------------- + !! *** routine mpp_lbc_north_icb *** + !! + !! ** Purpose : Ensure proper north fold horizontal bondary condition + !! in mpp configuration in case of jpn1 > 1 and for 2d + !! array with outer extra halo + !! + !! ** Method : North fold condition and mpp with more than one proc + !! in i-direction require a specific treatment. We gather + !! the 4+kextj northern lines of the global domain on 1 + !! processor and apply lbc north-fold on this sub array. + !! Then we scatter the north fold array back to the processors. + !! This routine accounts for an extra halo with icebergs + !! and assumes ghost rows and columns have been suppressed. + !! + !!---------------------------------------------------------------------- + REAL(sp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points + ! ! = T , U , V , F or W -points + REAL(sp) , INTENT(in ) :: psgn ! = -1. the sign change across the + !! ! north fold, = 1. otherwise + INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold + ! + INTEGER :: ji, jj, jr + INTEGER :: ierr, itaille + INTEGER :: ipj, ij, iproc, ijnr, ii1, ipi, impp + ! + REAL(sp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e + REAL(sp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e + !!---------------------------------------------------------------------- + ! + ipj=4 + ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & + & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & + & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,ndim_rank_north) ) + ! + ztab_e(:,:) = 0._sp + znorthloc_e(:,:) = 0._sp + ! + ij = 1 - kextj + ! put the last ipj+2*kextj lines of pt2d into znorthloc_e + DO jj = jpj - ipj + 1 - kextj , jpj + kextj + znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) + ij = ij + 1 + END DO + ! + itaille = jpimax * ( ipj + 2*kextj ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_REAL, & + & znorthgloio_e(1,1-kextj,1), itaille, MPI_REAL, & + & ncomm_north, ierr ) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ijnr = 0 + DO jr = 1, ndim_rank_north ! recover the global north array + iproc = nfproc(jr) + IF( iproc /= -1 ) THEN + impp = nfimpp(jr) + ipi = nfjpi(jr) + ijnr = ijnr + 1 + DO jj = 1-kextj, ipj+kextj + DO ji = 1, ipi + ii1 = impp + ji - 1 ! corresponds to mig(ji) but for subdomain iproc + ztab_e(ii1,jj) = znorthgloio_e(ji,jj,ijnr) + END DO + END DO + ENDIF + END DO + + ! 2. North-Fold boundary conditions + ! ---------------------------------- + CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) + + ij = 1 - kextj + !! Scatter back to pt2d + DO jj = jpj - ipj + 1 - kextj , jpj + kextj + DO ji= 1, jpi + pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) + END DO + ij = ij +1 + END DO + ! + DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) + ! + END SUBROUTINE mpp_lbc_north_icb_sp + + + SUBROUTINE mpp_lbc_north_icb_dp( pt2d, cd_type, psgn, kextj) + !!--------------------------------------------------------------------- + !! *** routine mpp_lbc_north_icb *** + !! + !! ** Purpose : Ensure proper north fold horizontal bondary condition + !! in mpp configuration in case of jpn1 > 1 and for 2d + !! array with outer extra halo + !! + !! ** Method : North fold condition and mpp with more than one proc + !! in i-direction require a specific treatment. We gather + !! the 4+kextj northern lines of the global domain on 1 + !! processor and apply lbc north-fold on this sub array. + !! Then we scatter the north fold array back to the processors. + !! This routine accounts for an extra halo with icebergs + !! and assumes ghost rows and columns have been suppressed. + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points + ! ! = T , U , V , F or W -points + REAL(dp) , INTENT(in ) :: psgn ! = -1. the sign change across the + !! ! north fold, = 1. otherwise + INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold + ! + INTEGER :: ji, jj, jr + INTEGER :: ierr, itaille + INTEGER :: ipj, ij, iproc, ijnr, ii1, ipi, impp + ! + REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e + !!---------------------------------------------------------------------- + ! + ipj=4 + ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & + & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & + & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,ndim_rank_north) ) + ! + ztab_e(:,:) = 0._dp + znorthloc_e(:,:) = 0._dp + ! + ij = 1 - kextj + ! put the last ipj+2*kextj lines of pt2d into znorthloc_e + DO jj = jpj - ipj + 1 - kextj , jpj + kextj + znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) + ij = ij + 1 + END DO + ! + itaille = jpimax * ( ipj + 2*kextj ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, & + & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, & + & ncomm_north, ierr ) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ijnr = 0 + DO jr = 1, ndim_rank_north ! recover the global north array + iproc = nfproc(jr) + IF( iproc /= -1 ) THEN + impp = nfimpp(jr) + ipi = nfjpi(jr) + ijnr = ijnr + 1 + DO jj = 1-kextj, ipj+kextj + DO ji = 1, ipi + ii1 = impp + ji - 1 ! corresponds to mig(ji) but for subdomain iproc + ztab_e(ii1,jj) = znorthgloio_e(ji,jj,ijnr) + END DO + END DO + ENDIF + END DO + + ! 2. North-Fold boundary conditions + ! ---------------------------------- + CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) + + ij = 1 - kextj + !! Scatter back to pt2d + DO jj = jpj - ipj + 1 - kextj , jpj + kextj + DO ji= 1, jpi + pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) + END DO + ij = ij +1 + END DO + ! + DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) + ! + END SUBROUTINE mpp_lbc_north_icb_dp + + + + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_2d_icb *** + !! + !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) + !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) + !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! jpi : first dimension of the local subdomain + !! jpj : second dimension of the local subdomain + !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) + !!---------------------------------------------------------------------- + + + SUBROUTINE mpp_lnk_2d_icb_sp( cdname, pt2d, cd_type, psgn, kexti, kextj ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_2d_icb *** + !! + !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) + !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) + !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! jpi : first dimension of the local subdomain + !! jpj : second dimension of the local subdomain + !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) + !! kexti : number of columns for extra outer halo + !! kextj : number of rows for extra outer halo + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(sp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points + REAL(sp) , INTENT(in ) :: psgn ! sign used across the north fold + INTEGER , INTENT(in ) :: kexti ! extra i-halo width + INTEGER , INTENT(in ) :: kextj ! extra j-halo width + ! + INTEGER :: jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! local integers + INTEGER :: ipreci, iprecj ! - - + INTEGER :: ml_req1, ml_req2, ml_err ! for mpi_isend + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend + !! + REAL(sp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn + REAL(sp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew + !!---------------------------------------------------------------------- + ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area + iprecj = nn_hls + kextj + + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) + + ! 1. standard boundary treatment + ! ------------------------------ + ! Order matters Here !!!! + ! + ! ! East-West boundaries + ! !* Cyclic east-west + IF( l_Iperio ) THEN + pt2d(1-kexti: 1 ,:) = pt2d(jpi-1-kexti: jpi-1 ,:) ! east + pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west + ! + ELSE !* closed + IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._sp ! east except at F-point + pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._sp ! west + ENDIF + ! ! North-South boundaries + IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) + pt2d(:,1-kextj: 1 ) = pt2d(:,jpj-1-kextj: jpj-1) ! north + pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south + ELSE !* closed + IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._sp ! north except at F-point + pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._sp ! south + ENDIF + ! + + ! north fold treatment + ! ----------------------- + IF( l_IdoNFold ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) + CASE DEFAULT ; CALL mpp_lbc_north_icb_sp ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) + END SELECT + ! + ENDIF + + ! 2. East and west directions exchange + ! ------------------------------------ + ! we play with the neigbours AND the row number because of the periodicity + ! + IF( mpinei(jpwe) >= 0 .OR. mpinei(jpea) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) + iihom = jpi - (2 * nn_hls) -kexti + DO jl = 1, ipreci + r2dew(:,jl,1) = pt2d(nn_hls+jl,:) + r2dwe(:,jl,1) = pt2d(iihom +jl,:) + END DO + ENDIF + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*kextj ) + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*kextj ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + IF( mpinei(jpwe) >= 0 ) CALL mppsend_sp( 1, r2dew(1-kextj,1,1), imigr, mpinei(jpwe), ml_req1 ) + IF( mpinei(jpea) >= 0 ) CALL mppsend_sp( 2, r2dwe(1-kextj,1,1), imigr, mpinei(jpea), ml_req2 ) + IF( mpinei(jpwe) >= 0 ) CALL mpprecv_sp( 2, r2dwe(1-kextj,1,2), imigr, mpinei(jpwe) ) + IF( mpinei(jpea) >= 0 ) CALL mpprecv_sp( 1, r2dew(1-kextj,1,2), imigr, mpinei(jpea) ) + IF( mpinei(jpwe) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF( mpinei(jpea) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ! Write Dirichlet lateral conditions + iihom = jpi - nn_hls + IF( mpinei(jpwe) >= 0 ) THEN + DO jl = 1, ipreci + pt2d(jl-kexti,:) = r2dwe(:,jl,2) + END DO + ENDIF + IF( mpinei(jpea) >= 0 ) THEN + DO jl = 1, ipreci + pt2d(iihom+jl,:) = r2dew(:,jl,2) + END DO + ENDIF + + ! 3. North and south directions + ! ----------------------------- + ! always closed : we play only with the neigbours + ! + IF( mpinei(jpso) >= 0 .OR. mpinei(jpno) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) + ijhom = jpj - (2 * nn_hls) - kextj + DO jl = 1, iprecj + r2dsn(:,jl,1) = pt2d(:,ijhom +jl) + r2dns(:,jl,1) = pt2d(:,nn_hls+jl) + END DO + ENDIF + ! + ! ! Migrations + imigr = iprecj * ( jpi + 2*kexti ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + IF( mpinei(jpso) >= 0 ) CALL mppsend_sp( 3, r2dns(1-kexti,1,1), imigr, mpinei(jpso), ml_req1 ) + IF( mpinei(jpno) >= 0 ) CALL mppsend_sp( 4, r2dsn(1-kexti,1,1), imigr, mpinei(jpno), ml_req2 ) + IF( mpinei(jpso) >= 0 ) CALL mpprecv_sp( 4, r2dsn(1-kexti,1,2), imigr, mpinei(jpso) ) + IF( mpinei(jpno) >= 0 ) CALL mpprecv_sp( 3, r2dns(1-kexti,1,2), imigr, mpinei(jpno) ) + IF( mpinei(jpso) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF( mpinei(jpno) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ! Write Dirichlet lateral conditions + ijhom = jpj - nn_hls + ! + IF( mpinei(jpso) >= 0 ) THEN + DO jl = 1, iprecj + pt2d(:,jl-kextj) = r2dsn(:,jl,2) + END DO + ENDIF + IF( mpinei(jpno) >= 0 ) THEN + DO jl = 1, iprecj + pt2d(:,ijhom+jl) = r2dns(:,jl,2) + END DO + ENDIF + ! + END SUBROUTINE mpp_lnk_2d_icb_sp + + + SUBROUTINE mpp_lnk_2d_icb_dp( cdname, pt2d, cd_type, psgn, kexti, kextj ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_2d_icb *** + !! + !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) + !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) + !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! jpi : first dimension of the local subdomain + !! jpj : second dimension of the local subdomain + !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) + !! kexti : number of columns for extra outer halo + !! kextj : number of rows for extra outer halo + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points + REAL(dp) , INTENT(in ) :: psgn ! sign used across the north fold + INTEGER , INTENT(in ) :: kexti ! extra i-halo width + INTEGER , INTENT(in ) :: kextj ! extra j-halo width + ! + INTEGER :: jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! local integers + INTEGER :: ipreci, iprecj ! - - + INTEGER :: ml_req1, ml_req2, ml_err ! for mpi_isend + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend + !! + REAL(dp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn + REAL(dp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew + !!---------------------------------------------------------------------- + ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area + iprecj = nn_hls + kextj + + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) + + ! 1. standard boundary treatment + ! ------------------------------ + ! Order matters Here !!!! + ! + ! ! East-West boundaries + ! !* Cyclic east-west + IF( l_Iperio ) THEN + pt2d(1-kexti: 1 ,:) = pt2d(jpi-1-kexti: jpi-1 ,:) ! east + pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west + ! + ELSE !* closed + IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._dp ! east except at F-point + pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._dp ! west + ENDIF + ! ! North-South boundaries + IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) + pt2d(:,1-kextj: 1 ) = pt2d(:,jpj-1-kextj: jpj-1) ! north + pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south + ELSE !* closed + IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._dp ! north except at F-point + pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._dp ! south + ENDIF + ! + + ! north fold treatment + ! ----------------------- + IF( l_IdoNFold ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) + CASE DEFAULT ; CALL mpp_lbc_north_icb_dp ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) + END SELECT + ! + ENDIF + + ! 2. East and west directions exchange + ! ------------------------------------ + ! we play with the neigbours AND the row number because of the periodicity + ! + IF( mpinei(jpwe) >= 0 .OR. mpinei(jpea) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) + iihom = jpi - (2 * nn_hls) -kexti + DO jl = 1, ipreci + r2dew(:,jl,1) = pt2d(nn_hls+jl,:) + r2dwe(:,jl,1) = pt2d(iihom +jl,:) + END DO + ENDIF + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*kextj ) + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*kextj ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + IF( mpinei(jpwe) >= 0 ) CALL mppsend_dp( 1, r2dew(1-kextj,1,1), imigr, mpinei(jpwe), ml_req1 ) + IF( mpinei(jpea) >= 0 ) CALL mppsend_dp( 2, r2dwe(1-kextj,1,1), imigr, mpinei(jpea), ml_req2 ) + IF( mpinei(jpwe) >= 0 ) CALL mpprecv_dp( 2, r2dwe(1-kextj,1,2), imigr, mpinei(jpwe) ) + IF( mpinei(jpea) >= 0 ) CALL mpprecv_dp( 1, r2dew(1-kextj,1,2), imigr, mpinei(jpea) ) + IF( mpinei(jpwe) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF( mpinei(jpea) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ! Write Dirichlet lateral conditions + iihom = jpi - nn_hls + IF( mpinei(jpwe) >= 0 ) THEN + DO jl = 1, ipreci + pt2d(jl-kexti,:) = r2dwe(:,jl,2) + END DO + ENDIF + IF( mpinei(jpea) >= 0 ) THEN + DO jl = 1, ipreci + pt2d(iihom+jl,:) = r2dew(:,jl,2) + END DO + ENDIF + + ! 3. North and south directions + ! ----------------------------- + ! always closed : we play only with the neigbours + ! + IF( mpinei(jpso) >= 0 .OR. mpinei(jpno) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) + ijhom = jpj - (2 * nn_hls) - kextj + DO jl = 1, iprecj + r2dsn(:,jl,1) = pt2d(:,ijhom +jl) + r2dns(:,jl,1) = pt2d(:,nn_hls+jl) + END DO + ENDIF + ! + ! ! Migrations + imigr = iprecj * ( jpi + 2*kexti ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + IF( mpinei(jpso) >= 0 ) CALL mppsend_dp( 3, r2dns(1-kexti,1,1), imigr, mpinei(jpso), ml_req1 ) + IF( mpinei(jpno) >= 0 ) CALL mppsend_dp( 4, r2dsn(1-kexti,1,1), imigr, mpinei(jpno), ml_req2 ) + IF( mpinei(jpso) >= 0 ) CALL mpprecv_dp( 4, r2dsn(1-kexti,1,2), imigr, mpinei(jpso) ) + IF( mpinei(jpno) >= 0 ) CALL mpprecv_dp( 3, r2dns(1-kexti,1,2), imigr, mpinei(jpno) ) + IF( mpinei(jpso) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF( mpinei(jpno) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ! Write Dirichlet lateral conditions + ijhom = jpj - nn_hls + ! + IF( mpinei(jpso) >= 0 ) THEN + DO jl = 1, iprecj + pt2d(:,jl-kextj) = r2dsn(:,jl,2) + END DO + ENDIF + IF( mpinei(jpno) >= 0 ) THEN + DO jl = 1, iprecj + pt2d(:,ijhom+jl) = r2dns(:,jl,2) + END DO + ENDIF + ! + END SUBROUTINE mpp_lnk_2d_icb_dp + + +END MODULE lbclnk diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lbcnfd.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lbcnfd.f90 new file mode 100644 index 0000000000000000000000000000000000000000..af50b4ccb8ea12664e2b40da54dab7aebdf81740 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lbcnfd.f90 @@ -0,0 +1,1894 @@ + + + + + + + + + + + + + +MODULE lbcnfd + !!====================================================================== + !! *** MODULE lbcnfd *** + !! Ocean : north fold boundary conditions + !!====================================================================== + !! History : 3.2 ! 2009-03 (R. Benshila) Original code + !! 3.5 ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization + !! 4.0 ! 2017-04 (G. Madec) automatique allocation of array argument (use any 3rd dimension) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! lbc_nfd : generic interface for lbc_nfd_sp and lbc_nfd_dp routines that is doing the north fold in a non-mpi case + !! mpp_nfd : generic interface for mpp_nfd_sp and mpp_nfd_dp routines that will use lbc_nfd directly or indirectly + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE MPI + + IMPLICIT NONE + PRIVATE + + INTERFACE lbc_nfd ! called by mpp_nfd, lbc_lnk_pt2pt or lbc_lnk_neicoll + MODULE PROCEDURE lbc_nfd_sp, lbc_nfd_ext_sp + MODULE PROCEDURE lbc_nfd_dp, lbc_nfd_ext_dp + END INTERFACE + + INTERFACE mpp_nfd ! called by lbc_lnk_pt2pt or lbc_lnk_neicoll + MODULE PROCEDURE mpp_nfd_sp, mpp_nfd_dp + END INTERFACE + + PUBLIC mpp_nfd ! mpi north fold conditions + PUBLIC lbc_nfd ! north fold conditions + + INTEGER, PUBLIC :: nfd_nbnei + INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (: ) :: nfd_rknei + INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_rksnd + INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_jisnd + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lbcnfd.F90 15267 2021-09-17 09:04:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + !!---------------------------------------------------------------------- + !! *** routine lbc_nfd_[sd]p *** + !! *** routine lbc_nfd_ext_[sd]p *** + !!---------------------------------------------------------------------- + !! + !! ** Purpose : lateral boundary condition + !! North fold treatment without processor exchanges. + !! + !! ** Method : + !! + !! ** Action : ptab with updated values along the north fold + !!---------------------------------------------------------------------- + ! + ! !== SINGLE PRECISION VERSIONS + ! +SUBROUTINE lbc_nfd_sp( ptab, cd_nat, psgn, khls, kfld ) + TYPE(PTR_4d_sp), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(sp), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + ! + INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ii1, ii2, ij1, ij2 + !!---------------------------------------------------------------------- + ! + ipi = SIZE(ptab(1)%pt4d,1) + ipj = SIZE(ptab(1)%pt4d,2) + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( ipi /= Ni0glo+2*khls ) THEN + WRITE(ctmp1,*) 'lbc_nfd input array does not match khls', ipi, khls, Ni0glo + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + ! + DO jf = 1, ipf ! Loop on the number of arrays to be treated + ! + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + ! + SELECT CASE ( cd_nat(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls+1 + ii1 = khls + ji + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + 1 + ii1 = ipi - khls + ji + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! last khls-1 points + ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi + ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - khls - 1) + 1 = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls - 1) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls-1 points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'U' ) ! U-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls-1 points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'V' ) ! V-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls+1 lines (from ipj to ipj-khls) : full + DO jj = 1, khls+1 + ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls + ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls+1 + ii1 = khls + ji + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + 1 + ii1 = ipi - khls + ji + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! last khls-1 points + ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi + ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'F' ) ! F-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls+1 lines (from ipj to ipj-khls) : full + DO jj = 1, khls+1 + ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls + ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + END SELECT ! cd_nat(jf) + ! + ENDIF ! c_NFtype == 'T' + ! + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + ! + SELECT CASE ( cd_nat(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! first: line number ipj-khls : 3 points + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, 1 ! points from ipi/2+1 + ii1 = ipi/2 + ji + ii2 = ipi/2 - ji + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + DO ji = 1, 1 ! points ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + DO ji = 1, 1 ! point khls: redo it just in case (if e-w periodocity already done) + ! ! as we just changed point ipi - khls + ii1 = khls + ji - 1 + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + END DO + ! + ! Second: last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls + ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'U' ) ! U-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls + ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls + ! + DO ji = 1, khls-1 ! first khls-1 points + ii1 = ji ! ends at: khls-1 + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls + ii1 = khls + ji - 1 + ii2 = ipi - ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 + ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'V' ) ! V-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'F' ) ! F-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls-1 ! first khls-1 points + ii1 = ji ! ends at: khls-1 + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls + ii1 = khls + ji - 1 + ii2 = ipi - ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 + ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - khls-1 (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! first khls-1 points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-nn_hl-1 + ii1 = ji ! ends at: khls + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + END SELECT ! cd_nat(jf) + ! + ENDIF ! c_NFtype == 'F' + ! + END DO ! ipf + ! + END SUBROUTINE lbc_nfd_sp +SUBROUTINE lbc_nfd_ext_sp( ptab, cd_nat, psgn, kextj ) + !!---------------------------------------------------------------------- + REAL(sp), DIMENSION(:,1-kextj:),INTENT(inout) :: ptab + CHARACTER(len=1), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(sp), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER, INTENT(in ) :: kextj ! extra halo width at north fold + ! + INTEGER :: ji, jj, jh ! dummy loop indices + INTEGER :: ipj + INTEGER :: ijt, iju, ipjm1 + !!---------------------------------------------------------------------- + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; ipj = jpj ! 1 proc only along the i-direction + CASE DEFAULT ; ipj = 4 ! several proc along the i-direction + END SELECT + ! + ipjm1 = ipj-1 + ! + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + ! + SELECT CASE ( cd_nat ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jh = 0, kextj + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) + END DO + ptab(1,ipj+jh) = psgn * ptab(3,ipj-2-jh) + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) + END DO + CASE ( 'U' ) ! U-point + DO jh = 0, kextj + DO ji = 2, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-2-jh) + END DO + ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-2-jh) + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-2-jh) + END DO + DO ji = jpiglo/2, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) + END DO + CASE ( 'V' ) ! V-point + DO jh = 0, kextj + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipj-1+jh) = psgn * ptab(ijt,ipj-2-jh) + ptab(ji,ipj+jh ) = psgn * ptab(ijt,ipj-3-jh) + END DO + ptab(1,ipj+jh) = psgn * ptab(3,ipj-3-jh) + END DO + CASE ( 'F' ) ! F-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipj-1+jh) = psgn * ptab(iju,ipj-2-jh) + ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-3-jh) + END DO + END DO + DO jh = 0, kextj + ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-3-jh) + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-3-jh) + END DO + END SELECT + ! + ENDIF ! c_NFtype == 'T' + ! + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + ! + SELECT CASE ( cd_nat ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jh = 0, kextj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-1-jh) + END DO + END DO + CASE ( 'U' ) ! U-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-1-jh) + END DO + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-1-jh) + END DO + CASE ( 'V' ) ! V-point + DO jh = 0, kextj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) + END DO + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) + END DO + CASE ( 'F' ) ! F-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-2-jh) + END DO + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-2-jh) + END DO + DO ji = jpiglo/2+1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) + END DO + END SELECT + ! + ENDIF ! c_NFtype == 'F' + ! + END SUBROUTINE lbc_nfd_ext_sp + ! + ! !== DOUBLE PRECISION VERSIONS + ! +SUBROUTINE lbc_nfd_dp( ptab, cd_nat, psgn, khls, kfld ) + TYPE(PTR_4d_dp), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(dp), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + ! + INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ii1, ii2, ij1, ij2 + !!---------------------------------------------------------------------- + ! + ipi = SIZE(ptab(1)%pt4d,1) + ipj = SIZE(ptab(1)%pt4d,2) + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( ipi /= Ni0glo+2*khls ) THEN + WRITE(ctmp1,*) 'lbc_nfd input array does not match khls', ipi, khls, Ni0glo + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + ! + DO jf = 1, ipf ! Loop on the number of arrays to be treated + ! + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + ! + SELECT CASE ( cd_nat(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls+1 + ii1 = khls + ji + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + 1 + ii1 = ipi - khls + ji + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! last khls-1 points + ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi + ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - khls - 1) + 1 = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls - 1) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls-1 points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'U' ) ! U-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls-1 points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'V' ) ! V-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls+1 lines (from ipj to ipj-khls) : full + DO jj = 1, khls+1 + ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls + ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls+1 + ii1 = khls + ji + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + 1 + ii1 = ipi - khls + ji + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! last khls-1 points + ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi + ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'F' ) ! F-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls+1 lines (from ipj to ipj-khls) : full + DO jj = 1, khls+1 + ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls + ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + END SELECT ! cd_nat(jf) + ! + ENDIF ! c_NFtype == 'T' + ! + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + ! + SELECT CASE ( cd_nat(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! first: line number ipj-khls : 3 points + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, 1 ! points from ipi/2+1 + ii1 = ipi/2 + ji + ii2 = ipi/2 - ji + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + DO ji = 1, 1 ! points ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + DO ji = 1, 1 ! point khls: redo it just in case (if e-w periodocity already done) + ! ! as we just changed point ipi - khls + ii1 = khls + ji - 1 + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + END DO + ! + ! Second: last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls + ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'U' ) ! U-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls + ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls + ! + DO ji = 1, khls-1 ! first khls-1 points + ii1 = ji ! ends at: khls-1 + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls + ii1 = khls + ji - 1 + ii2 = ipi - ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 + ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'V' ) ! V-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'F' ) ! F-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls-1 ! first khls-1 points + ii1 = ji ! ends at: khls-1 + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls + ii1 = khls + ji - 1 + ii2 = ipi - ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 + ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - khls-1 (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! first khls-1 points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-nn_hl-1 + ii1 = ji ! ends at: khls + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + END SELECT ! cd_nat(jf) + ! + ENDIF ! c_NFtype == 'F' + ! + END DO ! ipf + ! + END SUBROUTINE lbc_nfd_dp +SUBROUTINE lbc_nfd_ext_dp( ptab, cd_nat, psgn, kextj ) + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,1-kextj:),INTENT(inout) :: ptab + CHARACTER(len=1), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(dp), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER, INTENT(in ) :: kextj ! extra halo width at north fold + ! + INTEGER :: ji, jj, jh ! dummy loop indices + INTEGER :: ipj + INTEGER :: ijt, iju, ipjm1 + !!---------------------------------------------------------------------- + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; ipj = jpj ! 1 proc only along the i-direction + CASE DEFAULT ; ipj = 4 ! several proc along the i-direction + END SELECT + ! + ipjm1 = ipj-1 + ! + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + ! + SELECT CASE ( cd_nat ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jh = 0, kextj + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) + END DO + ptab(1,ipj+jh) = psgn * ptab(3,ipj-2-jh) + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) + END DO + CASE ( 'U' ) ! U-point + DO jh = 0, kextj + DO ji = 2, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-2-jh) + END DO + ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-2-jh) + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-2-jh) + END DO + DO ji = jpiglo/2, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) + END DO + CASE ( 'V' ) ! V-point + DO jh = 0, kextj + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipj-1+jh) = psgn * ptab(ijt,ipj-2-jh) + ptab(ji,ipj+jh ) = psgn * ptab(ijt,ipj-3-jh) + END DO + ptab(1,ipj+jh) = psgn * ptab(3,ipj-3-jh) + END DO + CASE ( 'F' ) ! F-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipj-1+jh) = psgn * ptab(iju,ipj-2-jh) + ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-3-jh) + END DO + END DO + DO jh = 0, kextj + ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-3-jh) + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-3-jh) + END DO + END SELECT + ! + ENDIF ! c_NFtype == 'T' + ! + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + ! + SELECT CASE ( cd_nat ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jh = 0, kextj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-1-jh) + END DO + END DO + CASE ( 'U' ) ! U-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-1-jh) + END DO + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-1-jh) + END DO + CASE ( 'V' ) ! V-point + DO jh = 0, kextj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) + END DO + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) + END DO + CASE ( 'F' ) ! F-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-2-jh) + END DO + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-2-jh) + END DO + DO ji = jpiglo/2+1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) + END DO + END SELECT + ! + ENDIF ! c_NFtype == 'F' + ! + END SUBROUTINE lbc_nfd_ext_dp + + !!====================================================================== + ! + !!---------------------------------------------------------------------- + !! *** routine mpp_nfd_[sd]p *** + !! + !! * Argument : dummy argument use in mpp_nfd_... routines + !! ptab : pointer of arrays on which the boundary condition is applied + !! cd_nat : nature of array grid-points + !! psgn : sign used across the north fold boundary + !! kfld : optional, number of pt3d arrays + !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) + !! pfillval : optional, background value (used with jpfillcopy) + !!---------------------------------------------------------------------- + !! + !! ---- SINGLE PRECISION VERSIONS + !! +SUBROUTINE mpp_nfd_sp( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld ) + TYPE(PTR_4d_sp), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(sp), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land + REAL(sp) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + ! + LOGICAL :: ll_add_line + INTEGER :: ji, jj, jk, jl, jf, jr, jg, jn ! dummy loop indices + INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ierr, ibuffsize, iis0, iie0, impp + INTEGER :: ii1, ii2, ij1, ij2, iis, iie, iib, iig, iin + INTEGER :: i0max + INTEGER :: ij, iproc, ipni, ijnr + INTEGER, DIMENSION (:), ALLOCATABLE :: ireq_s, ireq_r ! for mpi_isend when avoiding mpi_allgather + INTEGER :: ipjtot ! sum of lines for all multi fields + INTEGER :: i012 ! 0, 1 or 2 + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijsnd ! j-position of sent lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijbuf ! j-position of send buffer lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijrcv ! j-position of recv buffer lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ii1st, iiend + INTEGER , DIMENSION(:) , ALLOCATABLE :: ipjfld ! number of sent lines for each field + REAL(sp), DIMENSION(:,:,:,:) , ALLOCATABLE :: zbufs ! buffer, receive and work arrays + REAL(sp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: zbufr ! buffer, receive and work arrays + REAL(sp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc + REAL(sp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo + TYPE(PTR_4D_sp), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c. + !!---------------------------------------------------------------------- + ! + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( ln_nnogather ) THEN !== no allgather exchanges ==! + + ! --- define number of exchanged lines --- + ! + ! In theory we should exchange only nn_hls lines. + ! + ! However, some other points are duplicated in the north pole folding: + ! - c_NFtype='T', grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) + ! - c_NFtype='T', grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) + ! - c_NFtype='T', grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) + ! - c_NFtype='T', grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) + ! - c_NFtype='F', grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) + ! - c_NFtype='F', grid=U : no points are duplicated + ! - c_NFtype='F', grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) + ! - c_NFtype='F', grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) + ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) + ! This explain why these duplicated points may have different values even if they are at the exact same location. + ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. + ! This is slightly slower but necessary to avoid different values on identical grid points!! + ! + !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! + !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!! + !!!!!!!!! I don't know why we must do that... !!!!!!!! + l_full_nf_update = .TRUE. + ! also force it if not restart during the first 2 steps (leap frog?) + ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) + + ALLOCATE(ipjfld(ipf)) ! how many lines do we exchange for each field? + IF( ll_add_line ) THEN + DO jf = 1, ipf ! Loop over the number of arrays to be processed + ipjfld(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) + END DO + ELSE + ipjfld(:) = khls + ENDIF + + ipj = MAXVAL(ipjfld(:)) ! Max 2nd dimension of message transfers + ipjtot = SUM( ipjfld(:)) ! Total number of lines to be exchanged + + ! Index of modifying lines in input + ALLOCATE( ijsnd(ipj, ipf), ijbuf(ipj, ipf), ijrcv(ipj, ipf), ii1st(ipj, ipf), iiend(ipj, ipf) ) + + ij1 = 0 + DO jf = 1, ipf ! Loop over the number of arrays to be processed + ! + DO jj = 1, khls ! first khls lines (starting from top) must be fully defined + ii1st(jj, jf) = 1 + iiend(jj, jf) = jpi + END DO + ! + ! what do we do with line khls+1 (starting from top) + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + SELECT CASE ( cd_nat(jf) ) + CASE ('T','W') ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+2) ; iiend(khls+1, jf) = mi1(jpiglo-khls) + CASE ('U' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls) + CASE ('V' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi + CASE ('F' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi + END SELECT + ENDIF + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + SELECT CASE ( cd_nat(jf) ) + CASE ('T','W') ; i012 = 0 ! we don't touch line khls+1 + CASE ('U' ) ; i012 = 0 ! we don't touch line khls+1 + CASE ('V' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls ) + CASE ('F' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls-1) + END SELECT + ENDIF + ! + DO jj = 1, ipjfld(jf) + ij1 = ij1 + 1 + ijsnd(jj,jf) = jpj - 2*khls + jj - i012 ! sent lines (from bottom of sent lines) + ijbuf(jj,jf) = ij1 ! gather all lines in the snd/rcv buffers + ijrcv(jj,jf) = jpj - jj + 1 ! recv lines (from the top -> reverse order for jj) + END DO + ! + END DO + ! + i0max = jpimax - 2 * khls ! we are not sending the halos + ALLOCATE( zbufs(i0max,ipjtot,ipk,ipl), ireq_s(nfd_nbnei) ) ! store all the data to be sent in a buffer array + ibuffsize = i0max * ipjtot * ipk * ipl + ! + ! fill the send buffer with all the lines + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) + DO ji = Nis0, Nie0 ! should not use any other value + iib = ji - Nis0 + 1 + zbufs(iib,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) + END DO + DO ji = Ni_0+1, i0max ! avoid sending uninitialized values (make sure we don't use it) + zbufs(ji,ij1,jk,jl) = HUGE(0._sp) ! make sure we don't use it... + END DO + END DO + END DO ; END DO ; END DO + ! + ! start waiting time measurement + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + ! send the same buffer data to all neighbourgs as soon as possible + DO jn = 1, nfd_nbnei + iproc = nfd_rknei(jn) + IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN + CALL MPI_Isend( zbufs, ibuffsize, MPI_REAL, iproc, 5, mpi_comm_oce, ireq_s(jn), ierr ) + ELSE + ireq_s(jn) = MPI_REQUEST_NULL + ENDIF + END DO + ! + ALLOCATE( zbufr(i0max,ipjtot,ipk,ipl,nfd_nbnei), ireq_r(nfd_nbnei) ) + ! + DO jn = 1, nfd_nbnei + ! + iproc = nfd_rknei(jn) + ! + IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) + ! + ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received + zbufr(:,:,:,:,jn) = HUGE(0._sp) ! default: define it and make sure we don't use it... + SELECT CASE ( kfillmode ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) ! we will use only the first value, see init_nfdcom + zbufr(1,ij1,jk,jl,jn) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point + END DO + END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + zbufr(1,:,:,:,jn) = pfillval ! we will use only the first value, see init_nfdcom + END SELECT + ! + ELSE IF( iproc == narea-1 ) THEN ! get data from myself! + ! + ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) + DO ji = Nis0, Nie0 ! should not use any other value + iib = ji - Nis0 + 1 + zbufr(iib,ij1,jk,jl,jn) = ptab(jf)%pt4d(ji,ij2,jk,jl) + END DO + END DO + END DO ; END DO ; END DO + ! + ELSE ! get data from a neighbour trough communication + CALL MPI_Irecv( zbufr(:,:,:,:,jn), ibuffsize, MPI_REAL, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr ) + ENDIF + ! + END DO ! nfd_nbnei + ! + CALL mpi_waitall(nfd_nbnei, ireq_r, MPI_STATUSES_IGNORE, ierr) ! wait for all Irecv + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! North fold boundary condition + ! + DO jf = 1, ipf + ! + SELECT CASE ( cd_nat(jf) ) ! which grid number? + CASE ('T','W') ; iig = 1 ! T-, W-point + CASE ('U') ; iig = 2 ! U-point + CASE ('V') ; iig = 3 ! V-point + CASE ('F') ; iig = 4 ! F-point + END SELECT + ! + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! if T point with F-point pivot : must be done first + ! --> specific correction of 3 points near the 2 pivots (to be clean, usually masked -> so useless) + IF( c_NFtype == 'F' .AND. iig == 1 ) THEN + ij1 = jpj - khls ! j-index in the receiving array + ij2 = 1 ! only 1 line in the buffer + DO ji = mi0(khls), mi1(khls) ! change because of EW periodicity as we also change jpiglo-khls + iib = nfd_jisnd(mi0( khls),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0( khls),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + DO ji = mi0(jpiglo/2+1), mi1(jpiglo/2+1) + iib = nfd_jisnd(mi0( jpiglo/2+1),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0( jpiglo/2+1),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + DO ji = mi0(jpiglo-khls), mi1(jpiglo-khls) + iib = nfd_jisnd(mi0(jpiglo-khls),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0(jpiglo-khls),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + ENDIF + ! + ! Apply the North pole folding. + DO jj = 1, ipjfld(jf) ! for all lines to be exchanged for this field + ij1 = ijrcv(jj,jf) ! j-index in the receiving array + ij2 = ijbuf(jj,jf) ! j-index in the buffer + iis = ii1st(jj,jf) ! stating i-index in the receiving array + iie = iiend(jj,jf) ! ending i-index in the receiving array + DO ji = iis, iie + iib = nfd_jisnd(ji,iig) ! i-index in the buffer + iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) + END DO + END DO + ! + ! re-apply periodocity when we modified the eastern side of the inner domain (and not the full line) + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + IF( iig <= 2 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'T','W','U': update west halo + ELSE ; iis = 1 ; iie = 0 ! 'V','F' : full line already exchanged + ENDIF + ENDIF + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + IF( iig <= 2 ) THEN ; iis = 1 ; iie = 0 ! 'T','W','U': nothing to do + ELSEIF( iig == 3 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'V' : update west halo + ELSEIF( khls > 1 ) THEN ; iis = mi0(1) ; iie = mi1(khls-1) ! 'F' and khls > 1 + ELSE ; iis = 1 ; iie = 0 ! 'F' and khls == 1 : nothing to do + ENDIF + ENDIF + jj = ipjfld(jf) ! only for the last line of this field + ij1 = ijrcv(jj,jf) ! j-index in the receiving array + ij2 = ijbuf(jj,jf) ! j-index in the buffer + DO ji = iis, iie + iib = nfd_jisnd(ji,iig) ! i-index in the buffer + iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) + END DO + ! + END DO ; END DO ! ipl ; ipk + ! + END DO ! ipf + + ! + DEALLOCATE( zbufr, ireq_r, ijsnd, ijbuf, ijrcv, ii1st, iiend, ipjfld ) + ! + CALL mpi_waitall(nfd_nbnei, ireq_s, MPI_STATUSES_IGNORE, ierr) ! wait for all Isend + ! + DEALLOCATE( zbufs, ireq_s ) + ! + ELSE !== allgather exchanges ==! + ! + ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) + ipj = khls + 2 + ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) + ipj2 = 2 * khls + 2 + ! + i0max = jpimax - 2 * khls + ibuffsize = i0max * ipj * ipk * ipl * ipf + ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) + ! + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab + DO jj = 1, ipj + ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines + DO ji = 1, Ni_0 + ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 + znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = Ni_0+1, i0max + znorthloc(ji,jj,jk,jl,jf) = HUGE(0._sp) ! avoid sending uninitialized values (make sure we don't use it) + END DO + END DO + END DO ; END DO ; END DO + ! + ! start waiting time measurement + IF( ln_timing ) CALL tic_tac(.TRUE.) + CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_REAL, znorthglo, ibuffsize, MPI_REAL, ncomm_north, ierr ) + ! stop waiting time measurement + IF( ln_timing ) CALL tic_tac(.FALSE.) + DEALLOCATE( znorthloc ) + ALLOCATE( ztabglo(ipf) ) + DO jf = 1, ipf + ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) ) + END DO + ! + ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines + ijnr = 0 + DO jr = 1, jpni ! recover the global north array + iproc = nfproc(jr) + impp = nfimpp(jr) + ipi = nfjpi( jr) - 2 * khls ! corresponds to Ni_0 but for subdomain iproc + IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) + ! + SELECT CASE ( kfillmode ) + CASE ( jpfillnothing ) ! no filling + CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F') + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point + END DO + END DO + END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval + END DO + END DO + END DO ; END DO ; END DO + END SELECT + ! + ELSE + ijnr = ijnr + 1 + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr) + END DO + END DO + END DO ; END DO ; END DO + ENDIF + ! + END DO ! jpni + DEALLOCATE( znorthglo ) + ! + DO jf = 1, ipf + CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 ) ! North fold boundary condition + DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity + DO jj = 1, khls + 1 + ij1 = ipj2 - (khls + 1) + jj ! need only the last khls + 1 lines until ipj2 + ztabglo(jf)%pt4d( 1: khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl) + ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( khls+1: 2*khls,ij1,jk,jl) + END DO + END DO ; END DO + END DO + ! + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN + DO jj = 1, khls + 1 + ij1 = jpj - (khls + 1) + jj ! last khls + 1 lines until jpj + ij2 = ipj2 - (khls + 1) + jj ! last khls + 1 lines until ipj2 + DO ji= 1, jpi + ii2 = mig(ji) + ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + END DO ; END DO ; END DO + ! + DO jf = 1, ipf + DEALLOCATE( ztabglo(jf)%pt4d ) + END DO + DEALLOCATE( ztabglo ) + ! + ENDIF ! ln_nnogather + ! + END SUBROUTINE mpp_nfd_sp + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +SUBROUTINE mpp_nfd_dp( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld ) + TYPE(PTR_4d_dp), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(dp), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land + REAL(dp) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + ! + LOGICAL :: ll_add_line + INTEGER :: ji, jj, jk, jl, jf, jr, jg, jn ! dummy loop indices + INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ierr, ibuffsize, iis0, iie0, impp + INTEGER :: ii1, ii2, ij1, ij2, iis, iie, iib, iig, iin + INTEGER :: i0max + INTEGER :: ij, iproc, ipni, ijnr + INTEGER, DIMENSION (:), ALLOCATABLE :: ireq_s, ireq_r ! for mpi_isend when avoiding mpi_allgather + INTEGER :: ipjtot ! sum of lines for all multi fields + INTEGER :: i012 ! 0, 1 or 2 + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijsnd ! j-position of sent lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijbuf ! j-position of send buffer lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijrcv ! j-position of recv buffer lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ii1st, iiend + INTEGER , DIMENSION(:) , ALLOCATABLE :: ipjfld ! number of sent lines for each field + REAL(dp), DIMENSION(:,:,:,:) , ALLOCATABLE :: zbufs ! buffer, receive and work arrays + REAL(dp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: zbufr ! buffer, receive and work arrays + REAL(dp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc + REAL(dp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo + TYPE(PTR_4D_dp), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c. + !!---------------------------------------------------------------------- + ! + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( ln_nnogather ) THEN !== no allgather exchanges ==! + + ! --- define number of exchanged lines --- + ! + ! In theory we should exchange only nn_hls lines. + ! + ! However, some other points are duplicated in the north pole folding: + ! - c_NFtype='T', grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) + ! - c_NFtype='T', grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) + ! - c_NFtype='T', grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) + ! - c_NFtype='T', grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) + ! - c_NFtype='F', grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) + ! - c_NFtype='F', grid=U : no points are duplicated + ! - c_NFtype='F', grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) + ! - c_NFtype='F', grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) + ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) + ! This explain why these duplicated points may have different values even if they are at the exact same location. + ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. + ! This is slightly slower but necessary to avoid different values on identical grid points!! + ! + !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! + !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!! + !!!!!!!!! I don't know why we must do that... !!!!!!!! + l_full_nf_update = .TRUE. + ! also force it if not restart during the first 2 steps (leap frog?) + ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) + + ALLOCATE(ipjfld(ipf)) ! how many lines do we exchange for each field? + IF( ll_add_line ) THEN + DO jf = 1, ipf ! Loop over the number of arrays to be processed + ipjfld(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) + END DO + ELSE + ipjfld(:) = khls + ENDIF + + ipj = MAXVAL(ipjfld(:)) ! Max 2nd dimension of message transfers + ipjtot = SUM( ipjfld(:)) ! Total number of lines to be exchanged + + ! Index of modifying lines in input + ALLOCATE( ijsnd(ipj, ipf), ijbuf(ipj, ipf), ijrcv(ipj, ipf), ii1st(ipj, ipf), iiend(ipj, ipf) ) + + ij1 = 0 + DO jf = 1, ipf ! Loop over the number of arrays to be processed + ! + DO jj = 1, khls ! first khls lines (starting from top) must be fully defined + ii1st(jj, jf) = 1 + iiend(jj, jf) = jpi + END DO + ! + ! what do we do with line khls+1 (starting from top) + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + SELECT CASE ( cd_nat(jf) ) + CASE ('T','W') ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+2) ; iiend(khls+1, jf) = mi1(jpiglo-khls) + CASE ('U' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls) + CASE ('V' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi + CASE ('F' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi + END SELECT + ENDIF + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + SELECT CASE ( cd_nat(jf) ) + CASE ('T','W') ; i012 = 0 ! we don't touch line khls+1 + CASE ('U' ) ; i012 = 0 ! we don't touch line khls+1 + CASE ('V' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls ) + CASE ('F' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls-1) + END SELECT + ENDIF + ! + DO jj = 1, ipjfld(jf) + ij1 = ij1 + 1 + ijsnd(jj,jf) = jpj - 2*khls + jj - i012 ! sent lines (from bottom of sent lines) + ijbuf(jj,jf) = ij1 ! gather all lines in the snd/rcv buffers + ijrcv(jj,jf) = jpj - jj + 1 ! recv lines (from the top -> reverse order for jj) + END DO + ! + END DO + ! + i0max = jpimax - 2 * khls ! we are not sending the halos + ALLOCATE( zbufs(i0max,ipjtot,ipk,ipl), ireq_s(nfd_nbnei) ) ! store all the data to be sent in a buffer array + ibuffsize = i0max * ipjtot * ipk * ipl + ! + ! fill the send buffer with all the lines + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) + DO ji = Nis0, Nie0 ! should not use any other value + iib = ji - Nis0 + 1 + zbufs(iib,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) + END DO + DO ji = Ni_0+1, i0max ! avoid sending uninitialized values (make sure we don't use it) + zbufs(ji,ij1,jk,jl) = HUGE(0._dp) ! make sure we don't use it... + END DO + END DO + END DO ; END DO ; END DO + ! + ! start waiting time measurement + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + ! send the same buffer data to all neighbourgs as soon as possible + DO jn = 1, nfd_nbnei + iproc = nfd_rknei(jn) + IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN + CALL MPI_Isend( zbufs, ibuffsize, MPI_DOUBLE_PRECISION, iproc, 5, mpi_comm_oce, ireq_s(jn), ierr ) + ELSE + ireq_s(jn) = MPI_REQUEST_NULL + ENDIF + END DO + ! + ALLOCATE( zbufr(i0max,ipjtot,ipk,ipl,nfd_nbnei), ireq_r(nfd_nbnei) ) + ! + DO jn = 1, nfd_nbnei + ! + iproc = nfd_rknei(jn) + ! + IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) + ! + ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received + zbufr(:,:,:,:,jn) = HUGE(0._dp) ! default: define it and make sure we don't use it... + SELECT CASE ( kfillmode ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) ! we will use only the first value, see init_nfdcom + zbufr(1,ij1,jk,jl,jn) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point + END DO + END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + zbufr(1,:,:,:,jn) = pfillval ! we will use only the first value, see init_nfdcom + END SELECT + ! + ELSE IF( iproc == narea-1 ) THEN ! get data from myself! + ! + ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) + DO ji = Nis0, Nie0 ! should not use any other value + iib = ji - Nis0 + 1 + zbufr(iib,ij1,jk,jl,jn) = ptab(jf)%pt4d(ji,ij2,jk,jl) + END DO + END DO + END DO ; END DO ; END DO + ! + ELSE ! get data from a neighbour trough communication + CALL MPI_Irecv( zbufr(:,:,:,:,jn), ibuffsize, MPI_DOUBLE_PRECISION, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr ) + ENDIF + ! + END DO ! nfd_nbnei + ! + CALL mpi_waitall(nfd_nbnei, ireq_r, MPI_STATUSES_IGNORE, ierr) ! wait for all Irecv + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! North fold boundary condition + ! + DO jf = 1, ipf + ! + SELECT CASE ( cd_nat(jf) ) ! which grid number? + CASE ('T','W') ; iig = 1 ! T-, W-point + CASE ('U') ; iig = 2 ! U-point + CASE ('V') ; iig = 3 ! V-point + CASE ('F') ; iig = 4 ! F-point + END SELECT + ! + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! if T point with F-point pivot : must be done first + ! --> specific correction of 3 points near the 2 pivots (to be clean, usually masked -> so useless) + IF( c_NFtype == 'F' .AND. iig == 1 ) THEN + ij1 = jpj - khls ! j-index in the receiving array + ij2 = 1 ! only 1 line in the buffer + DO ji = mi0(khls), mi1(khls) ! change because of EW periodicity as we also change jpiglo-khls + iib = nfd_jisnd(mi0( khls),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0( khls),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + DO ji = mi0(jpiglo/2+1), mi1(jpiglo/2+1) + iib = nfd_jisnd(mi0( jpiglo/2+1),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0( jpiglo/2+1),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + DO ji = mi0(jpiglo-khls), mi1(jpiglo-khls) + iib = nfd_jisnd(mi0(jpiglo-khls),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0(jpiglo-khls),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + ENDIF + ! + ! Apply the North pole folding. + DO jj = 1, ipjfld(jf) ! for all lines to be exchanged for this field + ij1 = ijrcv(jj,jf) ! j-index in the receiving array + ij2 = ijbuf(jj,jf) ! j-index in the buffer + iis = ii1st(jj,jf) ! stating i-index in the receiving array + iie = iiend(jj,jf) ! ending i-index in the receiving array + DO ji = iis, iie + iib = nfd_jisnd(ji,iig) ! i-index in the buffer + iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) + END DO + END DO + ! + ! re-apply periodocity when we modified the eastern side of the inner domain (and not the full line) + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + IF( iig <= 2 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'T','W','U': update west halo + ELSE ; iis = 1 ; iie = 0 ! 'V','F' : full line already exchanged + ENDIF + ENDIF + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + IF( iig <= 2 ) THEN ; iis = 1 ; iie = 0 ! 'T','W','U': nothing to do + ELSEIF( iig == 3 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'V' : update west halo + ELSEIF( khls > 1 ) THEN ; iis = mi0(1) ; iie = mi1(khls-1) ! 'F' and khls > 1 + ELSE ; iis = 1 ; iie = 0 ! 'F' and khls == 1 : nothing to do + ENDIF + ENDIF + jj = ipjfld(jf) ! only for the last line of this field + ij1 = ijrcv(jj,jf) ! j-index in the receiving array + ij2 = ijbuf(jj,jf) ! j-index in the buffer + DO ji = iis, iie + iib = nfd_jisnd(ji,iig) ! i-index in the buffer + iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) + END DO + ! + END DO ; END DO ! ipl ; ipk + ! + END DO ! ipf + + ! + DEALLOCATE( zbufr, ireq_r, ijsnd, ijbuf, ijrcv, ii1st, iiend, ipjfld ) + ! + CALL mpi_waitall(nfd_nbnei, ireq_s, MPI_STATUSES_IGNORE, ierr) ! wait for all Isend + ! + DEALLOCATE( zbufs, ireq_s ) + ! + ELSE !== allgather exchanges ==! + ! + ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) + ipj = khls + 2 + ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) + ipj2 = 2 * khls + 2 + ! + i0max = jpimax - 2 * khls + ibuffsize = i0max * ipj * ipk * ipl * ipf + ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) + ! + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab + DO jj = 1, ipj + ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines + DO ji = 1, Ni_0 + ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 + znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = Ni_0+1, i0max + znorthloc(ji,jj,jk,jl,jf) = HUGE(0._dp) ! avoid sending uninitialized values (make sure we don't use it) + END DO + END DO + END DO ; END DO ; END DO + ! + ! start waiting time measurement + IF( ln_timing ) CALL tic_tac(.TRUE.) + CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_DOUBLE_PRECISION, znorthglo, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) + ! stop waiting time measurement + IF( ln_timing ) CALL tic_tac(.FALSE.) + DEALLOCATE( znorthloc ) + ALLOCATE( ztabglo(ipf) ) + DO jf = 1, ipf + ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) ) + END DO + ! + ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines + ijnr = 0 + DO jr = 1, jpni ! recover the global north array + iproc = nfproc(jr) + impp = nfimpp(jr) + ipi = nfjpi( jr) - 2 * khls ! corresponds to Ni_0 but for subdomain iproc + IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) + ! + SELECT CASE ( kfillmode ) + CASE ( jpfillnothing ) ! no filling + CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F') + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point + END DO + END DO + END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval + END DO + END DO + END DO ; END DO ; END DO + END SELECT + ! + ELSE + ijnr = ijnr + 1 + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr) + END DO + END DO + END DO ; END DO ; END DO + ENDIF + ! + END DO ! jpni + DEALLOCATE( znorthglo ) + ! + DO jf = 1, ipf + CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 ) ! North fold boundary condition + DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity + DO jj = 1, khls + 1 + ij1 = ipj2 - (khls + 1) + jj ! need only the last khls + 1 lines until ipj2 + ztabglo(jf)%pt4d( 1: khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl) + ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( khls+1: 2*khls,ij1,jk,jl) + END DO + END DO ; END DO + END DO + ! + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN + DO jj = 1, khls + 1 + ij1 = jpj - (khls + 1) + jj ! last khls + 1 lines until jpj + ij2 = ipj2 - (khls + 1) + jj ! last khls + 1 lines until ipj2 + DO ji= 1, jpi + ii2 = mig(ji) + ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + END DO ; END DO ; END DO + ! + DO jf = 1, ipf + DEALLOCATE( ztabglo(jf)%pt4d ) + END DO + DEALLOCATE( ztabglo ) + ! + ENDIF ! ln_nnogather + ! + END SUBROUTINE mpp_nfd_dp + + !!====================================================================== +END MODULE lbcnfd diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldfc1d_c2d.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldfc1d_c2d.f90 new file mode 100644 index 0000000000000000000000000000000000000000..47fa0d8bb3e5f53ef9d1c953aa478a0209eb08e8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldfc1d_c2d.f90 @@ -0,0 +1,174 @@ + + + + + + + + + + + + + +MODULE ldfc1d_c2d + !!====================================================================== + !! *** MODULE ldfc1d_c2d *** + !! Ocean physics: profile and horizontal shape of lateral eddy coefficients + !!===================================================================== + !! History : 3.7 ! 2013-12 (G. Madec) restructuration/simplification of aht/aeiv specification, + !! ! add velocity dependent coefficient and optional read in file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ldf_c1d : ah reduced by 1/4 on the vertical (tanh profile, inflection at 300m) + !! ldf_c2d : ah = F(e1,e2) (laplacian or = F(e1^3,e2^3) (bilaplacian) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC ldf_c1d ! called by ldftra and ldfdyn modules + PUBLIC ldf_c2d ! called by ldftra and ldfdyn modules + + 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 + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ldfc1d_c2d.F90 15014 2021-06-17 17:02:04Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ldf_c1d( cd_type, pahs1, pahs2, pah1, pah2 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_c1d *** + !! + !! ** Purpose : 1D eddy diffusivity/viscosity coefficients + !! + !! ** Method : 1D eddy diffusivity coefficients F( depth ) + !! Reduction by zratio from surface to bottom + !! hyperbolic tangent profile with inflection point + !! at zh=500m and a width of zw=200m + !! + !! cd_type = TRA pah1, pah2 defined at U- and V-points + !! DYN pah1, pah2 defined at T- and F-points + !!---------------------------------------------------------------------- + CHARACTER(len=3) , INTENT(in ) :: cd_type ! DYNamique or TRAcers + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pahs1, pahs2 ! surface value of eddy coefficient [m2/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pah1 , pah2 ! eddy coefficient [m2/s] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zh, zc, zdep1 ! local scalars + REAL(wp) :: zw , zdep2 ! - - + REAL(wp) :: zratio ! - - + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ldf_c1d : set a given profile to eddy mixing coefficients' + ! + ! initialization of the profile + zratio = 0.25_wp ! surface/bottom ratio + zh = 500._wp ! depth of the inflection point [m] + zw = 1._wp / 200._wp ! width^-1 - - - [1/m] + ! ! associated coefficient [-] + zc = ( 1._wp - zratio ) / ( 1._wp + TANH( zh * zw) ) + ! + ! + SELECT CASE( cd_type ) ! point of calculation + ! + CASE( 'DYN' ) ! T- and F-points + DO jk = jpkm1, 1, -1 ! pah1 at T-point + pah1(:,:,jk) = pahs1(:,:) * ( zratio + zc * ( 1._wp + TANH( - ( gdept_0(:,:,jk) - zh ) * zw) ) ) + END DO + DO jk = jpkm1, 1, -1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! pah2 at F-point (zdep2 is an approximation in zps-coord.) + zdep2 = ( gdept_0(ji,jj+1,jk) + gdept_0(ji+1,jj+1,jk) & + & + gdept_0(ji,jj ,jk) + gdept_0(ji+1,jj ,jk) ) * r1_4 + pah2(ji,jj,jk) = pahs2(ji,jj) * ( zratio + zc * ( 1._wp + TANH( - ( zdep2 - zh ) * zw) ) ) + END DO ; END DO ; END DO + CALL lbc_lnk( 'ldfc1d_c2d', pah2, 'F', 1.0_wp ) ! Lateral boundary conditions + ! + CASE( 'TRA' ) ! U- and V-points (zdep1 & 2 are an approximation in zps-coord.) + DO jk = jpkm1, 1, -1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zdep1 = ( gdept_0(ji,jj,jk) + gdept_0(ji+1,jj,jk) ) * 0.5_wp + zdep2 = ( gdept_0(ji,jj,jk) + gdept_0(ji,jj+1,jk) ) * 0.5_wp + pah1(ji,jj,jk) = pahs1(ji,jj) * ( zratio + zc * ( 1._wp + TANH( - ( zdep1 - zh ) * zw) ) ) + pah2(ji,jj,jk) = pahs2(ji,jj) * ( zratio + zc * ( 1._wp + TANH( - ( zdep2 - zh ) * zw) ) ) + END DO ; END DO ; END DO + ! Lateral boundary conditions + CALL lbc_lnk( 'ldfc1d_c2d', pah1, 'U', 1.0_wp , pah2, 'V', 1.0_wp ) + ! + CASE DEFAULT ! error + CALL ctl_stop( 'ldf_c1d: ', cd_type, ' Unknown, i.e. /= DYN or TRA' ) + END SELECT + ! + END SUBROUTINE ldf_c1d + + + SUBROUTINE ldf_c2d( cd_type, pUfac, knn, pah1, pah2 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_c2d *** + !! + !! ** Purpose : 2D eddy diffusivity/viscosity coefficients + !! + !! ** Method : 2D eddy diffusivity coefficients F( e1 , e2 ) + !! laplacian operator : ah proportional to the scale factor [m2/s] + !! bilaplacian operator : ah proportional to the (scale factor)^3 [m4/s] + !! In both cases, pah0 is the maximum value reached by the coefficient + !! at the Equator in case of e1=ra*rad= ~111km, not over the whole domain. + !! + !! cd_type = TRA pah1, pah2 defined at U- and V-points + !! DYN pah1, pah2 defined at T- and F-points + !!---------------------------------------------------------------------- + CHARACTER(len=3) , INTENT(in ) :: cd_type ! DYNamique or TRAcers + REAL(wp) , INTENT(in ) :: pUfac ! =1/2*Uc LAPlacian BiLaPlacian + INTEGER , INTENT(in ) :: knn ! characteristic velocity [m/s] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pah1, pah2 ! eddy coefficients [m2/s or m4/s] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inn ! local integer + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ldf_c2d : aht = Ufac * max(e1,e2) with Ufac = ', pUfac, ' m/s' + ! + ! + SELECT CASE( cd_type ) !== surface values ==! (chosen grid point function of DYN or TRA) + ! + CASE( 'DYN' ) ! T- and F-points + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + pah1(ji,jj,1) = pUfac * MAX( e1t(ji,jj) , e2t(ji,jj) )**knn + pah2(ji,jj,1) = pUfac * MAX( e1f(ji,jj) , e2f(ji,jj) )**knn + END DO ; END DO + CASE( 'TRA' ) ! U- and V-points + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + pah1(ji,jj,1) = pUfac * MAX( e1u(ji,jj), e2u(ji,jj) )**knn + pah2(ji,jj,1) = pUfac * MAX( e1v(ji,jj), e2v(ji,jj) )**knn + END DO ; END DO + CASE DEFAULT ! error + CALL ctl_stop( 'ldf_c2d: ', cd_type, ' Unknown, i.e. /= DYN or TRA' ) + END SELECT + ! !== deeper values = surface one ==! (except jpk) + DO jk = 2, jpkm1 + pah1(:,:,jk) = pah1(:,:,1) + pah2(:,:,jk) = pah2(:,:,1) + END DO + ! + END SUBROUTINE ldf_c2d + + !!====================================================================== +END MODULE ldfc1d_c2d diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldfdyn.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldfdyn.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7b9601bbaab2782b56e836f5d3e19f2afd96bb1a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldfdyn.f90 @@ -0,0 +1,519 @@ + + + + + + + + + + + + + +MODULE ldfdyn + !!====================================================================== + !! *** MODULE ldfdyn *** + !! Ocean physics: lateral viscosity coefficient + !!===================================================================== + !! History : OPA ! 1997-07 (G. Madec) multi dimensional coefficients + !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module + !! 3.7 ! 2014-01 (F. Lemarie, G. Madec) restructuration/simplification of ahm specification, + !! ! add velocity dependent coefficient and optional read in file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ldf_dyn_init : initialization, namelist read, and parameters control + !! ldf_dyn : update lateral eddy viscosity coefficients at each time step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ldfslp ! lateral diffusion: slopes of mixing orientation + USE ldfc1d_c2d ! lateral diffusion: 1D and 2D cases + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module for ehanced bottom friction file + USE timing ! Timing + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC ldf_dyn_init ! called by nemogcm.F90 + PUBLIC ldf_dyn ! called by step.F90 + + ! !!* Namelist namdyn_ldf : lateral mixing on momentum * + LOGICAL , PUBLIC :: ln_dynldf_OFF !: No operator (i.e. no explicit diffusion) + INTEGER , PUBLIC :: nn_dynldf_typ !: operator type (0: div-rot ; 1: symmetric) + LOGICAL , PUBLIC :: ln_dynldf_lap !: laplacian operator + LOGICAL , PUBLIC :: ln_dynldf_blp !: bilaplacian operator + LOGICAL , PUBLIC :: ln_dynldf_lev !: iso-level direction + LOGICAL , PUBLIC :: ln_dynldf_hor !: horizontal (geopotential) direction +! LOGICAL , PUBLIC :: ln_dynldf_iso !: iso-neutral direction (see ldfslp) + INTEGER , PUBLIC :: nn_ahm_ijk_t !: choice of time & space variations of the lateral eddy viscosity coef. + ! ! time invariant coefficients: aht = 1/2 Ud*Ld (lap case) + ! ! bht = 1/12 Ud*Ld^3 (blp case) + REAL(wp), PUBLIC :: rn_Uv !: lateral viscous velocity [m/s] + REAL(wp), PUBLIC :: rn_Lv !: lateral viscous length [m] + ! ! Smagorinsky viscosity (nn_ahm_ijk_t = 32) + REAL(wp), PUBLIC :: rn_csmc !: Smagorinsky constant of proportionality + REAL(wp), PUBLIC :: rn_minfac !: Multiplicative factor of theorectical minimum Smagorinsky viscosity + REAL(wp), PUBLIC :: rn_maxfac !: Multiplicative factor of theorectical maximum Smagorinsky viscosity + ! ! iso-neutral laplacian (ln_dynldf_lap=ln_dynldf_iso=T) + REAL(wp), PUBLIC :: rn_ahm_b !: lateral laplacian background eddy viscosity [m2/s] + + ! !!* Parameter to control the type of lateral viscous operator + INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 !: error in setting the operator + INTEGER, PARAMETER, PUBLIC :: np_no_ldf = 00 !: without operator (i.e. no lateral viscous trend) + ! + INTEGER, PARAMETER, PUBLIC :: np_typ_rot = 0 !: div-rot operator + INTEGER, PARAMETER, PUBLIC :: np_typ_sym = 1 !: symmetric operator + ! + ! !! laplacian ! bilaplacian ! + INTEGER, PARAMETER, PUBLIC :: np_lap = 10 , np_blp = 20 !: iso-level operator + INTEGER, PARAMETER, PUBLIC :: np_lap_i = 11 !: iso-neutral or geopotential operator + ! + INTEGER , PUBLIC :: nldf_dyn !: type of lateral diffusion used defined from ln_dynldf_... (namlist logicals) + LOGICAL , PUBLIC :: l_ldfdyn_time !: flag for time variation of the lateral eddy viscosity coef. + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahmt, ahmf !: eddy viscosity coef. at T- and F-points [m2/s or m4/s] + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dtensq !: horizontal tension squared (Smagorinsky only) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dshesq !: horizontal shearing strain squared (Smagorinsky only) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: esqt, esqf !: Square of the local gridscale (e1e2/(e1+e2))**2 + + REAL(wp) :: r1_2 = 0.5_wp ! =1/2 + REAL(wp) :: r1_4 = 0.25_wp ! =1/4 + REAL(wp) :: r1_8 = 0.125_wp ! =1/8 + REAL(wp) :: r1_12 = 1._wp / 12._wp ! =1/12 + REAL(wp) :: r1_288 = 1._wp / 288._wp ! =1/( 12^2 * 2 ) + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ldfdyn.F90 15014 2021-06-17 17:02:04Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ldf_dyn_init + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_dyn_init *** + !! + !! ** Purpose : set the horizontal ocean dynamics physics + !! + !! ** Method : the eddy viscosity coef. specification depends on: + !! - the operator: + !! ln_dynldf_lap = T laplacian operator + !! ln_dynldf_blp = T bilaplacian operator + !! - the parameter nn_ahm_ijk_t: + !! nn_ahm_ijk_t = 0 => = constant + !! = 10 => = F(z) : = constant with a reduction of 1/4 with depth + !! =-20 => = F(i,j) = shape read in 'eddy_viscosity_2D.nc' file + !! = 20 = F(i,j) = F(e1,e2) or F(e1^3,e2^3) (lap or bilap case) + !! =-30 => = F(i,j,k) = shape read in 'eddy_viscosity_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) ( |u|e /12 laplacian operator + !! or |u|e^3/12 bilaplacian operator ) + !! = 32 = F(i,j,k,t) = F(local deformation rate and gridscale) (D and L) (Smagorinsky) + !! ( L^2|D| laplacian operator + !! or L^4|D|/8 bilaplacian operator ) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ioptio, ierr, inum, ios, inn ! local integer + REAL(wp) :: zah0, zah_max, zUfac ! local scalar + CHARACTER(len=5) :: cl_Units ! units (m2/s or m4/s) + !! + NAMELIST/namdyn_ldf/ ln_dynldf_OFF, nn_dynldf_typ, ln_dynldf_lap, ln_dynldf_blp, & ! type of operator + & ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso, & ! acting direction of the operator + & nn_ahm_ijk_t , rn_Uv , rn_Lv , rn_ahm_b, & ! lateral eddy coefficient + & rn_csmc , rn_minfac , rn_maxfac ! Smagorinsky settings + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namdyn_ldf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist' ) + + READ ( numnam_cfg, namdyn_ldf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in configuration namelist' ) + IF(lwm) WRITE ( numond, namdyn_ldf ) + + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) 'ldf_dyn : lateral momentum physics' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) ' Namelist namdyn_ldf : set lateral mixing parameters' + ! + WRITE(numout,*) ' type :' + WRITE(numout,*) ' no explicit diffusion ln_dynldf_OFF = ', ln_dynldf_OFF + WRITE(numout,*) ' type of operator (div-rot or sym) nn_dynldf_typ = ', nn_dynldf_typ + WRITE(numout,*) ' laplacian operator ln_dynldf_lap = ', ln_dynldf_lap + WRITE(numout,*) ' bilaplacian operator ln_dynldf_blp = ', ln_dynldf_blp + ! + WRITE(numout,*) ' direction of action :' + WRITE(numout,*) ' iso-level ln_dynldf_lev = ', ln_dynldf_lev + WRITE(numout,*) ' horizontal (geopotential) ln_dynldf_hor = ', ln_dynldf_hor + WRITE(numout,*) ' iso-neutral ln_dynldf_iso = ', ln_dynldf_iso + ! + WRITE(numout,*) ' coefficients :' + WRITE(numout,*) ' type of time-space variation nn_ahm_ijk_t = ', nn_ahm_ijk_t + WRITE(numout,*) ' lateral viscous velocity (if cst) rn_Uv = ', rn_Uv, ' m/s' + WRITE(numout,*) ' lateral viscous length (if cst) rn_Lv = ', rn_Lv, ' m' + WRITE(numout,*) ' background viscosity (iso-lap case) rn_ahm_b = ', rn_ahm_b, ' m2/s' + ! + WRITE(numout,*) ' Smagorinsky settings (nn_ahm_ijk_t = 32) :' + WRITE(numout,*) ' Smagorinsky coefficient rn_csmc = ', rn_csmc + WRITE(numout,*) ' factor multiplier for eddy visc.' + WRITE(numout,*) ' lower limit (default 1.0) rn_minfac = ', rn_minfac + WRITE(numout,*) ' upper limit (default 1.0) rn_maxfac = ', rn_maxfac + ENDIF + + ! + ! !== type of lateral operator used ==! (set nldf_dyn) + ! !=====================================! + ! + nldf_dyn = np_ERROR + ioptio = 0 + IF( ln_dynldf_OFF ) THEN ; nldf_dyn = np_no_ldf ; ioptio = ioptio + 1 ; ENDIF + IF( ln_dynldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF + IF( ln_dynldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'ldf_dyn_init: use ONE of the 3 operator options (NONE/lap/blp)' ) + ! + IF(.NOT.ln_dynldf_OFF ) THEN !== direction ==>> type of operator ==! + ! + SELECT CASE( nn_dynldf_typ ) ! div-rot or symmetric + CASE( np_typ_rot ) ; IF(lwp) WRITE(numout,*) ' ==>>> use div-rot operator ' + CASE( np_typ_sym ) ; IF(lwp) WRITE(numout,*) ' ==>>> use symmetric operator ' + CASE DEFAULT ! error + CALL ctl_stop('ldf_dyn_init: wrong value for nn_dynldf_typ (0 or 1)' ) + END SELECT + ! + ioptio = 0 + IF( ln_dynldf_lev ) ioptio = ioptio + 1 + IF( ln_dynldf_hor ) ioptio = ioptio + 1 + IF( ln_dynldf_iso ) ioptio = ioptio + 1 + IF( ioptio /= 1 ) CALL ctl_stop( 'ldf_dyn_init: use ONE of the 3 direction options (level/hor/iso)' ) + ! + ! ! Set nldf_dyn, the type of lateral diffusion, from ln_dynldf_... logicals + ierr = 0 + IF( ln_dynldf_lap ) THEN ! laplacian operator + IF( ln_zco ) THEN ! z-coordinate + IF ( ln_dynldf_lev ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation) + IF ( ln_dynldf_hor ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation) + IF ( ln_dynldf_iso ) nldf_dyn = np_lap_i ! iso-neutral ( rotation) + ENDIF + IF( ln_zps ) THEN ! z-coordinate with partial step + IF ( ln_dynldf_lev ) nldf_dyn = np_lap ! iso-level (no rotation) + IF ( ln_dynldf_hor ) nldf_dyn = np_lap ! iso-level (no rotation) + IF ( ln_dynldf_iso ) nldf_dyn = np_lap_i ! iso-neutral ( rotation) + ENDIF + IF( ln_sco ) THEN ! s-coordinate + IF ( ln_dynldf_lev ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation) + IF ( ln_dynldf_hor ) nldf_dyn = np_lap_i ! horizontal ( rotation) + IF ( ln_dynldf_iso ) nldf_dyn = np_lap_i ! iso-neutral ( rotation) + ENDIF + ENDIF + ! + IF( ln_dynldf_blp ) THEN ! bilaplacian operator + IF( ln_zco ) THEN ! z-coordinate + IF( ln_dynldf_lev ) nldf_dyn = np_blp ! iso-level = horizontal (no rotation) + IF( ln_dynldf_hor ) nldf_dyn = np_blp ! iso-level = horizontal (no rotation) + IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) + ENDIF + IF( ln_zps ) THEN ! z-coordinate with partial step + IF( ln_dynldf_lev ) nldf_dyn = np_blp ! iso-level (no rotation) + IF( ln_dynldf_hor ) nldf_dyn = np_blp ! iso-level (no rotation) + IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) + ENDIF + IF( ln_sco ) THEN ! s-coordinate + IF( ln_dynldf_lev ) nldf_dyn = np_blp ! iso-level (no rotation) + IF( ln_dynldf_hor ) ierr = 2 ! horizontal ( rotation) + IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) + ENDIF + ENDIF + ! + IF( ierr == 2 ) CALL ctl_stop( 'rotated bi-laplacian operator does not exist' ) + ! + IF( nldf_dyn == np_lap_i ) l_ldfslp = .TRUE. ! rotation require the computation of the slopes + ! + ENDIF + ! + IF(lwp) THEN + WRITE(numout,*) + SELECT CASE( nldf_dyn ) + CASE( np_no_ldf ) ; WRITE(numout,*) ' ==>>> NO lateral viscosity' + CASE( np_lap ) ; WRITE(numout,*) ' ==>>> iso-level laplacian operator' + CASE( np_lap_i ) ; WRITE(numout,*) ' ==>>> rotated laplacian operator with iso-level background' + CASE( np_blp ) ; WRITE(numout,*) ' ==>>> iso-level bi-laplacian operator' + END SELECT + WRITE(numout,*) + ENDIF + + ! + ! !== Space/time variation of eddy coefficients ==! + ! !=================================================! + ! + l_ldfdyn_time = .FALSE. ! no time variation except in case defined below + ! + IF( ln_dynldf_OFF ) THEN + IF(lwp) WRITE(numout,*) ' ==>>> No viscous operator selected. ahmt and ahmf are not allocated' + RETURN + ! + ELSE !== a lateral diffusion operator is used ==! + ! + ! ! allocate the ahm arrays + ALLOCATE( ahmt(jpi,jpj,jpk) , ahmf(jpi,jpj,jpk) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate arrays') + ! + ahmt(:,:,:) = 0._wp ! init to 0 needed + ahmf(:,:,:) = 0._wp + ! + ! ! value of lap/blp eddy mixing coef. + IF( ln_dynldf_lap ) THEN ; zUfac = r1_2 *rn_Uv ; inn = 1 ; cl_Units = ' m2/s' ! laplacian + ELSEIF( ln_dynldf_blp ) THEN ; zUfac = r1_12*rn_Uv ; inn = 3 ; cl_Units = ' m4/s' ! bilaplacian + ENDIF + zah0 = zUfac * rn_Lv**inn ! mixing coefficient + zah_max = zUfac * (ra*rad)**inn ! maximum reachable coefficient (value at the Equator) + ! + SELECT CASE( nn_ahm_ijk_t ) !* Specification of space-time variations of ahmt, ahmf + ! + CASE( 0 ) !== constant ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity. = constant = ', zah0, cl_Units + ahmt(:,:,1:jpkm1) = zah0 + ahmf(:,:,1:jpkm1) = zah0 + ! + CASE( 10 ) !== fixed profile ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( depth )' + IF(lwp) WRITE(numout,*) ' surface viscous coef. = constant = ', zah0, cl_Units + ahmt(:,:,1) = zah0 ! constant surface value + ahmf(:,:,1) = zah0 + CALL ldf_c1d( 'DYN', ahmt(:,:,1), ahmf(:,:,1), ahmt, ahmf ) + ! + CASE ( -20 ) !== fixed horizontal shape read in file ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F(i,j) read in eddy_viscosity.nc file' + CALL iom_open( 'eddy_viscosity_2D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'ahmt_2d', ahmt(:,:,1), cd_type = 'T', psgn = 1._dp ) + CALL iom_get ( inum, jpdom_global, 'ahmf_2d', ahmf(:,:,1), cd_type = 'F', psgn = 1._dp ) + CALL iom_close( inum ) + DO jk = 2, jpkm1 + ahmt(:,:,jk) = ahmt(:,:,1) + ahmf(:,:,jk) = ahmf(:,:,1) + END DO + ! + CASE( 20 ) !== fixed horizontal shape ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( e1, e2 ) or F( e1^3, e2^3 ) (lap. or blp. case)' + IF(lwp) WRITE(numout,*) ' using a fixed viscous velocity = ', rn_Uv ,' m/s and Lv = Max(e1,e2)' + IF(lwp) WRITE(numout,*) ' maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, ' for e1=1°)' + CALL ldf_c2d( 'DYN', zUfac , inn , ahmt, ahmf ) ! surface value proportional to scale factor^inn + ! + CASE( -30 ) !== fixed 3D shape read in file ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F(i,j,k) read in eddy_viscosity_3D.nc file' + CALL iom_open( 'eddy_viscosity_3D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'ahmt_3d', ahmt, cd_type = 'T', psgn = 1._dp ) + CALL iom_get ( inum, jpdom_global, 'ahmf_3d', ahmf, cd_type = 'F', psgn = 1._dp ) + CALL iom_close( inum ) + ! + CASE( 30 ) !== fixed 3D shape ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( latitude, longitude, depth )' + IF(lwp) WRITE(numout,*) ' using a fixed viscous velocity = ', rn_Uv ,' 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( 'DYN', zUfac , inn , ahmt, ahmf ) ! surface value proportional to scale factor^inn + CALL ldf_c1d( 'DYN', ahmt(:,:,1), ahmf(:,:,1), ahmt, ahmf ) ! reduction with depth + ! + CASE( 31 ) !== time varying 3D field ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( latitude, longitude, depth , time )' + IF(lwp) WRITE(numout,*) ' proportional to the local velocity : 1/2 |u|e (lap) or 1/12 |u|e^3 (blp)' + ! + l_ldfdyn_time = .TRUE. ! will be calculated by call to ldf_dyn routine in step.F90 + ! + CASE( 32 ) !== time varying 3D field ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( latitude, longitude, depth , time )' + IF(lwp) WRITE(numout,*) ' proportional to the local deformation rate and gridscale (Smagorinsky)' + ! + l_ldfdyn_time = .TRUE. ! will be calculated by call to ldf_dyn routine in step.F90 + ! + ! ! allocate arrays used in ldf_dyn. + ALLOCATE( dtensq(jpi,jpj,jpk) , dshesq(jpi,jpj,jpk) , esqt(jpi,jpj) , esqf(jpi,jpj) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays') + ! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) ! Set local gridscale values + esqt(ji,jj) = ( 2._wp * e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2 + esqf(ji,jj) = ( 2._wp * e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2 + END DO ; END DO + ! + CASE DEFAULT + CALL ctl_stop('ldf_dyn_init: wrong choice for nn_ahm_ijk_t, the type of space-time variation of ahm') + END SELECT + ! + IF( .NOT.l_ldfdyn_time ) THEN !* No time variation + IF( ln_dynldf_lap ) THEN ! laplacian operator (mask only) + ahmt(:,:,1:jpkm1) = ahmt(:,:,1:jpkm1) * tmask(:,:,1:jpkm1) + ahmf(:,:,1:jpkm1) = ahmf(:,:,1:jpkm1) * fmask(:,:,1:jpkm1) + ELSEIF( ln_dynldf_blp ) THEN ! bilaplacian operator (square root + mask) + ahmt(:,:,1:jpkm1) = SQRT( ahmt(:,:,1:jpkm1) ) * tmask(:,:,1:jpkm1) + ahmf(:,:,1:jpkm1) = SQRT( ahmf(:,:,1:jpkm1) ) * fmask(:,:,1:jpkm1) + ENDIF + ENDIF + ! + ENDIF + ! + END SUBROUTINE ldf_dyn_init + + + SUBROUTINE ldf_dyn( kt, Kbb ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_dyn *** + !! + !! ** Purpose : update at kt the momentum lateral mixing coeff. (ahmt and ahmf) + !! + !! ** Method : time varying eddy viscosity coefficients: + !! + !! nn_ahm_ijk_t = 31 ahmt, ahmf = F(i,j,k,t) = F(local velocity) + !! ( |u|e /12 or |u|e^3/12 for laplacian or bilaplacian operator ) + !! + !! nn_ahm_ijk_t = 32 ahmt, ahmf = F(i,j,k,t) = F(local deformation rate and gridscale) (D and L) (Smagorinsky) + !! ( L^2|D| or L^4|D|/8 for laplacian or bilaplacian operator ) + !! + !! ** note : in BLP cases the sqrt of the eddy coef is returned, since bilaplacian is en re-entrant laplacian + !! ** action : ahmt, ahmf updated at each time step + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step index + INTEGER, INTENT(in) :: Kbb ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zu2pv2_ij_p1, zu2pv2_ij, zu2pv2_ij_m1, zemax ! local scalar (option 31) + REAL(wp) :: zcmsmag, zstabf_lo, zstabf_up, zdelta, zdb ! local scalar (option 32) + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('ldf_dyn') + ! + SELECT CASE( nn_ahm_ijk_t ) !== Eddy vicosity coefficients ==! + ! + CASE( 31 ) !== time varying 3D field ==! = F( local velocity ) + ! + IF( ln_dynldf_lap ) THEN ! laplacian operator : |u| e /12 = |u/144| e + DO jk = 1, jpkm1 + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb) + zu2pv2_ij_m1 = uu(ji-1,jj ,jk,Kbb) * uu(ji-1,jj ,jk,Kbb) + vv(ji ,jj-1,jk,Kbb) * vv(ji ,jj-1,jk,Kbb) + zu2pv2_ij_p1 = uu(ji ,jj+1,jk,Kbb) * uu(ji ,jj+1,jk,Kbb) + vv(ji+1,jj ,jk,Kbb) * vv(ji+1,jj ,jk,Kbb) + zemax = MAX( e1t(ji,jj) , e2t(ji,jj) ) + ahmt(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax * tmask(ji,jj,jk) ! 288= 12*12 * 2 + zemax = MAX( e1f(ji,jj) , e2f(ji,jj) ) + ahmf(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zemax * fmask(ji,jj,jk) ! 288= 12*12 * 2 + END DO ; END DO + END DO + ELSEIF( ln_dynldf_blp ) THEN ! bilaplacian operator : sqrt( |u| e^3 /12 ) = sqrt( |u/144| e ) * e + DO jk = 1, jpkm1 + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb) + zu2pv2_ij_m1 = uu(ji-1,jj ,jk,Kbb) * uu(ji-1,jj ,jk,Kbb) + vv(ji ,jj-1,jk,Kbb) * vv(ji ,jj-1,jk,Kbb) + zu2pv2_ij_p1 = uu(ji ,jj+1,jk,Kbb) * uu(ji ,jj+1,jk,Kbb) + vv(ji+1,jj ,jk,Kbb) * vv(ji+1,jj ,jk,Kbb) + zemax = MAX( e1t(ji,jj) , e2t(ji,jj) ) + ahmt(ji,jj,jk) = SQRT( SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax ) * zemax * tmask(ji,jj,jk) + zemax = MAX( e1f(ji,jj) , e2f(ji,jj) ) + ahmf(ji,jj,jk) = SQRT( SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zemax ) * zemax * fmask(ji,jj,jk) + END DO ; END DO + END DO + ENDIF + ! + CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_wp, ahmf, 'F', 1.0_wp ) + ! + ! + CASE( 32 ) !== time varying 3D field ==! = F( local deformation rate and gridscale ) (Smagorinsky) + ! + IF( ln_dynldf_lap .OR. ln_dynldf_blp ) THEN ! laplacian operator : (C_smag/pi)^2 L^2 |D| + ! + zcmsmag = (rn_csmc/rpi)**2 ! (C_smag/pi)^2 + zstabf_lo = rn_minfac * rn_minfac / ( 2._wp * 12._wp * 12._wp * zcmsmag ) ! lower limit stability factor scaling + zstabf_up = rn_maxfac / ( 4._wp * zcmsmag * 2._wp * rn_Dt ) ! upper limit stability factor scaling + IF( ln_dynldf_blp ) zstabf_lo = ( 16._wp / 9._wp ) * zstabf_lo ! provide |U|L^3/12 lower limit instead + ! ! of |U|L^3/16 in blp case + DO jk = 1, jpkm1 + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zdb = ( uu(ji,jj,jk,Kbb) * r1_e2u(ji,jj) - uu(ji-1,jj,jk,Kbb) * r1_e2u(ji-1,jj) ) & + & * r1_e1t(ji,jj) * e2t(ji,jj) & + & - ( vv(ji,jj,jk,Kbb) * r1_e1v(ji,jj) - vv(ji,jj-1,jk,Kbb) * r1_e1v(ji,jj-1) ) & + & * r1_e2t(ji,jj) * e1t(ji,jj) + dtensq(ji,jj,jk) = zdb * zdb * tmask(ji,jj,jk) + END DO ; END DO + ! + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zdb = ( uu(ji,jj+1,jk,Kbb) * r1_e1u(ji,jj+1) - uu(ji,jj,jk,Kbb) * r1_e1u(ji,jj) ) & + & * r1_e2f(ji,jj) * e1f(ji,jj) & + & + ( vv(ji+1,jj,jk,Kbb) * r1_e2v(ji+1,jj) - vv(ji,jj,jk,Kbb) * r1_e2v(ji,jj) ) & + & * r1_e1f(ji,jj) * e2f(ji,jj) + dshesq(ji,jj,jk) = zdb * zdb * fmask(ji,jj,jk) + END DO ; END DO + ! + END DO + ! + CALL lbc_lnk( 'ldfdyn', dtensq, 'T', 1.0_wp ) ! lbc_lnk on dshesq not needed + ! + DO jk = 1, jpkm1 + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! T-point value + ! + zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb) + zu2pv2_ij_m1 = uu(ji-1,jj ,jk,Kbb) * uu(ji-1,jj ,jk,Kbb) + vv(ji ,jj-1,jk,Kbb) * vv(ji ,jj-1,jk,Kbb) + ! + zdelta = zcmsmag * esqt(ji,jj) ! L^2 * (C_smag/pi)^2 + ahmt(ji,jj,jk) = zdelta * SQRT( dtensq(ji ,jj,jk) + & + & r1_4 * ( dshesq(ji ,jj,jk) + dshesq(ji ,jj-1,jk) + & + & dshesq(ji-1,jj,jk) + dshesq(ji-1,jj-1,jk) ) ) + ahmt(ji,jj,jk) = MAX( ahmt(ji,jj,jk), SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac * |U|L/2 + ahmt(ji,jj,jk) = MIN( ahmt(ji,jj,jk), zdelta * zstabf_up ) ! Impose upper limit == maxfac * L^2/(4*2dt) + ! + END DO ; END DO + ! + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) ! F-point value + ! + zu2pv2_ij_p1 = uu(ji ,jj+1,jk, kbb) * uu(ji ,jj+1,jk, kbb) + vv(ji+1,jj ,jk, kbb) * vv(ji+1,jj ,jk, kbb) + zu2pv2_ij = uu(ji ,jj ,jk, kbb) * uu(ji ,jj ,jk, kbb) + vv(ji ,jj ,jk, kbb) * vv(ji ,jj ,jk, kbb) + ! + zdelta = zcmsmag * esqf(ji,jj) ! L^2 * (C_smag/pi)^2 + ahmf(ji,jj,jk) = zdelta * SQRT( dshesq(ji ,jj,jk) + & + & r1_4 * ( dtensq(ji ,jj,jk) + dtensq(ji ,jj+1,jk) + & + & dtensq(ji+1,jj,jk) + dtensq(ji+1,jj+1,jk) ) ) + ahmf(ji,jj,jk) = MAX( ahmf(ji,jj,jk), SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac * |U|L/2 + ahmf(ji,jj,jk) = MIN( ahmf(ji,jj,jk), zdelta * zstabf_up ) ! Impose upper limit == maxfac * L^2/(4*2dt) + ! + END DO ; END DO + ! + END DO + ! + ENDIF + ! + IF( ln_dynldf_blp ) THEN ! bilaplacian operator : sqrt( (C_smag/pi)^2 L^4 |D|/8) + ! ! = sqrt( A_lap_smag L^2/8 ) + ! ! stability limits already applied to laplacian values + ! ! effective default limits are 1/12 |U|L^3 < B_hm < 1//(32*2dt) L^4 + DO jk = 1, jpkm1 + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ahmt(ji,jj,jk) = SQRT( r1_8 * esqt(ji,jj) * ahmt(ji,jj,jk) ) + ahmf(ji,jj,jk) = SQRT( r1_8 * esqf(ji,jj) * ahmf(ji,jj,jk) ) + END DO ; END DO + END DO + ! + ENDIF + ! + CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_wp , ahmf, 'F', 1.0_wp ) + ! + END SELECT + ! + CALL iom_put( "ahmt_2d", ahmt(:,:,1) ) ! surface u-eddy diffusivity coeff. + CALL iom_put( "ahmf_2d", ahmf(:,:,1) ) ! surface v-eddy diffusivity coeff. + CALL iom_put( "ahmt_3d", ahmt(:,:,:) ) ! 3D u-eddy diffusivity coeff. + CALL iom_put( "ahmf_3d", ahmf(:,:,:) ) ! 3D v-eddy diffusivity coeff. + ! + IF( ln_timing ) CALL timing_stop('ldf_dyn') + ! + END SUBROUTINE ldf_dyn + + !!====================================================================== +END MODULE ldfdyn diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldfslp.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldfslp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3fb118026def3db546da56c806a7ff9182324ec8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldfslp.f90 @@ -0,0 +1,764 @@ + + + + + + + + + + + + + +MODULE ldfslp + !!====================================================================== + !! *** MODULE ldfslp *** + !! Ocean physics: slopes of neutral surfaces + !!====================================================================== + !! History : OPA ! 1994-12 (G. Madec, M. Imbard) Original code + !! 8.0 ! 1997-06 (G. Madec) optimization, lbc + !! 8.1 ! 1999-10 (A. Jouzeau) NEW profile in the mixed layer + !! NEMO 1.0 ! 2002-10 (G. Madec) Free form, F90 + !! - ! 2005-10 (A. Beckmann) correction for s-coordinates + !! 3.3 ! 2010-10 (G. Nurser, C. Harris, G. Madec) add Griffies operator + !! - ! 2010-11 (F. Dupond, G. Madec) bug correction in slopes just below the ML + !! 3.7 ! 2013-12 (F. Lemarie, G. Madec) add limiter on triad slopes + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ldf_slp : calculates the slopes of neutral surface (Madec operator) + !! ldf_slp_triad : calculates the triads of isoneutral slopes (Griffies operator) + !! ldf_slp_mxl : calculates the slopes at the base of the mixed layer (Madec operator) + !! ldf_slp_init : initialization of the slopes computation + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE isf_oce ! ice shelf + USE dom_oce ! ocean space and time domain +! USE ldfdyn ! lateral diffusion: eddy viscosity coef. + USE phycst ! physical constants + USE zdfmxl ! mixed layer depth + USE eosbn2 ! equation of states + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distribued memory computing library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC ldf_slp ! routine called by step.F90 + PUBLIC ldf_slp_triad ! routine called by step.F90 + PUBLIC ldf_slp_init ! routine called by nemogcm.F90 + + LOGICAL , PUBLIC :: l_ldfslp = .FALSE. !: slopes flag + + LOGICAL , PUBLIC :: ln_traldf_iso = .TRUE. !: iso-neutral direction (nam_traldf namelist) + LOGICAL , PUBLIC :: ln_traldf_triad = .FALSE. !: griffies triad scheme (nam_traldf namelist) + LOGICAL , PUBLIC :: ln_dynldf_iso !: iso-neutral direction (nam_dynldf namelist) + + LOGICAL , PUBLIC :: ln_triad_iso = .FALSE. !: pure horizontal mixing in ML (nam_traldf namelist) + LOGICAL , PUBLIC :: ln_botmix_triad = .FALSE. !: mixing on bottom (nam_traldf namelist) + REAL(wp), PUBLIC :: rn_sw_triad = 1._wp !: =1 switching triads ; =0 all four triads used (nam_traldf namelist) + REAL(wp), PUBLIC :: rn_slpmax = 0.01_wp !: slope limit (nam_traldf namelist) + + LOGICAL , PUBLIC :: l_grad_zps = .FALSE. !: special treatment for Horz Tgradients w partial steps (triad operator) + + ! !! Classic operator (Madec) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uslp, wslpi !: i_slope at U- and W-points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vslp, wslpj !: j-slope at V- and W-points + ! !! triad operator (Griffies) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wslp2 !: wslp**2 from Griffies quarter cells + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: triadi_g, triadj_g !: skew flux slopes relative to geopotentials + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: triadi , triadj !: isoneutral slopes relative to model-coordinate + ! !! both operators + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ah_wslp2 !: ah * slope^2 at w-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akz !: stabilizing vertical diffusivity + + ! !! Madec operator + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: omlmask ! mask of the surface mixed layer at T-pt + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: uslpml, wslpiml ! i_slope at U- and W-points just below the mixed layer + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: vslpml, wslpjml ! j_slope at V- and W-points just below the mixed layer + + REAL(wp) :: repsln = 1.e-25_wp ! tiny value used as minium of di(rho), dj(rho) and dk(rho) + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ldfslp.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ldf_slp( kt, prd, pn2, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_slp *** + !! + !! ** Purpose : Compute the slopes of neutral surface (slope of isopycnal + !! surfaces referenced locally) (ln_traldf_iso=T). + !! + !! ** Method : The slope in the i-direction is computed at U- and + !! W-points (uslp, wslpi) and the slope in the j-direction is + !! computed at V- and W-points (vslp, wslpj). + !! They are bounded by 1/100 over the whole ocean, and within the + !! surface layer they are bounded by the distance to the surface + !! ( slope<= depth/l where l is the length scale of horizontal + !! diffusion (here, aht=2000m2/s ==> l=20km with a typical velocity + !! of 10cm/s) + !! A horizontal shapiro filter is applied to the slopes + !! ln_sco=T, s-coordinate, add to the previously computed slopes + !! the slope of the model level surface. + !! macro-tasked on horizontal slab (jk-loop) (2, jpk-1) + !! [slopes already set to zero at level 1, and to zero or the ocean + !! bottom slope (ln_sco=T) at level jpk in inildf] + !! + !! ** Action : - uslp, wslpi, and vslp, wslpj, the i- and j-slopes + !! of now neutral surfaces at u-, w- and v- w-points, resp. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: prd ! in situ density + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: pn2 ! Brunt-Vaisala frequency (locally ref.) + !! + INTEGER :: ji , jj , jk ! dummy loop indices + INTEGER :: ii0, ii1 ! temporary integer + INTEGER :: ij0, ij1 ! temporary integer + REAL(wp) :: zeps, zm1_g, zm1_2g, z1_16, zcofw, z1_slpmax ! local scalars + REAL(wp) :: zci, zfi, zau, zbu, zai, zbi ! - - + REAL(wp) :: zcj, zfj, zav, zbv, zaj, zbj ! - - + REAL(wp) :: zck, zfk, zbw ! - - + REAL(wp) :: zdepu, zdepv ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zslpml_hmlpu, zslpml_hmlpv + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgru, zwz, zdzr + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrv, zww + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('ldf_slp') + ! + zeps = 1.e-20_wp !== Local constant initialization ==! + z1_16 = 1.0_wp / 16._wp + zm1_g = -1.0_wp / grav + zm1_2g = -0.5_wp / grav + z1_slpmax = 1._wp / rn_slpmax + ! + zww(:,:,:) = 0._wp + zwz(:,:,:) = 0._wp + ! + DO jk = 1, jpk ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) !== i- & j-gradient of density ==! + zgru(ji,jj,jk) = umask(ji,jj,jk) * ( prd(ji+1,jj ,jk) - prd(ji,jj,jk) ) + zgrv(ji,jj,jk) = vmask(ji,jj,jk) * ( prd(ji ,jj+1,jk) - prd(ji,jj,jk) ) + END DO ; END DO ; END DO + IF( ln_zps ) THEN ! partial steps correction at the bottom ocean level + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) + zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj) + END DO ; END DO + ENDIF + IF( ln_zps .AND. ln_isfcav ) THEN ! partial steps correction at the bottom ocean level + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + IF( miku(ji,jj) > 1 ) zgru(ji,jj,miku(ji,jj)) = grui(ji,jj) + IF( mikv(ji,jj) > 1 ) zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj) + END DO ; END DO + ENDIF + ! + zdzr(:,:,1) = 0._wp !== Local vertical density gradient at T-point == ! (evaluated from N^2) + DO jk = 2, jpkm1 + ! ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point + ! ! trick: tmask(ik ) = 0 => all pn2 = 0 => zdzr = 0 + ! ! else tmask(ik+1) = 0 => pn2(ik+1) = 0 => zdzr divides by 1 + ! ! umask(ik+1) /= 0 => all pn2 /= 0 => zdzr divides by 2 + ! ! NB: 1/(tmask+1) = (1-.5*tmask) substitute a / by a * ==> faster + zdzr(:,:,jk) = zm1_g * ( prd(:,:,jk) + 1._wp ) & + & * ( pn2(:,:,jk) + pn2(:,:,jk+1) ) * ( 1._wp - 0.5_wp * tmask(:,:,jk+1) ) + END DO + ! + ! !== Slopes just below the mixed layer ==! + CALL ldf_slp_mxl( prd, pn2, zgru, zgrv, zdzr, Kmm ) ! output: uslpml, vslpml, wslpiml, wslpjml + + + ! I. slopes at u and v point | uslp = d/di( prd ) / d/dz( prd ) + ! =========================== | vslp = d/dj( prd ) / d/dz( prd ) + ! + IF ( ln_isfcav ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / ( MAX(hmlpt (ji,jj), hmlpt (ji+1,jj ), 5._wp) & + & - MAX(risfdep(ji,jj), risfdep(ji+1,jj ) ) ) + zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / ( MAX(hmlpt (ji,jj), hmlpt (ji ,jj+1), 5._wp) & + & - MAX(risfdep(ji,jj), risfdep(ji ,jj+1) ) ) + END DO ; END DO + ELSE + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / MAX(hmlpt(ji,jj), hmlpt(ji+1,jj ), 5._wp) + zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / MAX(hmlpt(ji,jj), hmlpt(ji ,jj+1), 5._wp) + END DO ; END DO + END IF + + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !* Slopes at u and v points + ! ! horizontal and vertical density gradient at u- and v-points + zau = zgru(ji,jj,jk) * r1_e1u(ji,jj) + zav = zgrv(ji,jj,jk) * r1_e2v(ji,jj) + zbu = 0.5_wp * ( zdzr(ji,jj,jk) + zdzr(ji+1,jj ,jk) ) + zbv = 0.5_wp * ( zdzr(ji,jj,jk) + zdzr(ji ,jj+1,jk) ) + ! ! bound the slopes: abs(zw.)<= 1/100 and zb..<0 + ! ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) + zbu = MIN( zbu, - z1_slpmax * ABS( zau ) , -7.e+3_wp/(e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk)))* ABS( zau ) ) + zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , -7.e+3_wp/(e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk)))* ABS( zav ) ) + ! ! Fred Dupont: add a correction for bottom partial steps: + ! ! max slope = 1/2 * e3 / e1 + IF (ln_zps .AND. jk==mbku(ji,jj)) & + zbu = MIN( zbu, - z1_slpmax * ABS( zau ) , & + & - 2._wp * e1u(ji,jj) / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk)))* ABS( zau ) ) + IF (ln_zps .AND. jk==mbkv(ji,jj)) & + zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , & + & - 2._wp * e2v(ji,jj) / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk)))* ABS( zav ) ) + ! ! uslp and vslp output in zwz and zww, resp. + zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) ) + zfj = MAX( omlmask(ji,jj,jk), omlmask(ji,jj+1,jk) ) + ! thickness of water column between surface and level k at u/v point + zdepu = 0.5_wp * ( ( (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + (gdept_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kmm))) ) & + & - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj) ) & + & - (e3u_0(ji,jj,miku(ji,jj))*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,miku(ji,jj)))) ) + zdepv = 0.5_wp * ( ( (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + (gdept_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kmm))) ) & + & - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) & + & - (e3v_0(ji,jj,mikv(ji,jj))*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,mikv(ji,jj)))) ) + ! + zwz(ji,jj,jk) = ( ( 1._wp - zfi) * zau / ( zbu - zeps ) & + & + zfi * zdepu * zslpml_hmlpu(ji,jj) ) * umask(ji,jj,jk) + zww(ji,jj,jk) = ( ( 1._wp - zfj) * zav / ( zbv - zeps ) & + & + zfj * zdepv * zslpml_hmlpv(ji,jj) ) * vmask(ji,jj,jk) +!!gm modif to suppress omlmask.... (as in Griffies case) +! ! ! jk must be >= ML level for zf=1. otherwise zf=0. +! zfi = REAL( 1 - 1/(1 + jk / MAX( nmln(ji+1,jj), nmln(ji,jj) ) ), wp ) +! zfj = REAL( 1 - 1/(1 + jk / MAX( nmln(ji,jj+1), nmln(ji,jj) ) ), wp ) +! zci = 0.5 * ( (gdept_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kmm)))+(gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) / MAX( hmlpt(ji,jj), hmlpt(ji+1,jj), 10. ) ) +! zcj = 0.5 * ( (gdept_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kmm)))+(gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) / MAX( hmlpt(ji,jj), hmlpt(ji,jj+1), 10. ) ) +! zwz(ji,jj,jk) = ( zfi * zai / ( zbi - zeps ) + ( 1._wp - zfi ) * wslpiml(ji,jj) * zci ) * tmask(ji,jj,jk) +! zww(ji,jj,jk) = ( zfj * zaj / ( zbj - zeps ) + ( 1._wp - zfj ) * wslpjml(ji,jj) * zcj ) * tmask(ji,jj,jk) +!!gm end modif + END DO ; END DO ; END DO + CALL lbc_lnk( 'ldfslp', zwz, 'U', -1.0_wp, zww, 'V', -1.0_wp ) ! lateral boundary conditions + ! + ! !* horizontal Shapiro filter + DO jk = 2, jpkm1 + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! rows jj=2 and =jpjm1 only + uslp(ji,jj,jk) = z1_16 * ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & + & + zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk) & + & + 2.*( zwz(ji ,jj-1,jk) + zwz(ji-1,jj ,jk) & + & + zwz(ji+1,jj ,jk) + zwz(ji ,jj+1,jk) ) & + & + 4.* zwz(ji ,jj ,jk) ) + vslp(ji,jj,jk) = z1_16 * ( zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk) & + & + zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk) & + & + 2.*( zww(ji ,jj-1,jk) + zww(ji-1,jj ,jk) & + & + zww(ji+1,jj ,jk) + zww(ji ,jj+1,jk) ) & + & + 4.* zww(ji,jj ,jk) ) + END DO ; END DO + ! !* decrease along coastal boundaries + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk ) ) * 0.5_wp & + & * ( umask(ji,jj ,jk) + umask(ji,jj ,jk+1) ) * 0.5_wp + vslp(ji,jj,jk) = vslp(ji,jj,jk) * ( vmask(ji+1,jj,jk) + vmask(ji-1,jj,jk ) ) * 0.5_wp & + & * ( vmask(ji ,jj,jk) + vmask(ji ,jj,jk+1) ) * 0.5_wp + END DO ; END DO + END DO + + + ! II. slopes at w point | wslpi = mij( d/di( prd ) / d/dz( prd ) + ! =========================== | wslpj = mij( d/dj( prd ) / d/dz( prd ) + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ! !* Local vertical density gradient evaluated from N^2 + zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) + ! !* Slopes at w point + ! ! i- & j-gradient of density at w-points + zci = MAX( umask(ji-1,jj,jk ) + umask(ji,jj,jk ) & + & + umask(ji-1,jj,jk-1) + umask(ji,jj,jk-1) , zeps ) * e1t(ji,jj) + zcj = MAX( vmask(ji,jj-1,jk ) + vmask(ji,jj,jk-1) & + & + vmask(ji,jj-1,jk-1) + vmask(ji,jj,jk ) , zeps ) * e2t(ji,jj) + zai = ( zgru (ji-1,jj,jk ) + zgru (ji,jj,jk-1) & + & + zgru (ji-1,jj,jk-1) + zgru (ji,jj,jk ) ) / zci * wmask (ji,jj,jk) + zaj = ( zgrv (ji,jj-1,jk ) + zgrv (ji,jj,jk-1) & + & + zgrv (ji,jj-1,jk-1) + zgrv (ji,jj,jk ) ) / zcj * wmask (ji,jj,jk) + ! ! bound the slopes: abs(zw.)<= 1/100 and zb..<0. + ! ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) + zbi = MIN( zbw ,- 100._wp* ABS( zai ) , -7.e+3_wp/(e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))* ABS( zai ) ) + zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/(e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))* ABS( zaj ) ) + ! ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.) + zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) ) ! zfk=1 in the ML otherwise zfk=0 + zck = ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - (gdepw_0(ji,jj,mikt(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) ) / MAX( hmlp(ji,jj) - (gdepw_0(ji,jj,mikt(ji,jj))*(1._wp+r3t(ji,jj,Kmm))), 10._wp ) + zwz(ji,jj,jk) = ( zai / ( zbi - zeps ) * ( 1._wp - zfk ) + zck * wslpiml(ji,jj) * zfk ) * wmask(ji,jj,jk) + zww(ji,jj,jk) = ( zaj / ( zbj - zeps ) * ( 1._wp - zfk ) + zck * wslpjml(ji,jj) * zfk ) * wmask(ji,jj,jk) + +!!gm modif to suppress omlmask.... (as in Griffies operator) +! ! ! jk must be >= ML level for zfk=1. otherwise zfk=0. +! zfk = REAL( 1 - 1/(1 + jk / nmln(ji+1,jj)), wp ) +! zck = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / MAX( hmlp(ji,jj), 10. ) +! zwz(ji,jj,jk) = ( zfk * zai / ( zbi - zeps ) + ( 1._wp - zfk ) * wslpiml(ji,jj) * zck ) * tmask(ji,jj,jk) +! zww(ji,jj,jk) = ( zfk * zaj / ( zbj - zeps ) + ( 1._wp - zfk ) * wslpjml(ji,jj) * zck ) * tmask(ji,jj,jk) +!!gm end modif + END DO ; END DO ; END DO + CALL lbc_lnk( 'ldfslp', zwz, 'T', -1.0_wp, zww, 'T', -1.0_wp ) ! lateral boundary conditions + ! + ! !* horizontal Shapiro filter + DO jk = 2, jpkm1 + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! rows jj=2 and =jpjm1 only + zcofw = wmask(ji,jj,jk) * z1_16 + wslpi(ji,jj,jk) = ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & + & + zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk) & + & + 2.*( zwz(ji ,jj-1,jk) + zwz(ji-1,jj ,jk) & + & + zwz(ji+1,jj ,jk) + zwz(ji ,jj+1,jk) ) & + & + 4.* zwz(ji ,jj ,jk) ) * zcofw + + wslpj(ji,jj,jk) = ( zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk) & + & + zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk) & + & + 2.*( zww(ji ,jj-1,jk) + zww(ji-1,jj ,jk) & + & + zww(ji+1,jj ,jk) + zww(ji ,jj+1,jk) ) & + & + 4.* zww(ji ,jj ,jk) ) * zcofw + END DO ; END DO + ! !* decrease in vicinity of topography + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zck = ( umask(ji,jj,jk) + umask(ji-1,jj,jk) ) & + & * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25 + wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck + wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck + END DO ; END DO + END DO + + ! IV. Lateral boundary conditions + ! =============================== + CALL lbc_lnk( 'ldfslp', uslp , 'U', -1.0_wp , vslp , 'V', -1.0_wp , wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) + + !IF(sn_cfctl%l_prtctl) THEN + !CALL prt_ctl(tab3d_1=uslp , clinfo1=' slp - u : ', tab3d_2=vslp, clinfo2=' v : ') + !CALL prt_ctl(tab3d_1=wslpi, clinfo1=' slp - wi: ', tab3d_2=wslpj, clinfo2=' wj: ') + !ENDIF + ! + IF( ln_timing ) CALL timing_stop('ldf_slp') + ! + END SUBROUTINE ldf_slp + + + SUBROUTINE ldf_slp_triad ( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_slp_triad *** + !! + !! ** Purpose : Compute the squared slopes of neutral surfaces (slope + !! of iso-pycnal surfaces referenced locally) (ln_traldf_triad=T) + !! at W-points using the Griffies quarter-cells. + !! + !! ** Method : calculates alpha and beta at T-points + !! + !! ** Action : - triadi_g, triadj_g T-pts i- and j-slope triads relative to geopot. (used for eiv) + !! - triadi , triadj T-pts i- and j-slope triads relative to model-coordinate + !! - wslp2 squared slope of neutral surfaces at w-points. + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices + !! + INTEGER :: ji, jj, jk, jl, ip, jp, kp ! dummy loop indices + INTEGER :: iku, ikv ! local integer + REAL(wp) :: zfacti, zfactj ! local scalars + REAL(wp) :: znot_thru_surface ! local scalars + REAL(wp) :: zdit, zdis, zdkt, zbu, zbti, zisw + REAL(wp) :: zdjt, zdjs, zdks, zbv, zbtj, zjsw + REAL(wp) :: zdxrho_raw, zti_coord, zti_raw, zti_lim, zti_g_raw, zti_g_lim + REAL(wp) :: zdyrho_raw, ztj_coord, ztj_raw, ztj_lim, ztj_g_raw, ztj_g_lim + REAL(wp) :: zdzrho_raw + REAL(wp) :: zbeta0, ze3_e1, ze3_e2 + REAL(wp), DIMENSION(jpi,jpj) :: z1_mlbw + REAL(wp), DIMENSION(jpi,jpj,jpk,0:1) :: zdxrho , zdyrho, zdzrho ! Horizontal and vertical density gradients + REAL(wp), DIMENSION(jpi,jpj,0:1,0:1) :: zti_mlb, ztj_mlb ! for Griffies operator only + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('ldf_slp_triad') + ! + !--------------------------------! + ! Some preliminary calculation ! + !--------------------------------! + ! + DO jl = 0, 1 !== unmasked before density i- j-, k-gradients ==! + ! + ip = jl ; jp = jl ! guaranteed nonzero gradients ( absolute value larger than repsln) + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) ! done each pair of triad ! NB: not masked ==> a minimum value is set + zdit = ( ts(ji+1,jj,jk,jp_tem,Kbb) - ts(ji,jj,jk,jp_tem,Kbb) ) ! i-gradient of T & S at u-point + zdis = ( ts(ji+1,jj,jk,jp_sal,Kbb) - ts(ji,jj,jk,jp_sal,Kbb) ) + zdjt = ( ts(ji,jj+1,jk,jp_tem,Kbb) - ts(ji,jj,jk,jp_tem,Kbb) ) ! j-gradient of T & S at v-point + zdjs = ( ts(ji,jj+1,jk,jp_sal,Kbb) - ts(ji,jj,jk,jp_sal,Kbb) ) + zdxrho_raw = ( - rab_b(ji+ip,jj ,jk,jp_tem) * zdit + rab_b(ji+ip,jj ,jk,jp_sal) * zdis ) * r1_e1u(ji,jj) + zdyrho_raw = ( - rab_b(ji ,jj+jp,jk,jp_tem) * zdjt + rab_b(ji ,jj+jp,jk,jp_sal) * zdjs ) * r1_e2v(ji,jj) + zdxrho(ji+ip,jj ,jk,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw ) ! keep the sign + zdyrho(ji ,jj+jp,jk,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw ) + END DO ; END DO ; END DO + ! + IF( ln_zps .AND. l_grad_zps ) THEN ! partial steps: correction of i- & j-grad on bottom + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + iku = mbku(ji,jj) ; ikv = mbkv(ji,jj) ! last ocean level (u- & v-points) + zdit = gtsu(ji,jj,jp_tem) ; zdjt = gtsv(ji,jj,jp_tem) ! i- & j-gradient of Temperature + zdis = gtsu(ji,jj,jp_sal) ; zdjs = gtsv(ji,jj,jp_sal) ! i- & j-gradient of Salinity + zdxrho_raw = ( - rab_b(ji+ip,jj ,iku,jp_tem) * zdit + rab_b(ji+ip,jj ,iku,jp_sal) * zdis ) * r1_e1u(ji,jj) + zdyrho_raw = ( - rab_b(ji ,jj+jp,ikv,jp_tem) * zdjt + rab_b(ji ,jj+jp,ikv,jp_sal) * zdjs ) * r1_e2v(ji,jj) + zdxrho(ji+ip,jj ,iku,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw ) ! keep the sign + zdyrho(ji ,jj+jp,ikv,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw ) + END DO ; END DO + ENDIF + ! + END DO + + DO kp = 0, 1 !== unmasked before density i- j-, k-gradients ==! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! done each pair of triad ! NB: not masked ==> a minimum value is set + IF( jk+kp > 1 ) THEN ! k-gradient of T & S a jk+kp + zdkt = ( ts(ji,jj,jk+kp-1,jp_tem,Kbb) - ts(ji,jj,jk+kp,jp_tem,Kbb) ) + zdks = ( ts(ji,jj,jk+kp-1,jp_sal,Kbb) - ts(ji,jj,jk+kp,jp_sal,Kbb) ) + ELSE + zdkt = 0._wp ! 1st level gradient set to zero + zdks = 0._wp + ENDIF + zdzrho_raw = ( - rab_b(ji,jj,jk ,jp_tem) * zdkt & + & + rab_b(ji,jj,jk ,jp_sal) * zdks & + & ) / (e3w_0(ji,jj,jk+kp)*(1._wp+r3t(ji,jj,Kmm))) + zdzrho(ji,jj,jk,kp) = - MIN( - repsln , zdzrho_raw ) ! force zdzrho >= repsln + END DO ; END DO ; END DO + END DO + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) !== Reciprocal depth of the w-point below ML base ==! + jk = MIN( nmln(ji,jj), mbkt(ji,jj) ) + 1 ! MIN in case ML depth is the ocean depth + z1_mlbw(ji,jj) = 1._wp / (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + ! + ! !== intialisations to zero ==! + ! + wslp2 (:,:,:) = 0._wp ! wslp2 will be cumulated 3D field set to zero + triadi_g(:,:,1,:,:) = 0._wp ; triadi_g(:,:,jpk,:,:) = 0._wp ! set surface and bottom slope to zero + triadj_g(:,:,1,:,:) = 0._wp ; triadj_g(:,:,jpk,:,:) = 0._wp + !!gm _iso set to zero missing + triadi (:,:,1,:,:) = 0._wp ; triadj (:,:,jpk,:,:) = 0._wp ! set surface and bottom slope to zero + triadj (:,:,1,:,:) = 0._wp ; triadj (:,:,jpk,:,:) = 0._wp + + !-------------------------------------! + ! Triads just below the Mixed Layer ! + !-------------------------------------! + ! + DO jl = 0, 1 ! calculate slope of the 4 triads immediately ONE level below mixed-layer base + DO kp = 0, 1 ! with only the slope-max limit and MASKED + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + ip = jl ; jp = jl + ! + jk = nmln(ji+ip,jj) + 1 + IF( jk > mbkt(ji+ip,jj) ) THEN ! ML reaches bottom + zti_mlb(ji+ip,jj ,1-ip,kp) = 0.0_wp + ELSE + ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth) + zti_g_raw = ( zdxrho(ji+ip,jj,jk-kp,1-ip) / zdzrho(ji+ip,jj,jk-kp,kp) & + & - ( (gdept_0(ji+1,jj,jk-kp)*(1._wp+r3t(ji+1,jj,Kmm))) - (gdept_0(ji,jj,jk-kp)*(1._wp+r3t(ji,jj,Kmm))) ) * r1_e1u(ji,jj) ) * umask(ji,jj,jk) + ze3_e1 = (e3w_0(ji+ip,jj,jk-kp)*(1._wp+r3t(ji+ip,jj,Kmm))) * r1_e1u(ji,jj) + zti_mlb(ji+ip,jj ,1-ip,kp) = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e1 , ABS( zti_g_raw ) ), zti_g_raw ) + ENDIF + ! + jk = nmln(ji,jj+jp) + 1 + IF( jk > mbkt(ji,jj+jp) ) THEN !ML reaches bottom + ztj_mlb(ji ,jj+jp,1-jp,kp) = 0.0_wp + ELSE + ztj_g_raw = ( zdyrho(ji,jj+jp,jk-kp,1-jp) / zdzrho(ji,jj+jp,jk-kp,kp) & + & - ( (gdept_0(ji,jj+1,jk-kp)*(1._wp+r3t(ji,jj+1,Kmm))) - (gdept_0(ji,jj,jk-kp)*(1._wp+r3t(ji,jj,Kmm))) ) / e2v(ji,jj) ) * vmask(ji,jj,jk) + ze3_e2 = (e3w_0(ji,jj+jp,jk-kp)*(1._wp+r3t(ji,jj+jp,Kmm))) / e2v(ji,jj) + ztj_mlb(ji ,jj+jp,1-jp,kp) = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e2 , ABS( ztj_g_raw ) ), ztj_g_raw ) + ENDIF + END DO ; END DO + END DO + END DO + + !-------------------------------------! + ! Triads with surface limits ! + !-------------------------------------! + ! + DO kp = 0, 1 ! k-index of triads + DO jl = 0, 1 + ip = jl ; jp = jl ! i- and j-indices of triads (i-k and j-k planes) + DO jk = 1, jpkm1 + ! Must mask contribution to slope from dz/dx at constant s for triads jk=1,kp=0 that poke up though ocean surface + znot_thru_surface = REAL( 1-1/(jk+kp), wp ) !jk+kp=1,=0.; otherwise=1.0 + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + ! + ! Calculate slope relative to geopotentials used for GM skew fluxes + ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth) + ! Limit by slope *relative to geopotentials* by rn_slpmax, and mask by psi-point + ! masked by umask taken at the level of dz(rho) + ! + ! raw slopes: unmasked unbounded slopes (relative to geopotential (zti_g) and model surface (zti) + ! + zti_raw = zdxrho(ji+ip,jj ,jk,1-ip) / zdzrho(ji+ip,jj ,jk,kp) ! unmasked + ztj_raw = zdyrho(ji ,jj+jp,jk,1-jp) / zdzrho(ji ,jj+jp,jk,kp) + ! + ! Must mask contribution to slope for triad jk=1,kp=0 that poke up though ocean surface + zti_coord = znot_thru_surface * ( (gdept_0(ji+1,jj ,jk)*(1._wp+r3t(ji+1,jj ,Kmm))) - (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) * r1_e1u(ji,jj) + ztj_coord = znot_thru_surface * ( (gdept_0(ji ,jj+1,jk)*(1._wp+r3t(ji ,jj+1,Kmm))) - (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) * r1_e2v(ji,jj) ! unmasked + zti_g_raw = zti_raw - zti_coord ! ref to geopot surfaces + ztj_g_raw = ztj_raw - ztj_coord + ! additional limit required in bilaplacian case + ze3_e1 = (e3w_0(ji+ip,jj ,jk+kp)*(1._wp+r3t(ji+ip,jj ,Kmm))) * r1_e1u(ji,jj) + ze3_e2 = (e3w_0(ji ,jj+jp,jk+kp)*(1._wp+r3t(ji ,jj+jp,Kmm))) * r1_e2v(ji,jj) + ! NB: hard coded factor 5 (can be a namelist parameter...) + zti_g_lim = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e1, ABS( zti_g_raw ) ), zti_g_raw ) + ztj_g_lim = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e2, ABS( ztj_g_raw ) ), ztj_g_raw ) + ! + ! Below ML use limited zti_g as is & mask + ! Inside ML replace by linearly reducing sx_mlb towards surface & mask + ! + zfacti = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji+ip,jj)), wp ) ! k index of uppermost point(s) of triad is jk+kp-1 + zfactj = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji,jj+jp)), wp ) ! must be .ge. nmln(ji,jj) for zfact=1 + ! ! otherwise zfact=0 + zti_g_lim = ( zfacti * zti_g_lim & + & + ( 1._wp - zfacti ) * zti_mlb(ji+ip,jj,1-ip,kp) & + & * (gdepw_0(ji+ip,jj,jk+kp)*(1._wp+r3t(ji+ip,jj,Kmm))) * z1_mlbw(ji+ip,jj) ) * umask(ji,jj,jk+kp) + ztj_g_lim = ( zfactj * ztj_g_lim & + & + ( 1._wp - zfactj ) * ztj_mlb(ji,jj+jp,1-jp,kp) & + & * (gdepw_0(ji,jj+jp,jk+kp)*(1._wp+r3t(ji,jj+jp,Kmm))) * z1_mlbw(ji,jj+jp) ) * vmask(ji,jj,jk+kp) + ! + triadi_g(ji+ip,jj ,jk,1-ip,kp) = zti_g_lim + triadj_g(ji ,jj+jp,jk,1-jp,kp) = ztj_g_lim + ! + ! Get coefficients of isoneutral diffusion tensor + ! 1. Utilise gradients *relative* to s-coordinate, so add t-point slopes (*subtract* depth gradients) + ! 2. We require that isoneutral diffusion gives no vertical buoyancy flux + ! i.e. 33 term = (real slope* 31, 13 terms) + ! To do this, retain limited sx**2 in vertical flux, but divide by real slope for 13/31 terms + ! Equivalent to tapering A_iso = sx_limited**2/(real slope)**2 + ! + zti_lim = ( zti_g_lim + zti_coord ) * umask(ji,jj,jk+kp) ! remove coordinate slope => relative to coordinate surfaces + ztj_lim = ( ztj_g_lim + ztj_coord ) * vmask(ji,jj,jk+kp) + ! + IF( ln_triad_iso ) THEN + zti_raw = zti_lim*zti_lim / zti_raw + ztj_raw = ztj_lim*ztj_lim / ztj_raw + zti_raw = SIGN( MIN( ABS(zti_lim), ABS( zti_raw ) ), zti_raw ) + ztj_raw = SIGN( MIN( ABS(ztj_lim), ABS( ztj_raw ) ), ztj_raw ) + zti_lim = zfacti * zti_lim + ( 1._wp - zfacti ) * zti_raw + ztj_lim = zfactj * ztj_lim + ( 1._wp - zfactj ) * ztj_raw + ENDIF + ! ! switching triad scheme + zisw = (1._wp - rn_sw_triad ) + rn_sw_triad & + & * 2._wp * ABS( 0.5_wp - kp - ( 0.5_wp - ip ) * SIGN( 1._wp , zdxrho(ji+ip,jj,jk,1-ip) ) ) + zjsw = (1._wp - rn_sw_triad ) + rn_sw_triad & + & * 2._wp * ABS( 0.5_wp - kp - ( 0.5_wp - jp ) * SIGN( 1._wp , zdyrho(ji,jj+jp,jk,1-jp) ) ) + ! + triadi(ji+ip,jj ,jk,1-ip,kp) = zti_lim * zisw + triadj(ji ,jj+jp,jk,1-jp,kp) = ztj_lim * zjsw + ! + zbu = e1e2u(ji ,jj ) * (e3u_0(ji ,jj ,jk )*(1._wp+r3u(ji ,jj ,Kmm)*umask(ji ,jj ,jk ))) + zbv = e1e2v(ji ,jj ) * (e3v_0(ji ,jj ,jk )*(1._wp+r3v(ji ,jj ,Kmm)*vmask(ji ,jj ,jk ))) + zbti = e1e2t(ji+ip,jj ) * (e3w_0(ji+ip,jj ,jk+kp)*(1._wp+r3t(ji+ip,jj ,Kmm))) + zbtj = e1e2t(ji ,jj+jp) * (e3w_0(ji ,jj+jp,jk+kp)*(1._wp+r3t(ji ,jj+jp,Kmm))) + ! + wslp2(ji+ip,jj,jk+kp) = wslp2(ji+ip,jj,jk+kp) + 0.25_wp * zbu / zbti * zti_g_lim*zti_g_lim ! masked + wslp2(ji,jj+jp,jk+kp) = wslp2(ji,jj+jp,jk+kp) + 0.25_wp * zbv / zbtj * ztj_g_lim*ztj_g_lim + END DO ; END DO + END DO + END DO + END DO + ! + wslp2(:,:,1) = 0._wp ! force the surface wslp to zero + + CALL lbc_lnk( 'ldfslp', wslp2, 'W', 1.0_wp ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked + ! + IF( ln_timing ) CALL timing_stop('ldf_slp_triad') + ! + END SUBROUTINE ldf_slp_triad + + + SUBROUTINE ldf_slp_mxl( prd, pn2, p_gru, p_grv, p_dzr, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_slp_mxl *** + !! + !! ** Purpose : Compute the slopes of iso-neutral surface just below + !! the mixed layer. + !! + !! ** Method : The slope in the i-direction is computed at u- & w-points + !! (uslpml, wslpiml) and the slope in the j-direction is computed + !! at v- and w-points (vslpml, wslpjml) with the same bounds as + !! in ldf_slp. + !! + !! ** Action : uslpml, wslpiml : i- & j-slopes of neutral surfaces + !! vslpml, wslpjml just below the mixed layer + !! omlmask : mixed layer mask + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: prd ! in situ density + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pn2 ! Brunt-Vaisala frequency (locally ref.) + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: p_gru, p_grv ! i- & j-gradient of density (u- & v-pts) + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: p_dzr ! z-gradient of density (T-point) + INTEGER , INTENT(in) :: Kmm ! ocean time level indices + !! + INTEGER :: ji , jj , jk ! dummy loop indices + INTEGER :: iku, ikv, ik, ikm1 ! local integers + REAL(wp) :: zeps, zm1_g, zm1_2g, z1_slpmax ! local scalars + REAL(wp) :: zci, zfi, zau, zbu, zai, zbi ! - - + REAL(wp) :: zcj, zfj, zav, zbv, zaj, zbj ! - - + REAL(wp) :: zck, zfk, zbw ! - - + !!---------------------------------------------------------------------- + ! + zeps = 1.e-20_wp !== Local constant initialization ==! + zm1_g = -1.0_wp / grav + zm1_2g = -0.5_wp / grav + z1_slpmax = 1._wp / rn_slpmax + ! + uslpml (1,:) = 0._wp ; uslpml (jpi,:) = 0._wp + vslpml (1,:) = 0._wp ; vslpml (jpi,:) = 0._wp + wslpiml(1,:) = 0._wp ; wslpiml(jpi,:) = 0._wp + wslpjml(1,:) = 0._wp ; wslpjml(jpi,:) = 0._wp + ! + ! !== surface mixed layer mask ! + DO jk = 1, jpk ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) ! =1 inside the mixed layer, =0 otherwise + ik = nmln(ji,jj) - 1 + IF( jk <= ik ) THEN ; omlmask(ji,jj,jk) = 1._wp + ELSE ; omlmask(ji,jj,jk) = 0._wp + ENDIF + END DO ; END DO ; END DO + + + ! Slopes of isopycnal surfaces just before bottom of mixed layer + ! -------------------------------------------------------------- + ! The slope are computed as in the 3D case. + ! A key point here is the definition of the mixed layer at u- and v-points. + ! It is assumed to be the maximum of the two neighbouring T-point mixed layer depth. + ! Otherwise, a n2 value inside the mixed layer can be involved in the computation + ! of the slope, resulting in a too steep diagnosed slope and thus a spurious eddy + ! induce velocity field near the base of the mixed layer. + !----------------------------------------------------------------------- + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ! !== Slope at u- & v-points just below the Mixed Layer ==! + ! + ! !- vertical density gradient for u- and v-slopes (from dzr at T-point) + iku = MIN( MAX( 1, nmln(ji,jj) , nmln(ji+1,jj) ) , jpkm1 ) ! ML (MAX of T-pts, bound by jpkm1) + ikv = MIN( MAX( 1, nmln(ji,jj) , nmln(ji,jj+1) ) , jpkm1 ) ! + zbu = 0.5_wp * ( p_dzr(ji,jj,iku) + p_dzr(ji+1,jj ,iku) ) + zbv = 0.5_wp * ( p_dzr(ji,jj,ikv) + p_dzr(ji ,jj+1,ikv) ) + ! !- horizontal density gradient at u- & v-points + zau = p_gru(ji,jj,iku) * r1_e1u(ji,jj) + zav = p_grv(ji,jj,ikv) * r1_e2v(ji,jj) + ! !- bound the slopes: abs(zw.)<= 1/100 and zb..<0 + ! kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) + zbu = MIN( zbu , - z1_slpmax * ABS( zau ) , -7.e+3_wp/(e3u_0(ji,jj,iku)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,iku)))* ABS( zau ) ) + zbv = MIN( zbv , - z1_slpmax * ABS( zav ) , -7.e+3_wp/(e3v_0(ji,jj,ikv)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,ikv)))* ABS( zav ) ) + ! !- Slope at u- & v-points (uslpml, vslpml) + uslpml(ji,jj) = zau / ( zbu - zeps ) * umask(ji,jj,iku) + vslpml(ji,jj) = zav / ( zbv - zeps ) * vmask(ji,jj,ikv) + ! + ! !== i- & j-slopes at w-points just below the Mixed Layer ==! + ! + ik = MIN( nmln(ji,jj) + 1, jpk ) + ikm1 = MAX( 1, ik-1 ) + ! !- vertical density gradient for w-slope (from N^2) + zbw = zm1_2g * pn2 (ji,jj,ik) * ( prd (ji,jj,ik) + prd (ji,jj,ikm1) + 2. ) + ! !- horizontal density i- & j-gradient at w-points + zci = MAX( umask(ji-1,jj,ik ) + umask(ji,jj,ik ) & + & + umask(ji-1,jj,ikm1) + umask(ji,jj,ikm1) , zeps ) * e1t(ji,jj) + zcj = MAX( vmask(ji,jj-1,ik ) + vmask(ji,jj,ik ) & + & + vmask(ji,jj-1,ikm1) + vmask(ji,jj,ikm1) , zeps ) * e2t(ji,jj) + zai = ( p_gru(ji-1,jj,ik ) + p_gru(ji,jj,ik) & + & + p_gru(ji-1,jj,ikm1) + p_gru(ji,jj,ikm1 ) ) / zci * tmask(ji,jj,ik) + zaj = ( p_grv(ji,jj-1,ik ) + p_grv(ji,jj,ik ) & + & + p_grv(ji,jj-1,ikm1) + p_grv(ji,jj,ikm1) ) / zcj * tmask(ji,jj,ik) + ! !- bound the slopes: abs(zw.)<= 1/100 and zb..<0. + ! kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) + zbi = MIN( zbw , -100._wp* ABS( zai ) , -7.e+3_wp/(e3w_0(ji,jj,ik)*(1._wp+r3t(ji,jj,Kmm)))* ABS( zai ) ) + zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/(e3w_0(ji,jj,ik)*(1._wp+r3t(ji,jj,Kmm)))* ABS( zaj ) ) + ! !- i- & j-slope at w-points (wslpiml, wslpjml) + wslpiml(ji,jj) = zai / ( zbi - zeps ) * tmask (ji,jj,ik) + wslpjml(ji,jj) = zaj / ( zbj - zeps ) * tmask (ji,jj,ik) + END DO ; END DO + !!gm this lbc_lnk should be useless.... + CALL lbc_lnk( 'ldfslp', uslpml , 'U', -1.0_wp , vslpml , 'V', -1.0_wp , wslpiml, 'W', -1.0_wp , wslpjml, 'W', -1.0_wp ) + ! + END SUBROUTINE ldf_slp_mxl + + + SUBROUTINE ldf_slp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_slp_init *** + !! + !! ** Purpose : Initialization for the isopycnal slopes computation + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ierr ! local integer + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'ldf_slp_init : direction of lateral mixing' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + ALLOCATE( ah_wslp2(jpi,jpj,jpk) , akz(jpi,jpj,jpk) , STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate ah_slp2 or akz' ) + ! + IF( ln_traldf_triad ) THEN ! Griffies operator : triad of slopes + IF(lwp) WRITE(numout,*) ' ==>>> triad) operator (Griffies)' + ALLOCATE( triadi_g(jpi,jpj,jpk,0:1,0:1) , triadj_g(jpi,jpj,jpk,0:1,0:1) , & + & triadi (jpi,jpj,jpk,0:1,0:1) , triadj (jpi,jpj,jpk,0:1,0:1) , & + & wslp2 (jpi,jpj,jpk) , STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Griffies operator slope' ) + IF( ln_dynldf_iso ) CALL ctl_stop( 'ldf_slp_init: Griffies operator on momentum not supported' ) + ! + ELSE ! Madec operator : slopes at u-, v-, and w-points + IF(lwp) WRITE(numout,*) ' ==>>> iso operator (Madec)' + ALLOCATE( omlmask(jpi,jpj,jpk) , & + & uslp(jpi,jpj,jpk) , uslpml(jpi,jpj) , wslpi(jpi,jpj,jpk) , wslpiml(jpi,jpj) , & + & vslp(jpi,jpj,jpk) , vslpml(jpi,jpj) , wslpj(jpi,jpj,jpk) , wslpjml(jpi,jpj) , STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' ) + + ! Direction of lateral diffusion (tracers and/or momentum) + ! ------------------------------ + uslp (:,:,:) = 0._wp ; uslpml (:,:) = 0._wp ! set the slope to zero (even in s-coordinates) + vslp (:,:,:) = 0._wp ; vslpml (:,:) = 0._wp + wslpi(:,:,:) = 0._wp ; wslpiml(:,:) = 0._wp + wslpj(:,:,:) = 0._wp ; wslpjml(:,:) = 0._wp + + !!gm I no longer understand this..... +!!gm IF( (ln_traldf_hor .OR. ln_dynldf_hor) .AND. .NOT. (.NOT.ln_linssh .AND. ln_rstart) ) THEN +! IF(lwp) WRITE(numout,*) ' Horizontal mixing in s-coordinate: slope = slope of s-surfaces' +! +! ! geopotential diffusion in s-coordinates on tracers and/or momentum +! ! The slopes of s-surfaces are computed once (no call to ldfslp in step) +! ! The slopes for momentum diffusion are i- or j- averaged of those on tracers +! +! ! set the slope of diffusion to the slope of s-surfaces +! ! ( c a u t i o n : minus sign as dep has positive value ) +! DO jk = 1, jpk +! DO jj = 2, jpjm1 +! DO ji = 2, jpim1 ! vector opt. +! uslp (ji,jj,jk) = - ( (gdept_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kmm))) - (gdept_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kmm))) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) +! vslp (ji,jj,jk) = - ( (gdept_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kmm))) - (gdept_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kmm))) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) +! wslpi(ji,jj,jk) = - ( (gdepw_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kmm))) - (gdepw_0(ji-1,jj,jk)*(1._wp+r3t(ji-1,jj,Kmm))) ) * r1_e1t(ji,jj) * wmask(ji,jj,jk) * 0.5 +! wslpj(ji,jj,jk) = - ( (gdepw_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kmm))) - (gdepw_0(ji,jj-1,jk)*(1._wp+r3t(ji,jj-1,Kmm))) ) * r1_e2t(ji,jj) * wmask(ji,jj,jk) * 0.5 +! END DO +! END DO +! END DO +! CALL lbc_lnk( 'ldfslp', uslp , 'U', -1. ; CALL lbc_lnk( 'ldfslp', vslp , 'V', -1., wslpi, 'W', -1., wslpj, 'W', -1. ) +!!gm ENDIF + ENDIF + ! + END SUBROUTINE ldf_slp_init + + !!====================================================================== +END MODULE ldfslp diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldftra.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldftra.f90 new file mode 100644 index 0000000000000000000000000000000000000000..00cb8e759cd0e48f2a71a3978b3780dda458e00c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ldftra.f90 @@ -0,0 +1,928 @@ + + + + + + + + + + + + + +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) + ! != 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] + + ! ! 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 + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ldftra.F90 15475 2021-11-05 14:14:45Z cdllod $ + !! 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._dp ) + CALL iom_get ( inum, jpdom_global, 'ahtv_2D', ahtv(:,:,1), cd_type = 'V', psgn = 1._dp ) + 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._dp ) + CALL iom_get ( inum, jpdom_global, 'ahtv_3D', ahtv, cd_type = 'V', psgn = 1._dp ) + 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 jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( 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 DO ; END DO + 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 + !!---------------------------------------------------------------------- + ! + 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._dp ) + CALL iom_get ( inum, jpdom_global, 'aeiv', aeiv(:,:,1), cd_type = 'V', psgn = 1._dp ) + 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' + ! + 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._dp ) + CALL iom_get ( inum, jpdom_global, 'aeiv', aeiv, cd_type = 'V', psgn = 1._dp ) + 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 ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zn, zah, zhw, zRo, zaeiw ! 2D workspace + !!---------------------------------------------------------------------- + ! + zn (:,:) = 0._wp ! Local initialization + zhw(:,:) = 5._wp + zah(:,:) = 0._wp + zRo(:,:) = 0._wp + ! ! Compute lateral diffusive coefficient at T-point + IF( ln_traldf_triad ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ! 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_0(ji,jj,jk)*(1._wp+r3t(ji,jj,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_0(ji,jj,jk)*(1._wp+r3t(ji,jj,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 DO ; END DO ; END DO + ELSE + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ! 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_0(ji,jj,jk)*(1._wp+r3t(ji,jj,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_0(ji,jj,jk)*(1._wp+r3t(ji,jj,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 DO ; END DO ; END DO + ENDIF + + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( 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) = MAX( 2.e3 , MIN( .4 * zn(ji,jj) / zfw, 40.e3 ) ) + ! Compute aeiw by multiplying Ro^2 and T^-1 + zaeiw(ji,jj) = zRo(ji,jj) * zRo(ji,jj) * SQRT( zah(ji,jj) / zhw(ji,jj) ) * tmask(ji,jj,1) + END DO ; END DO + + ! !== Bound on eiv coeff. ==! + z1_f20 = 1._wp / ( 2._wp * omega * sin( rad * 20._wp ) ) + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( 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 DO ; END DO + IF( nn_hls == 1 ) CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1.0_wp ) ! lateral boundary condition + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 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 DO ; END DO + 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 ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(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(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(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 jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + 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 DO ; END DO ; END DO + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls)*nthr) + 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 DO ; END DO ; END DO + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + 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 DO ; END DO ; END DO + ! + ! ! diagnose the eddy induced velocity and associated heat transport + IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) + ! + 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(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(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(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zw2d ! 2D workspace + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(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 jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! 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_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) ) + END DO ; END DO ; END DO + CALL iom_put( "uoce_eiv", zw3d ) + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! 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_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) ) + END DO ; END DO ; END DO + CALL iom_put( "voce_eiv", zw3d ) + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! 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 DO ; END DO ; END DO + CALL iom_put( "woce_eiv", zw3d ) + ! + IF( iom_use('weiv_masstr') ) THEN ! vertical mass transport & its square value + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zw2d(ji,jj) = rho0 * e1e2t(ji,jj) + END DO ; END DO + 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 jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + 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 DO ; END DO ; END DO + 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 jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + 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 DO ; END DO ; END DO + 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' ) ) 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 + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + 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 DO ; END DO ; END DO + 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 jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + 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 DO ; END DO ; END DO + 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' ) ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5_wp * zw3d ) + ! + ! + END SUBROUTINE ldf_eiv_dia + + !!====================================================================== +END MODULE ldftra diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lib_fortran.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lib_fortran.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3cc8da0aaf280380541e72d40d3bf77b510b77ca --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lib_fortran.f90 @@ -0,0 +1,723 @@ + + + + + + + + + + + + + +MODULE lib_fortran + !!====================================================================== + !! *** MODULE lib_fortran *** + !! Fortran utilities: includes some low levels fortran functionality + !!====================================================================== + !! History : 3.2 ! 2010-05 (M. Dunphy, R. Benshila) Original code + !! 3.4 ! 2013-06 (C. Rousset) add glob_min, glob_max + !! + 3d dim. of input is fexible (jpk, jpl...) + !! 4.0 ! 2016-06 (T. Lovato) double precision global sum by default + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! glob_sum : generic interface for global masked summation over + !! the interior domain for 1 or 2 2D or 3D arrays + !! it works only for T points + !! SIGN : generic interface for SIGN to overwrite f95 behaviour + !! of intrinsinc sign function + !!---------------------------------------------------------------------- + USE par_oce ! Ocean parameter + USE dom_oce ! ocean domain + USE in_out_manager ! I/O manager + USE lib_mpp ! distributed memory computing + USE lbclnk ! ocean lateral boundary conditions + + IMPLICIT NONE + PRIVATE + + PUBLIC glob_sum ! used in many places (masked with tmask_i = ssmask * (excludes halo+duplicated points (NP folding)) ) + PUBLIC local_sum ! used in trcrad, local operation before glob_sum_delay + PUBLIC sum3x3 ! used in trcrad, do a sum over 3x3 boxes + PUBLIC DDPDD ! also used in closea module + PUBLIC glob_min, glob_max + PUBLIC glob_sum_vec + PUBLIC glob_min_vec, glob_max_vec + + INTERFACE glob_sum + MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d + END INTERFACE + INTERFACE local_sum + MODULE PROCEDURE local_sum_2d, local_sum_3d + END INTERFACE + INTERFACE sum3x3 + MODULE PROCEDURE sum3x3_2d, sum3x3_3d + END INTERFACE + INTERFACE glob_min + MODULE PROCEDURE glob_min_2d, glob_min_3d + END INTERFACE + INTERFACE glob_max + MODULE PROCEDURE glob_max_2d, glob_max_3d + END INTERFACE + INTERFACE glob_sum_vec + MODULE PROCEDURE glob_sum_vec_3d, glob_sum_vec_4d + END INTERFACE + INTERFACE glob_min_vec + MODULE PROCEDURE glob_min_vec_3d, glob_min_vec_4d + END INTERFACE + INTERFACE glob_max_vec + MODULE PROCEDURE glob_max_vec_3d, glob_max_vec_4d + END INTERFACE + + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lib_fortran.F90 15376 2021-10-14 20:41:23Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +! ! FUNCTION FUNCTION_GLOBSUM ! + + FUNCTION glob_sum_1d( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:) ! array on which operation is applied + REAL(wp) :: glob_sum_1d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(wp) :: ztmp + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ipi,ipj, ipk ! dimensions + INTEGER :: iis, iie, ijs, ije ! loop start and end + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = 1 ! 2nd dimension + ipk = 1 ! 3rd dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) + iis = Nis0 ; iie = Nie0 + ijs = Njs0 ; ije = Nje0 + ELSE + iis = 1 ; iie = jpi + ijs = 1 ; ije = jpj + ENDIF + ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + DO jk = 1, ipk + DO jj = ijs, ije + DO ji = iis, iie + ztmp = ptab(ji) * 1. + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END DO + END DO + END DO + CALL mpp_sum( cdname, ctmp ) ! sum over the global domain + glob_sum_1d = REAL(ctmp,wp) + + END FUNCTION glob_sum_1d + +! +! ! FUNCTION FUNCTION_GLOBSUM ! + + FUNCTION glob_sum_2d( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:) ! array on which operation is applied + REAL(wp) :: glob_sum_2d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(wp) :: ztmp + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ipi,ipj, ipk ! dimensions + INTEGER :: iis, iie, ijs, ije ! loop start and end + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ipk = 1 ! 3rd dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) + iis = Nis0 ; iie = Nie0 + ijs = Njs0 ; ije = Nje0 + ELSE + iis = 1 ; iie = jpi + ijs = 1 ; ije = jpj + ENDIF + ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + DO jk = 1, ipk + DO jj = ijs, ije + DO ji = iis, iie + ztmp = ptab(ji,jj) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END DO + END DO + END DO + CALL mpp_sum( cdname, ctmp ) ! sum over the global domain + glob_sum_2d = REAL(ctmp,wp) + + END FUNCTION glob_sum_2d + +! +! ! FUNCTION FUNCTION_GLOBSUM ! + + FUNCTION glob_sum_3d( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied + REAL(wp) :: glob_sum_3d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(wp) :: ztmp + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ipi,ipj, ipk ! dimensions + INTEGER :: iis, iie, ijs, ije ! loop start and end + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ipk = SIZE(ptab,3) ! 3rd dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) + iis = Nis0 ; iie = Nie0 + ijs = Njs0 ; ije = Nje0 + ELSE + iis = 1 ; iie = jpi + ijs = 1 ; ije = jpj + ENDIF + ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + DO jk = 1, ipk + DO jj = ijs, ije + DO ji = iis, iie + ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END DO + END DO + END DO + CALL mpp_sum( cdname, ctmp ) ! sum over the global domain + glob_sum_3d = REAL(ctmp,wp) + + END FUNCTION glob_sum_3d + +! + +! ! FUNCTION FUNCTION_GLOBMINMAX ! + + FUNCTION glob_min_2d( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:) ! array on which operation is applied + REAL(wp) :: glob_min_2d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(wp) :: ztmp + INTEGER :: jk ! dummy loop indices + INTEGER :: ipk ! dimensions + !!----------------------------------------------------------------------- + ! + ipk = 1 ! 3rd dimension + ! + ztmp = minval( ptab(:,:)*tmask_i(:,:) ) + DO jk = 2, ipk + ztmp = min(ztmp, minval( ptab(:,:)*tmask_i(:,:) )) + ENDDO + + CALL mpp_min( cdname, ztmp) + + glob_min_2d = ztmp + + END FUNCTION glob_min_2d + +! ! FUNCTION FUNCTION_GLOBMINMAX ! + + FUNCTION glob_max_2d( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:) ! array on which operation is applied + REAL(wp) :: glob_max_2d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(wp) :: ztmp + INTEGER :: jk ! dummy loop indices + INTEGER :: ipk ! dimensions + !!----------------------------------------------------------------------- + ! + ipk = 1 ! 3rd dimension + ! + ztmp = maxval( ptab(:,:)*tmask_i(:,:) ) + DO jk = 2, ipk + ztmp = max(ztmp, maxval( ptab(:,:)*tmask_i(:,:) )) + ENDDO + + CALL mpp_max( cdname, ztmp) + + glob_max_2d = ztmp + + END FUNCTION glob_max_2d + +! ! FUNCTION FUNCTION_GLOBMINMAX ! + + FUNCTION glob_min_3d( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied + REAL(wp) :: glob_min_3d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(wp) :: ztmp + INTEGER :: jk ! dummy loop indices + INTEGER :: ipk ! dimensions + !!----------------------------------------------------------------------- + ! + ipk = SIZE(ptab,3) ! 3rd dimension + ! + ztmp = minval( ptab(:,:,1)*tmask_i(:,:) ) + DO jk = 2, ipk + ztmp = min(ztmp, minval( ptab(:,:,jk)*tmask_i(:,:) )) + ENDDO + + CALL mpp_min( cdname, ztmp) + + glob_min_3d = ztmp + + END FUNCTION glob_min_3d + +! ! FUNCTION FUNCTION_GLOBMINMAX ! + + FUNCTION glob_max_3d( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied + REAL(wp) :: glob_max_3d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(wp) :: ztmp + INTEGER :: jk ! dummy loop indices + INTEGER :: ipk ! dimensions + !!----------------------------------------------------------------------- + ! + ipk = SIZE(ptab,3) ! 3rd dimension + ! + ztmp = maxval( ptab(:,:,1)*tmask_i(:,:) ) + DO jk = 2, ipk + ztmp = max(ztmp, maxval( ptab(:,:,jk)*tmask_i(:,:) )) + ENDDO + + CALL mpp_max( cdname, ztmp) + + glob_max_3d = ztmp + + END FUNCTION glob_max_3d + + +! ! FUNCTION local_sum ! + + FUNCTION local_sum_2d( ptab ) + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:), INTENT(in ) :: ptab ! array on which operation is applied + COMPLEX(dp) :: local_sum_2d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(dp) :: ztmp + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ipi, ipj ! dimensions + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + + DO jj = 1, ipj + DO ji = 1, ipi + ztmp = ptab(ji,jj) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END DO + END DO + ! + local_sum_2d = ctmp + + END FUNCTION local_sum_2d + + FUNCTION local_sum_3d( ptab ) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptab ! array on which operation is applied + COMPLEX(dp) :: local_sum_3d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(dp) :: ztmp + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ipi, ipj, ipk ! dimensions + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ipk = SIZE(ptab,3) ! 3rd dimension + ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + + DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END DO + END DO + END DO + ! + local_sum_3d = ctmp + + END FUNCTION local_sum_3d + +! ! FUNCTION sum3x3 ! + + SUBROUTINE sum3x3_2d( p2d ) + !!----------------------------------------------------------------------- + !! *** routine sum3x3_2d *** + !! + !! ** Purpose : sum over 3x3 boxes + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION (:,:), INTENT(inout) :: p2d + ! + INTEGER :: ji, ji2, jj, jj2 ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( SIZE(p2d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the first dimension is not equal to jpi' ) + IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' ) + ! + ! work over the whole domain (guarantees all internal cells are set when nn_hls=2) + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1) + & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box + ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box + jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box + IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain + p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2)) + ENDIF + ENDIF + END DO ; END DO + CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) + ! no need for 2nd exchange when nn_hls > 1 + IF( nn_hls == 1 ) THEN + IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN ! 1st column was changed during the previous call to lbc_lnk + IF( MOD(mig( 1), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally + p2d( 1,:) = p2d( 2,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2 + IF( MOD(mig( 1), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh + p2d( 2,:) = p2d( 1,:) ! previous lbc_lnk fix column 1 -> copy it to column 2 + ENDIF + IF( mpiRnei(nn_hls,jpea) > -1 ) THEN + IF( MOD(mig(jpi-2), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:) + IF( MOD(mig(jpi-2), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:) + ENDIF + IF( mpiRnei(nn_hls,jpso) > -1 ) THEN + IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2) + IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1) + ENDIF + IF( mpiRnei(nn_hls,jpno) > -1 ) THEN + IF( MOD(mjg(jpj-2), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1) + IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj) + ENDIF + CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) + ENDIF + + END SUBROUTINE sum3x3_2d + + SUBROUTINE sum3x3_3d( p3d ) + !!----------------------------------------------------------------------- + !! *** routine sum3x3_3d *** + !! + !! ** Purpose : sum over 3x3 boxes + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION (:,:,:), INTENT(inout) :: p3d + ! + INTEGER :: ji, ji2, jj, jj2, jn ! dummy loop indices + INTEGER :: ipn ! Third dimension size + !!---------------------------------------------------------------------- + ! + IF( SIZE(p3d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the first dimension is not equal to jpi' ) + IF( SIZE(p3d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the second dimension is not equal to jpj' ) + ipn = SIZE(p3d,3) + ! + DO jn = 1, ipn + ! + ! work over the whole domain (guarantees all internal cells are set when nn_hls=2) + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1) + & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box + ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box + jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box + IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain + p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn)) + ENDIF + ENDIF + END DO ; END DO + END DO + CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) + ! no need for 2nd exchange when nn_hls > 1 + IF( nn_hls == 1 ) THEN + IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN ! 1st column was changed during the previous call to lbc_lnk + IF( MOD(mig( 1), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally + p3d( 1,:,:) = p3d( 2,:,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2 + IF( MOD(mig( 1), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh + p3d( 2,:,:) = p3d( 1,:,:) ! previous lbc_lnk fix column 1 -> copy it to column 2 + ENDIF + IF( mpiRnei(nn_hls,jpea) > -1 ) THEN + IF( MOD(mig(jpi-2), 3) == 1 ) p3d( jpi,:,:) = p3d(jpi-1,:,:) + IF( MOD(mig(jpi-2), 3) == 0 ) p3d(jpi-1,:,:) = p3d( jpi,:,:) + ENDIF + IF( mpiRnei(nn_hls,jpso) > -1 ) THEN + IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:) + IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:) + ENDIF + IF( mpiRnei(nn_hls,jpno) > -1 ) THEN + IF( MOD(mjg(jpj-2), 3) == 1 ) p3d(:, jpj,:) = p3d(:,jpj-1,:) + IF( MOD(mjg(jpj-2), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:) + ENDIF + CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) + ENDIF + + END SUBROUTINE sum3x3_3d + + + FUNCTION glob_sum_vec_3d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,3)) :: ptmp + ! + COMPLEX(dp), DIMENSION(:), ALLOCATABLE :: ctmp + REAL(dp) :: ztmp + INTEGER :: ji , jj , jk ! dummy loop indices + INTEGER :: ipi, ipj, ipk ! dimensions + INTEGER :: iis, iie, ijs, ije ! loop start and end + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ipk = SIZE(ptab,3) ! 3rd dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) + iis = Nis0 ; iie = Nie0 + ijs = Njs0 ; ije = Nje0 + ELSE ! I think we are never in this case... + iis = 1 ; iie = jpi + ijs = 1 ; ije = jpj + ENDIF + ! + ALLOCATE( ctmp(ipk) ) + ! + DO jk = 1, ipk + ctmp(jk) = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + DO jj = ijs, ije + DO ji = iis, iie + ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp(jk) ) + END DO + END DO + END DO + CALL mpp_sum( cdname, ctmp(:) ) ! sum over the global domain + ! + ptmp = REAL( ctmp(:), dp ) + ! + DEALLOCATE( ctmp ) + ! + END FUNCTION glob_sum_vec_3d + + FUNCTION glob_sum_vec_4d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,4)) :: ptmp + ! + COMPLEX(dp), DIMENSION(:), ALLOCATABLE :: ctmp + REAL(dp) :: ztmp + INTEGER :: ji , jj , jk , jl ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl ! dimensions + INTEGER :: iis, iie, ijs, ije ! loop start and end + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ipk = SIZE(ptab,3) ! 3rd dimension + ipl = SIZE(ptab,4) ! 4th dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) + iis = Nis0 ; iie = Nie0 + ijs = Njs0 ; ije = Nje0 + ELSE ! I think we are never in this case... + iis = 1 ; iie = jpi + ijs = 1 ; ije = jpj + ENDIF + ! + ALLOCATE( ctmp(ipl) ) + ! + DO jl = 1, ipl + ctmp(jl) = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + DO jk = 1, ipk + DO jj = ijs, ije + DO ji = iis, iie + ztmp = ptab(ji,jj,jk,jl) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp(jl) ) + END DO + END DO + END DO + END DO + CALL mpp_sum( cdname, ctmp(:) ) ! sum over the global domain + ! + ptmp = REAL( ctmp(:), dp ) + ! + DEALLOCATE( ctmp ) + ! + END FUNCTION glob_sum_vec_4d + + FUNCTION glob_min_vec_3d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,3)) :: ptmp + ! + INTEGER :: jk ! dummy loop indice & dimension + INTEGER :: ipk ! dimension + !!----------------------------------------------------------------------- + ! + ipk = SIZE(ptab,3) + DO jk = 1, ipk + ptmp(jk) = MINVAL( ptab(:,:,jk) * tmask_i(:,:) ) + ENDDO + ! + CALL mpp_min( cdname, ptmp (:) ) + ! + END FUNCTION glob_min_vec_3d + + FUNCTION glob_min_vec_4d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,4)) :: ptmp + ! + INTEGER :: jk , jl ! dummy loop indice & dimension + INTEGER :: ipk, ipl ! dimension + !!----------------------------------------------------------------------- + ! + ipk = SIZE(ptab,3) + ipl = SIZE(ptab,4) + DO jl = 1, ipl + ptmp(jl) = MINVAL( ptab(:,:,1,jl) * tmask_i(:,:) ) + DO jk = 2, ipk + ptmp(jl) = MIN( ptmp(jl), MINVAL( ptab(:,:,jk,jl) * tmask_i(:,:) ) ) + ENDDO + ENDDO + ! + CALL mpp_min( cdname, ptmp (:) ) + ! + END FUNCTION glob_min_vec_4d + + FUNCTION glob_max_vec_3d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,3)) :: ptmp + ! + INTEGER :: jk ! dummy loop indice & dimension + INTEGER :: ipk ! dimension + !!----------------------------------------------------------------------- + ! + ipk = SIZE(ptab,3) + DO jk = 1, ipk + ptmp(jk) = MAXVAL( ptab(:,:,jk) * tmask_i(:,:) ) + ENDDO + ! + CALL mpp_max( cdname, ptmp (:) ) + ! + END FUNCTION glob_max_vec_3d + + FUNCTION glob_max_vec_4d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,4)) :: ptmp + ! + INTEGER :: jk , jl ! dummy loop indice & dimension + INTEGER :: ipk, ipl ! dimension + !!----------------------------------------------------------------------- + ! + ipk = SIZE(ptab,3) + ipl = SIZE(ptab,4) + DO jl = 1, ipl + ptmp(jl) = MAXVAL( ptab(:,:,1,jl) * tmask_i(:,:) ) + DO jk = 2, ipk + ptmp(jl) = MAX( ptmp(jl), MAXVAL( ptab(:,:,jk,jl) * tmask_i(:,:) ) ) + ENDDO + ENDDO + ! + CALL mpp_max( cdname, ptmp (:) ) + ! + END FUNCTION glob_max_vec_4d + + SUBROUTINE DDPDD( ydda, yddb ) + !!---------------------------------------------------------------------- + !! *** ROUTINE DDPDD *** + !! + !! ** Purpose : Add a scalar element to a sum + !! + !! + !! ** Method : The code uses the compensated summation with doublet + !! (sum,error) emulated using complex numbers. ydda is the + !! scalar to add to the summ yddb + !! + !! ** Action : This does only work for MPI. + !! + !! References : Using Acurate Arithmetics to Improve Numerical + !! Reproducibility and Sability in Parallel Applications + !! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001 + !!---------------------------------------------------------------------- + COMPLEX(dp), INTENT(in ) :: ydda + COMPLEX(dp), INTENT(inout) :: yddb + ! + REAL(dp) :: zerr, zt1, zt2 ! local work variables + !!----------------------------------------------------------------------- + ! + ! Compute ydda + yddb using Knuth's trick. + zt1 = REAL(ydda) + REAL(yddb) + zerr = zt1 - REAL(ydda) + zt2 = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) ) & + & + AIMAG(ydda) + AIMAG(yddb) + ! + ! The result is t1 + t2, after normalization. + yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), dp ) + ! + END SUBROUTINE DDPDD + + + !!====================================================================== +END MODULE lib_fortran diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lib_mpp.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lib_mpp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b7027cba8a2c03f454dab4476fb5a2c3f894cbba --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/lib_mpp.f90 @@ -0,0 +1,2748 @@ + + + + + + + + + + + + + +MODULE lib_mpp + !!====================================================================== + !! *** MODULE lib_mpp *** + !! Ocean numerics: massively parallel processing library + !!===================================================================== + !! History : OPA ! 1994 (M. Guyon, J. Escobar, M. Imbard) Original code + !! 7.0 ! 1997 (A.M. Treguier) SHMEM additions + !! 8.0 ! 1998 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI + !! ! 1998 (J.M. Molines) Open boundary conditions + !! NEMO 1.0 ! 2003 (J.M. Molines, G. Madec) F90, free form + !! ! 2003 (J.M. Molines) add mpp_ini_north(_3d,_2d) + !! - ! 2004 (R. Bourdalle Badie) isend option in mpi + !! ! 2004 (J.M. Molines) minloc, maxloc + !! - ! 2005 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases + !! - ! 2005 (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort + !! - ! 2005 (R. Benshila, G. Madec) add extra halo case + !! - ! 2008 (R. Benshila) add mpp_ini_ice + !! 3.2 ! 2009 (R. Benshila) SHMEM suppression, north fold in lbc_nfd + !! 3.2 ! 2009 (O. Marti) add mpp_ini_znl + !! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager + !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm. + !! 3.5 ! 2013 (C. Ethe, G. Madec) message passing arrays as local variables + !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations + !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max + !! 4.0 ! 2017 (G. Madec) automatique allocation of array argument (use any 3rd dimension) + !! - ! 2017 (G. Madec) create generic.h90 files to generate all lbc and north fold routines + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ctl_stop : update momentum and tracer Kz from a tke scheme + !! ctl_warn : initialization, namelist read, and parameters control + !! ctl_opn : Open file and check if required file is available. + !! ctl_nam : Prints informations when an error occurs while reading a namelist + !! load_nml : Read, condense and buffer namelist file into character array for use as an internal file + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! mpp_start : get local communicator its size and rank + !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) + !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) + !! mpprecv : + !! mppsend : + !! mppscatter : + !! mppgather : + !! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real + !! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real + !! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real + !! mpp_minloc : + !! mpp_maxloc : + !! mppsync : + !! mppstop : + !! mpp_ini_northgather : initialisation of north fold with gathering of the communications + !! mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs + !! mpp_bcast_nml : broadcast/receive namelist character buffer from reading process to all others + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + USE MPI + + IMPLICIT NONE + PRIVATE + ! + PUBLIC ctl_stop, ctl_warn, ctl_opn, ctl_nam, load_nml + PUBLIC mpp_start, mppstop, mppsync, mpp_comm_free + PUBLIC mpp_ini_northgather + PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc + PUBLIC mpp_delay_max, mpp_delay_sum, mpp_delay_rcv + PUBLIC mppscatter, mppgather + PUBLIC mpp_ini_znl + PUBLIC mpp_ini_nc + PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines + PUBLIC mppsend_sp, mpprecv_sp ! needed by TAM and ICB routines + PUBLIC mppsend_dp, mpprecv_dp ! needed by TAM and ICB routines + PUBLIC mpp_report + PUBLIC mpp_bcast_nml + PUBLIC tic_tac + + !! * Interfaces + !! define generic interface for these routine as they are called sometimes + !! with scalar arguments instead of array arguments, which causes problems + !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ + INTERFACE mpp_min + MODULE PROCEDURE mppmin_a_int, mppmin_int + MODULE PROCEDURE mppmin_a_real_sp, mppmin_real_sp + MODULE PROCEDURE mppmin_a_real_dp, mppmin_real_dp + END INTERFACE + INTERFACE mpp_max + MODULE PROCEDURE mppmax_a_int, mppmax_int + MODULE PROCEDURE mppmax_a_real_sp, mppmax_real_sp + MODULE PROCEDURE mppmax_a_real_dp, mppmax_real_dp + END INTERFACE + INTERFACE mpp_sum + MODULE PROCEDURE mppsum_a_int, mppsum_int + MODULE PROCEDURE mppsum_realdd, mppsum_a_realdd + MODULE PROCEDURE mppsum_a_real_sp, mppsum_real_sp + MODULE PROCEDURE mppsum_a_real_dp, mppsum_real_dp + END INTERFACE + INTERFACE mpp_minloc + MODULE PROCEDURE mpp_minloc2d_sp ,mpp_minloc3d_sp + MODULE PROCEDURE mpp_minloc2d_dp ,mpp_minloc3d_dp + END INTERFACE + INTERFACE mpp_maxloc + MODULE PROCEDURE mpp_maxloc2d_sp ,mpp_maxloc3d_sp + MODULE PROCEDURE mpp_maxloc2d_dp ,mpp_maxloc3d_dp + END INTERFACE + + TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (used in lbclnk and lbcnfd) + REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d + END TYPE PTR_4D_sp + + TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (used in lbclnk and lbcnfd) + REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d + END TYPE PTR_4D_dp + + !! ========================= !! + !! MPI variable definition !! + !! ========================= !! + LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag + + INTEGER, PUBLIC :: mppsize ! number of process + INTEGER, PUBLIC :: mpprank ! process number [ 0 - size-1 ] +!$AGRIF_DO_NOT_TREAT + INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator +!$AGRIF_END_DO_NOT_TREAT + + INTEGER :: MPI_SUMDD + + ! Neighbourgs informations + INTEGER, PARAMETER, PUBLIC :: n_hlsmax = 3 + INTEGER, DIMENSION( 8), PUBLIC :: mpinei !: 8-neighbourg MPI indexes (starting at 0, -1 if no neighbourg) + INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiSnei !: 8-neighbourg Send MPI indexes (starting at 0, -1 if no neighbourg) + INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiRnei !: 8-neighbourg Recv MPI indexes (starting at 0, -1 if no neighbourg) + INTEGER, PARAMETER, PUBLIC :: jpwe = 1 !: WEst + INTEGER, PARAMETER, PUBLIC :: jpea = 2 !: EAst + INTEGER, PARAMETER, PUBLIC :: jpso = 3 !: SOuth + INTEGER, PARAMETER, PUBLIC :: jpno = 4 !: NOrth + INTEGER, PARAMETER, PUBLIC :: jpsw = 5 !: South-West + INTEGER, PARAMETER, PUBLIC :: jpse = 6 !: South-East + INTEGER, PARAMETER, PUBLIC :: jpnw = 7 !: North-West + INTEGER, PARAMETER, PUBLIC :: jpne = 8 !: North-East + + LOGICAL, DIMENSION(8), PUBLIC :: l_SelfPerio ! should we explicitely take care of I/J periodicity + LOGICAL, PUBLIC :: l_IdoNFold + + ! variables used for zonal integration + INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average + LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row + INTEGER :: ngrp_znl !: group ID for the znl processors + INTEGER :: ndim_rank_znl !: number of processors on the same zonal average + INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain + + ! variables used for MPI3 neighbourhood collectives + INTEGER, DIMENSION(n_hlsmax), PUBLIC :: mpi_nc_com4 ! MPI3 neighbourhood collectives communicator + INTEGER, DIMENSION(n_hlsmax), PUBLIC :: mpi_nc_com8 ! MPI3 neighbourhood collectives communicator (with diagionals) + + ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) + INTEGER, PUBLIC :: ngrp_world !: group ID for the world processors + INTEGER, PUBLIC :: ngrp_opa !: group ID for the opa processors + INTEGER, PUBLIC :: ngrp_north !: group ID for the northern processors (to be fold) + INTEGER, PUBLIC :: ncomm_north !: communicator made by the processors belonging to ngrp_north + INTEGER, PUBLIC :: ndim_rank_north !: number of 'sea' processor in the northern line (can be /= jpni !) + INTEGER, PUBLIC :: njmppmax !: value of njmpp for the processors of the northern line + INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north + + ! Communications summary report + CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines + CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_glb !: names of global comm calling routines + CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_dlg !: names of delayed global comm calling routines + INTEGER, PUBLIC :: ncom_stp = 0 !: copy of time step # istp + INTEGER, PUBLIC :: ncom_fsbc = 1 !: copy of sbc time step # nn_fsbc + INTEGER, PUBLIC :: ncom_freq !: frequency of comm diagnostic + INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE :: ncomm_sequence !: size of communicated arrays (halos) + INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 5000 !: max number of communication record + INTEGER, PUBLIC :: n_sequence_lbc = 0 !: # of communicated arraysvia lbc + INTEGER, PUBLIC :: n_sequence_glb = 0 !: # of global communications + INTEGER, PUBLIC :: n_sequence_dlg = 0 !: # of delayed global communications + INTEGER, PUBLIC :: numcom = -1 !: logical unit for communicaton report + LOGICAL, PUBLIC :: l_full_nf_update = .TRUE. !: logical for a full (2lines) update of bc at North fold report + INTEGER, PARAMETER, PUBLIC :: nbdelay = 2 !: number of delayed operations + !: name (used as id) of allreduce-delayed operations + ! Warning: we must use the same character length in an array constructor (at least for gcc compiler) + CHARACTER(len=32), DIMENSION(nbdelay), PUBLIC :: c_delaylist = (/ 'cflice', 'fwb ' /) + !: component name where the allreduce-delayed operation is performed + CHARACTER(len=3), DIMENSION(nbdelay), PUBLIC :: c_delaycpnt = (/ 'ICE' , 'OCE' /) + TYPE, PUBLIC :: DELAYARR + REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL() + COMPLEX(dp), POINTER, DIMENSION(:) :: y1d => NULL() + END TYPE DELAYARR + TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE :: todelay !: must have SAVE for default initialization of DELAYARR + INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1 !: mpi request id of the delayed operations + + ! timing summary report + REAL(dp), DIMENSION(2), PUBLIC :: waiting_time = 0._dp + REAL(dp) , PUBLIC :: compute_time = 0._dp, elapsed_time = 0._dp + + REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend + + LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms + INTEGER, PUBLIC :: nn_comm !: namelist control of comms + + INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1 + INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2 + INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3 + INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4 + INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5 + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lib_mpp.F90 15267 2021-09-17 09:04:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE mpp_start( localComm ) + !!---------------------------------------------------------------------- + !! *** routine mpp_start *** + !! + !! ** Purpose : get mpi_comm_oce, mpprank and mppsize + !!---------------------------------------------------------------------- + INTEGER , OPTIONAL , INTENT(in ) :: localComm ! + ! + INTEGER :: ierr + LOGICAL :: llmpi_init + !!---------------------------------------------------------------------- + ! + CALL mpi_initialized ( llmpi_init, ierr ) + IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) + + IF( .NOT. llmpi_init ) THEN + IF( PRESENT(localComm) ) THEN + WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' + WRITE(ctmp2,*) ' without calling MPI_Init before ! ' + CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) + ENDIF + CALL mpi_init( ierr ) + IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) + ENDIF + + IF( PRESENT(localComm) ) THEN + IF( Agrif_Root() ) THEN + mpi_comm_oce = localComm + ENDIF + ELSE + CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) + IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) + ENDIF + + + CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) + CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) + ! + CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) + ! + END SUBROUTINE mpp_start + + + SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) + !!---------------------------------------------------------------------- + !! *** routine mppsend *** + !! + !! ** Purpose : Send messag passing array + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! size of the array pmess + INTEGER , INTENT(in ) :: kdest ! receive process number + INTEGER , INTENT(in ) :: ktyp ! tag of the message + INTEGER , INTENT(inout) :: md_req ! argument for isend + !! + INTEGER :: iflag + INTEGER :: mpi_working_type + !!---------------------------------------------------------------------- + ! + IF (wp == dp) THEN + mpi_working_type = mpi_double_precision + ELSE + mpi_working_type = mpi_real + END IF + CALL mpi_isend( pmess, kbytes, mpi_working_type, kdest , ktyp, mpi_comm_oce, md_req, iflag ) + ! + END SUBROUTINE mppsend + + + SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req ) + !!---------------------------------------------------------------------- + !! *** routine mppsend *** + !! + !! ** Purpose : Send messag passing array + !! + !!---------------------------------------------------------------------- + REAL(dp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! size of the array pmess + INTEGER , INTENT(in ) :: kdest ! receive process number + INTEGER , INTENT(in ) :: ktyp ! tag of the message + INTEGER , INTENT(inout) :: md_req ! argument for isend + !! + INTEGER :: iflag + !!---------------------------------------------------------------------- + ! + CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) + ! + END SUBROUTINE mppsend_dp + + + SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req ) + !!---------------------------------------------------------------------- + !! *** routine mppsend *** + !! + !! ** Purpose : Send messag passing array + !! + !!---------------------------------------------------------------------- + REAL(sp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! size of the array pmess + INTEGER , INTENT(in ) :: kdest ! receive process number + INTEGER , INTENT(in ) :: ktyp ! tag of the message + INTEGER , INTENT(inout) :: md_req ! argument for isend + !! + INTEGER :: iflag + !!---------------------------------------------------------------------- + ! + CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag ) + ! + END SUBROUTINE mppsend_sp + + + SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource ) + !!---------------------------------------------------------------------- + !! *** routine mpprecv *** + !! + !! ** Purpose : Receive messag passing array + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess + INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message + INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number + !! + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + INTEGER :: use_source + INTEGER :: mpi_working_type + !!---------------------------------------------------------------------- + ! + ! If a specific process number has been passed to the receive call, + ! use that one. Default is to use mpi_any_source + use_source = mpi_any_source + IF( PRESENT(ksource) ) use_source = ksource + ! + IF (wp == dp) THEN + mpi_working_type = mpi_double_precision + ELSE + mpi_working_type = mpi_real + END IF + CALL mpi_recv( pmess, kbytes, mpi_working_type, use_source, ktyp, mpi_comm_oce, istatus, iflag ) + ! + END SUBROUTINE mpprecv + + SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource ) + !!---------------------------------------------------------------------- + !! *** routine mpprecv *** + !! + !! ** Purpose : Receive messag passing array + !! + !!---------------------------------------------------------------------- + REAL(dp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess + INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message + INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number + !! + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + INTEGER :: use_source + !!---------------------------------------------------------------------- + ! + ! If a specific process number has been passed to the receive call, + ! use that one. Default is to use mpi_any_source + use_source = mpi_any_source + IF( PRESENT(ksource) ) use_source = ksource + ! + CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) + ! + END SUBROUTINE mpprecv_dp + + + SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource ) + !!---------------------------------------------------------------------- + !! *** routine mpprecv *** + !! + !! ** Purpose : Receive messag passing array + !! + !!---------------------------------------------------------------------- + REAL(sp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess + INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message + INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number + !! + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + INTEGER :: use_source + !!---------------------------------------------------------------------- + ! + ! If a specific process number has been passed to the receive call, + ! use that one. Default is to use mpi_any_source + use_source = mpi_any_source + IF( PRESENT(ksource) ) use_source = ksource + ! + CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag ) + ! + END SUBROUTINE mpprecv_sp + + + SUBROUTINE mppgather( ptab, kp, pio ) + !!---------------------------------------------------------------------- + !! *** routine mppgather *** + !! + !! ** Purpose : Transfert between a local subdomain array and a work + !! array which is distributed following the vertical level. + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: ptab ! subdomain input array + INTEGER , INTENT(in ) :: kp ! record length + REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array + !! + INTEGER :: itaille, ierror ! temporary integer + !!--------------------------------------------------------------------- + ! + itaille = jpi * jpj + CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & + & mpi_double_precision, kp , mpi_comm_oce, ierror ) + ! + END SUBROUTINE mppgather + + + SUBROUTINE mppscatter( pio, kp, ptab ) + !!---------------------------------------------------------------------- + !! *** routine mppscatter *** + !! + !! ** Purpose : Transfert between awork array which is distributed + !! following the vertical level and the local subdomain array. + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array + INTEGER :: kp ! Tag (not used with MPI + REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input + !! + INTEGER :: itaille, ierror ! temporary integer + !!--------------------------------------------------------------------- + ! + itaille = jpi * jpj + ! + CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & + & mpi_double_precision, kp , mpi_comm_oce, ierror ) + ! + END SUBROUTINE mppscatter + + + SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mpp_delay_sum *** + !! + !! ** Purpose : performed delayed mpp_sum, the result is received on next call + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation + COMPLEX(dp), INTENT(in ), DIMENSION(:) :: y_in + REAL(wp), INTENT( out), DIMENSION(:) :: pout + LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine + INTEGER, INTENT(in ), OPTIONAL :: kcom + !! + INTEGER :: ji, isz + INTEGER :: idvar + INTEGER :: ierr, ilocalcomm + COMPLEX(dp), ALLOCATABLE, DIMENSION(:) :: ytmp + !!---------------------------------------------------------------------- + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + + isz = SIZE(y_in) + + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. ) + + idvar = -1 + DO ji = 1, nbdelay + IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji + END DO + IF ( idvar == -1 ) CALL ctl_stop( 'STOP',' mpp_delay_sum : please add a new delayed exchange for '//TRIM(cdname) ) + + IF ( ndelayid(idvar) == 0 ) THEN ! first call with restart: %z1d defined in iom_delay_rst + ! -------------------------- + IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN ! Check dimension coherence + IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one' + DEALLOCATE(todelay(idvar)%z1d) + ndelayid(idvar) = -1 ! do as if we had no restart + ELSE + ALLOCATE(todelay(idvar)%y1d(isz)) + todelay(idvar)%y1d(:) = CMPLX(todelay(idvar)%z1d(:), 0., wp) ! create %y1d, complex variable needed by mpi_sumdd + ndelayid(idvar) = MPI_REQUEST_NULL ! initialised request to a valid value + END IF + ENDIF + + IF( ndelayid(idvar) == -1 ) THEN ! first call without restart: define %y1d and %z1d from y_in with blocking allreduce + ! -------------------------- + ALLOCATE(todelay(idvar)%z1d(isz), todelay(idvar)%y1d(isz)) ! allocate also %z1d as used for the restart + CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) ! get %y1d + ndelayid(idvar) = MPI_REQUEST_NULL + ENDIF + + CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received + + ! send back pout from todelay(idvar)%z1d defined at previous call + pout(:) = todelay(idvar)%z1d(:) + + ! send y_in into todelay(idvar)%y1d with a non-blocking communication + CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) + + END SUBROUTINE mpp_delay_sum + + + SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mpp_delay_max *** + !! + !! ** Purpose : performed delayed mpp_max, the result is received on next call + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation + REAL(wp), INTENT(in ), DIMENSION(:) :: p_in ! + REAL(wp), INTENT( out), DIMENSION(:) :: pout ! + LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine + INTEGER, INTENT(in ), OPTIONAL :: kcom + !! + INTEGER :: ji, isz + INTEGER :: idvar + INTEGER :: ierr, ilocalcomm + INTEGER :: MPI_TYPE + !!---------------------------------------------------------------------- + + if( wp == dp ) then + MPI_TYPE = MPI_DOUBLE_PRECISION + else if ( wp == sp ) then + MPI_TYPE = MPI_REAL + else + CALL ctl_stop( "Error defining type, wp is neither dp nor sp" ) + + end if + + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + + isz = SIZE(p_in) + + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. ) + + idvar = -1 + DO ji = 1, nbdelay + IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji + END DO + IF ( idvar == -1 ) CALL ctl_stop( 'STOP',' mpp_delay_max : please add a new delayed exchange for '//TRIM(cdname) ) + + IF ( ndelayid(idvar) == 0 ) THEN ! first call with restart: %z1d defined in iom_delay_rst + ! -------------------------- + IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN ! Check dimension coherence + IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one' + DEALLOCATE(todelay(idvar)%z1d) + ndelayid(idvar) = -1 ! do as if we had no restart + ELSE + ndelayid(idvar) = MPI_REQUEST_NULL + END IF + ENDIF + + IF( ndelayid(idvar) == -1 ) THEN ! first call without restart: define %z1d from p_in with a blocking allreduce + ! -------------------------- + ALLOCATE(todelay(idvar)%z1d(isz)) + CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) ! get %z1d + ndelayid(idvar) = MPI_REQUEST_NULL + ENDIF + + CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received + + ! send back pout from todelay(idvar)%z1d defined at previous call + pout(:) = todelay(idvar)%z1d(:) + + ! send p_in into todelay(idvar)%z1d with a non-blocking communication + ! (PM) Should we get rid of MPI2 option ? MPI3 was release in 2013. Who is still using MPI2 ? + CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) + + END SUBROUTINE mpp_delay_max + + + SUBROUTINE mpp_delay_rcv( kid ) + !!---------------------------------------------------------------------- + !! *** routine mpp_delay_rcv *** + !! + !! ** Purpose : force barrier for delayed mpp (needed for restart) + !! + !!---------------------------------------------------------------------- + INTEGER,INTENT(in ) :: kid + INTEGER :: ierr + !!---------------------------------------------------------------------- + IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) + ! test on ndelayid(kid) useless as mpi_wait return immediatly if the request handle is MPI_REQUEST_NULL + CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! after this ndelayid(kid) = MPI_REQUEST_NULL + IF( ln_timing ) CALL tic_tac( .FALSE., ld_global = .TRUE.) + IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d + END SUBROUTINE mpp_delay_rcv + + SUBROUTINE mpp_bcast_nml( cdnambuff , kleng ) + CHARACTER(LEN=:) , ALLOCATABLE, INTENT(INOUT) :: cdnambuff + INTEGER , INTENT(INOUT) :: kleng + !!---------------------------------------------------------------------- + !! *** routine mpp_bcast_nml *** + !! + !! ** Purpose : broadcast namelist character buffer + !! + !!---------------------------------------------------------------------- + !! + INTEGER :: iflag + !!---------------------------------------------------------------------- + ! + call MPI_BCAST(kleng, 1, MPI_INT, 0, mpi_comm_oce, iflag) + call MPI_BARRIER(mpi_comm_oce, iflag) +!$AGRIF_DO_NOT_TREAT + IF ( .NOT. ALLOCATED(cdnambuff) ) ALLOCATE( CHARACTER(LEN=kleng) :: cdnambuff ) +!$AGRIF_END_DO_NOT_TREAT + call MPI_BCAST(cdnambuff, kleng, MPI_CHARACTER, 0, mpi_comm_oce, iflag) + call MPI_BARRIER(mpi_comm_oce, iflag) + ! + END SUBROUTINE mpp_bcast_nml + + + !!---------------------------------------------------------------------- + !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** + !! + !!---------------------------------------------------------------------- + !! +! !== IN: ptab is an array ==! + + SUBROUTINE mppmax_int( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + INTEGER , INTENT(inout) :: ptab ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + INTEGER , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = 1 ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab, work, ipi, mpi_integer, mpi_max, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmax_int + +! !== IN: ptab is an array ==! + + SUBROUTINE mppmax_a_int( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + INTEGER , INTENT(inout) :: ptab(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + INTEGER , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = SIZE(ptab,1) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab(:), work, ipi, mpi_integer, mpi_max, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab(ii) = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmax_a_int + +! + !! + !! ---- SINGLE PRECISION VERSIONS + !! +! !== IN: ptab is an array ==! + + SUBROUTINE mppmax_real_sp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(sp) , INTENT(inout) :: ptab ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(sp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = 1 ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab, work, ipi, mpi_real, mpi_max, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmax_real_sp + +! !== IN: ptab is an array ==! + + SUBROUTINE mppmax_a_real_sp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(sp) , INTENT(inout) :: ptab(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(sp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = SIZE(ptab,1) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab(:), work, ipi, mpi_real, mpi_max, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab(ii) = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmax_a_real_sp + + !! + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +! +! !== IN: ptab is an array ==! + + SUBROUTINE mppmax_real_dp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(inout) :: ptab ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(dp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = 1 ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab, work, ipi, mpi_double_precision, mpi_max, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmax_real_dp + +! !== IN: ptab is an array ==! + + SUBROUTINE mppmax_a_real_dp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(inout) :: ptab(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(dp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = SIZE(ptab,1) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab(:), work, ipi, mpi_double_precision, mpi_max, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab(ii) = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmax_a_real_dp + + !!---------------------------------------------------------------------- + !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** + !! + !!---------------------------------------------------------------------- + !! +! !== IN: ptab is an array ==! + + SUBROUTINE mppmin_int( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + INTEGER , INTENT(inout) :: ptab ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + INTEGER , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = 1 ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab, work, ipi, mpi_integer, mpi_min, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmin_int + +! !== IN: ptab is an array ==! + + SUBROUTINE mppmin_a_int( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + INTEGER , INTENT(inout) :: ptab(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + INTEGER , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = SIZE(ptab,1) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab(:), work, ipi, mpi_integer, mpi_min, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab(ii) = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmin_a_int + +! + !! + !! ---- SINGLE PRECISION VERSIONS + !! +! !== IN: ptab is an array ==! + + SUBROUTINE mppmin_real_sp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(sp) , INTENT(inout) :: ptab ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(sp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = 1 ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab, work, ipi, mpi_real, mpi_min, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmin_real_sp + +! !== IN: ptab is an array ==! + + SUBROUTINE mppmin_a_real_sp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(sp) , INTENT(inout) :: ptab(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(sp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = SIZE(ptab,1) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab(:), work, ipi, mpi_real, mpi_min, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab(ii) = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmin_a_real_sp + + !! + !! ---- DOUBLE PRECISION VERSIONS + !! + +! !== IN: ptab is an array ==! + + SUBROUTINE mppmin_real_dp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(inout) :: ptab ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(dp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = 1 ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab, work, ipi, mpi_double_precision, mpi_min, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmin_real_dp + +! !== IN: ptab is an array ==! + + SUBROUTINE mppmin_a_real_dp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(inout) :: ptab(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(dp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = SIZE(ptab,1) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab(:), work, ipi, mpi_double_precision, mpi_min, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab(ii) = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppmin_a_real_dp + + + !!---------------------------------------------------------------------- + !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** + !! + !! Global sum of 1D array or a variable (integer, real or complex) + !!---------------------------------------------------------------------- + !! +! !== IN: ptab is an array ==! + + SUBROUTINE mppsum_int( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + INTEGER , INTENT(inout) :: ptab ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + INTEGER , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = 1 ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab, work, ipi, mpi_integer, mpi_sum, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppsum_int + +! !== IN: ptab is an array ==! + + SUBROUTINE mppsum_a_int( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + INTEGER , INTENT(inout) :: ptab(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + INTEGER , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = SIZE(ptab,1) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab(:), work, ipi, mpi_integer, mpi_sum, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab(ii) = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppsum_a_int + + + !! + !! ---- SINGLE PRECISION VERSIONS + !! +! !== IN: ptab is an array ==! + + SUBROUTINE mppsum_real_sp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(sp) , INTENT(inout) :: ptab ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(sp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = 1 ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab, work, ipi, mpi_real, mpi_sum, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppsum_real_sp + +! !== IN: ptab is an array ==! + + SUBROUTINE mppsum_a_real_sp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(sp) , INTENT(inout) :: ptab(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(sp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = SIZE(ptab,1) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab(:), work, ipi, mpi_real, mpi_sum, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab(ii) = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppsum_a_real_sp + + + + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +! !== IN: ptab is an array ==! + + SUBROUTINE mppsum_real_dp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(inout) :: ptab ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(dp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = 1 ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab, work, ipi, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppsum_real_dp + +! !== IN: ptab is an array ==! + + SUBROUTINE mppsum_a_real_dp( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(inout) :: ptab(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + REAL(dp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = SIZE(ptab,1) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab(:), work, ipi, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab(ii) = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppsum_a_real_dp + + +! !== IN: ptab is an array ==! + + SUBROUTINE mppsum_realdd( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + COMPLEX(dp) , INTENT(inout) :: ptab ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + COMPLEX(dp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = 1 ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab, work, ipi, mpi_double_complex, mpi_sumdd, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppsum_realdd + +! !== IN: ptab is an array ==! + + SUBROUTINE mppsum_a_realdd( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + COMPLEX(dp) , INTENT(inout) :: ptab(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + COMPLEX(dp) , ALLOCATABLE :: work(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = SIZE(ptab,1) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ptab(:), work, ipi, mpi_double_complex, mpi_sumdd, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ptab(ii) = work(ii) + ENDDO + DEALLOCATE(work) + + END SUBROUTINE mppsum_a_realdd + + + !!---------------------------------------------------------------------- + !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d + !! + !!---------------------------------------------------------------------- + !! + !! + !! ---- SINGLE PRECISION VERSIONS + !! +!== IN: ptab is an array ==! + + + SUBROUTINE mpp_minloc2d_sp( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:) ! array on which loctrans operation is applied + LOGICAL , INTENT(in ) :: ldmsk(:,:) ! local mask + REAL(sp) , INTENT( out) :: pmin ! Global minimum of ptab + INTEGER , INTENT( out) :: kindex(2) ! index of minimum in global frame + LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(sp) :: zmin ! local minimum + REAL(sp), DIMENSION(2,1) :: zain, zaout + LOGICAL :: llhalo + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo + ELSE ; llhalo = .FALSE. + ENDIF + ! + idim = SIZE(kindex) + ! + IF ( ANY( ldmsk(:,:) ) ) THEN ! there is at least 1 valid point... + ! + ALLOCATE ( ilocs(idim) ) + ! + ilocs = MINLOC( ptab(:,:) , mask= ldmsk(:,:) ) + zmin = ptab(ilocs(1),ilocs(2)) + ! + kindex(1) = mig( ilocs(1) ) + kindex(2) = mjg( ilocs(2) ) + ! + DEALLOCATE (ilocs) + ! + index0 = kindex(1)-1 ! 1d index starting at 0 + index0 = index0 + jpiglo * (kindex(2)-1) + ELSE + ! special case for land processors + zmin = HUGE(zmin) + index0 = 0 + END IF + ! + zain(1,:) = zmin + zain(2,:) = REAL(index0, sp) + ! + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2REAL, MPI_MINLOC ,MPI_COMM_OCE, ierror) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + ! + pmin = zaout(1,1) + index0 = NINT( zaout(2,1) ) + kindex(2) = index0 / jpiglo + index0 = index0 - kindex(2) * jpiglo + kindex(1) = index0 + kindex(:) = kindex(:) + 1 ! start indices at 1 + + IF( .NOT. llhalo ) THEN + kindex(1) = kindex(1) - nn_hls + kindex(2) = kindex(2) - nn_hls + ENDIF + + END SUBROUTINE mpp_minloc2d_sp + + +!== IN: ptab is an array ==! + + + SUBROUTINE mpp_minloc3d_sp( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:,:) ! array on which loctrans operation is applied + LOGICAL , INTENT(in ) :: ldmsk(:,:,:) ! local mask + REAL(sp) , INTENT( out) :: pmin ! Global minimum of ptab + INTEGER , INTENT( out) :: kindex(3) ! index of minimum in global frame + LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(sp) :: zmin ! local minimum + REAL(sp), DIMENSION(2,1) :: zain, zaout + LOGICAL :: llhalo + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo + ELSE ; llhalo = .FALSE. + ENDIF + ! + idim = SIZE(kindex) + ! + IF ( ANY( ldmsk(:,:,:) ) ) THEN ! there is at least 1 valid point... + ! + ALLOCATE ( ilocs(idim) ) + ! + ilocs = MINLOC( ptab(:,:,:) , mask= ldmsk(:,:,:) ) + zmin = ptab(ilocs(1),ilocs(2),ilocs(3)) + ! + kindex(1) = mig( ilocs(1) ) + kindex(2) = mjg( ilocs(2) ) + kindex(3) = ilocs(3) + ! + DEALLOCATE (ilocs) + ! + index0 = kindex(1)-1 ! 1d index starting at 0 + index0 = index0 + jpiglo * (kindex(2)-1) + index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) + ELSE + ! special case for land processors + zmin = HUGE(zmin) + index0 = 0 + END IF + ! + zain(1,:) = zmin + zain(2,:) = REAL(index0, sp) + ! + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2REAL, MPI_MINLOC ,MPI_COMM_OCE, ierror) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + ! + pmin = zaout(1,1) + index0 = NINT( zaout(2,1) ) + kindex(3) = index0 / (jpiglo*jpjglo) + index0 = index0 - kindex(3) * (jpiglo*jpjglo) + kindex(2) = index0 / jpiglo + index0 = index0 - kindex(2) * jpiglo + kindex(1) = index0 + kindex(:) = kindex(:) + 1 ! start indices at 1 + + IF( .NOT. llhalo ) THEN + kindex(1) = kindex(1) - nn_hls + kindex(2) = kindex(2) - nn_hls + ENDIF + + END SUBROUTINE mpp_minloc3d_sp + + + +!== IN: ptab is an array ==! + + + SUBROUTINE mpp_maxloc2d_sp( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:) ! array on which loctrans operation is applied + LOGICAL , INTENT(in ) :: ldmsk(:,:) ! local mask + REAL(sp) , INTENT( out) :: pmin ! Global minimum of ptab + INTEGER , INTENT( out) :: kindex(2) ! index of minimum in global frame + LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(sp) :: zmin ! local minimum + REAL(sp), DIMENSION(2,1) :: zain, zaout + LOGICAL :: llhalo + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo + ELSE ; llhalo = .FALSE. + ENDIF + ! + idim = SIZE(kindex) + ! + IF ( ANY( ldmsk(:,:) ) ) THEN ! there is at least 1 valid point... + ! + ALLOCATE ( ilocs(idim) ) + ! + ilocs = MAXLOC( ptab(:,:) , mask= ldmsk(:,:) ) + zmin = ptab(ilocs(1),ilocs(2)) + ! + kindex(1) = mig( ilocs(1) ) + kindex(2) = mjg( ilocs(2) ) + ! + DEALLOCATE (ilocs) + ! + index0 = kindex(1)-1 ! 1d index starting at 0 + index0 = index0 + jpiglo * (kindex(2)-1) + ELSE + ! special case for land processors + zmin = -HUGE(zmin) + index0 = 0 + END IF + ! + zain(1,:) = zmin + zain(2,:) = REAL(index0, sp) + ! + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2REAL, MPI_MAXLOC ,MPI_COMM_OCE, ierror) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + ! + pmin = zaout(1,1) + index0 = NINT( zaout(2,1) ) + kindex(2) = index0 / jpiglo + index0 = index0 - kindex(2) * jpiglo + kindex(1) = index0 + kindex(:) = kindex(:) + 1 ! start indices at 1 + + IF( .NOT. llhalo ) THEN + kindex(1) = kindex(1) - nn_hls + kindex(2) = kindex(2) - nn_hls + ENDIF + + END SUBROUTINE mpp_maxloc2d_sp + + +!== IN: ptab is an array ==! + + + SUBROUTINE mpp_maxloc3d_sp( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:,:) ! array on which loctrans operation is applied + LOGICAL , INTENT(in ) :: ldmsk(:,:,:) ! local mask + REAL(sp) , INTENT( out) :: pmin ! Global minimum of ptab + INTEGER , INTENT( out) :: kindex(3) ! index of minimum in global frame + LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(sp) :: zmin ! local minimum + REAL(sp), DIMENSION(2,1) :: zain, zaout + LOGICAL :: llhalo + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo + ELSE ; llhalo = .FALSE. + ENDIF + ! + idim = SIZE(kindex) + ! + IF ( ANY( ldmsk(:,:,:) ) ) THEN ! there is at least 1 valid point... + ! + ALLOCATE ( ilocs(idim) ) + ! + ilocs = MAXLOC( ptab(:,:,:) , mask= ldmsk(:,:,:) ) + zmin = ptab(ilocs(1),ilocs(2),ilocs(3)) + ! + kindex(1) = mig( ilocs(1) ) + kindex(2) = mjg( ilocs(2) ) + kindex(3) = ilocs(3) + ! + DEALLOCATE (ilocs) + ! + index0 = kindex(1)-1 ! 1d index starting at 0 + index0 = index0 + jpiglo * (kindex(2)-1) + index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) + ELSE + ! special case for land processors + zmin = -HUGE(zmin) + index0 = 0 + END IF + ! + zain(1,:) = zmin + zain(2,:) = REAL(index0, sp) + ! + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2REAL, MPI_MAXLOC ,MPI_COMM_OCE, ierror) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + ! + pmin = zaout(1,1) + index0 = NINT( zaout(2,1) ) + kindex(3) = index0 / (jpiglo*jpjglo) + index0 = index0 - kindex(3) * (jpiglo*jpjglo) + kindex(2) = index0 / jpiglo + index0 = index0 - kindex(2) * jpiglo + kindex(1) = index0 + kindex(:) = kindex(:) + 1 ! start indices at 1 + + IF( .NOT. llhalo ) THEN + kindex(1) = kindex(1) - nn_hls + kindex(2) = kindex(2) - nn_hls + ENDIF + + END SUBROUTINE mpp_maxloc3d_sp + + + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +!== IN: ptab is an array ==! + + + SUBROUTINE mpp_minloc2d_dp( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:) ! array on which loctrans operation is applied + LOGICAL , INTENT(in ) :: ldmsk(:,:) ! local mask + REAL(dp) , INTENT( out) :: pmin ! Global minimum of ptab + INTEGER , INTENT( out) :: kindex(2) ! index of minimum in global frame + LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(dp) :: zmin ! local minimum + REAL(dp), DIMENSION(2,1) :: zain, zaout + LOGICAL :: llhalo + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo + ELSE ; llhalo = .FALSE. + ENDIF + ! + idim = SIZE(kindex) + ! + IF ( ANY( ldmsk(:,:) ) ) THEN ! there is at least 1 valid point... + ! + ALLOCATE ( ilocs(idim) ) + ! + ilocs = MINLOC( ptab(:,:) , mask= ldmsk(:,:) ) + zmin = ptab(ilocs(1),ilocs(2)) + ! + kindex(1) = mig( ilocs(1) ) + kindex(2) = mjg( ilocs(2) ) + ! + DEALLOCATE (ilocs) + ! + index0 = kindex(1)-1 ! 1d index starting at 0 + index0 = index0 + jpiglo * (kindex(2)-1) + ELSE + ! special case for land processors + zmin = HUGE(zmin) + index0 = 0 + END IF + ! + zain(1,:) = zmin + zain(2,:) = REAL(index0, dp) + ! + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_MINLOC ,MPI_COMM_OCE, ierror) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + ! + pmin = zaout(1,1) + index0 = NINT( zaout(2,1) ) + kindex(2) = index0 / jpiglo + index0 = index0 - kindex(2) * jpiglo + kindex(1) = index0 + kindex(:) = kindex(:) + 1 ! start indices at 1 + + IF( .NOT. llhalo ) THEN + kindex(1) = kindex(1) - nn_hls + kindex(2) = kindex(2) - nn_hls + ENDIF + + END SUBROUTINE mpp_minloc2d_dp + + +!== IN: ptab is an array ==! + + + SUBROUTINE mpp_minloc3d_dp( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:,:) ! array on which loctrans operation is applied + LOGICAL , INTENT(in ) :: ldmsk(:,:,:) ! local mask + REAL(dp) , INTENT( out) :: pmin ! Global minimum of ptab + INTEGER , INTENT( out) :: kindex(3) ! index of minimum in global frame + LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(dp) :: zmin ! local minimum + REAL(dp), DIMENSION(2,1) :: zain, zaout + LOGICAL :: llhalo + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo + ELSE ; llhalo = .FALSE. + ENDIF + ! + idim = SIZE(kindex) + ! + IF ( ANY( ldmsk(:,:,:) ) ) THEN ! there is at least 1 valid point... + ! + ALLOCATE ( ilocs(idim) ) + ! + ilocs = MINLOC( ptab(:,:,:) , mask= ldmsk(:,:,:) ) + zmin = ptab(ilocs(1),ilocs(2),ilocs(3)) + ! + kindex(1) = mig( ilocs(1) ) + kindex(2) = mjg( ilocs(2) ) + kindex(3) = ilocs(3) + ! + DEALLOCATE (ilocs) + ! + index0 = kindex(1)-1 ! 1d index starting at 0 + index0 = index0 + jpiglo * (kindex(2)-1) + index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) + ELSE + ! special case for land processors + zmin = HUGE(zmin) + index0 = 0 + END IF + ! + zain(1,:) = zmin + zain(2,:) = REAL(index0, dp) + ! + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_MINLOC ,MPI_COMM_OCE, ierror) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + ! + pmin = zaout(1,1) + index0 = NINT( zaout(2,1) ) + kindex(3) = index0 / (jpiglo*jpjglo) + index0 = index0 - kindex(3) * (jpiglo*jpjglo) + kindex(2) = index0 / jpiglo + index0 = index0 - kindex(2) * jpiglo + kindex(1) = index0 + kindex(:) = kindex(:) + 1 ! start indices at 1 + + IF( .NOT. llhalo ) THEN + kindex(1) = kindex(1) - nn_hls + kindex(2) = kindex(2) - nn_hls + ENDIF + + END SUBROUTINE mpp_minloc3d_dp + + + +!== IN: ptab is an array ==! + + + SUBROUTINE mpp_maxloc2d_dp( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:) ! array on which loctrans operation is applied + LOGICAL , INTENT(in ) :: ldmsk(:,:) ! local mask + REAL(dp) , INTENT( out) :: pmin ! Global minimum of ptab + INTEGER , INTENT( out) :: kindex(2) ! index of minimum in global frame + LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(dp) :: zmin ! local minimum + REAL(dp), DIMENSION(2,1) :: zain, zaout + LOGICAL :: llhalo + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo + ELSE ; llhalo = .FALSE. + ENDIF + ! + idim = SIZE(kindex) + ! + IF ( ANY( ldmsk(:,:) ) ) THEN ! there is at least 1 valid point... + ! + ALLOCATE ( ilocs(idim) ) + ! + ilocs = MAXLOC( ptab(:,:) , mask= ldmsk(:,:) ) + zmin = ptab(ilocs(1),ilocs(2)) + ! + kindex(1) = mig( ilocs(1) ) + kindex(2) = mjg( ilocs(2) ) + ! + DEALLOCATE (ilocs) + ! + index0 = kindex(1)-1 ! 1d index starting at 0 + index0 = index0 + jpiglo * (kindex(2)-1) + ELSE + ! special case for land processors + zmin = -HUGE(zmin) + index0 = 0 + END IF + ! + zain(1,:) = zmin + zain(2,:) = REAL(index0, dp) + ! + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_MAXLOC ,MPI_COMM_OCE, ierror) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + ! + pmin = zaout(1,1) + index0 = NINT( zaout(2,1) ) + kindex(2) = index0 / jpiglo + index0 = index0 - kindex(2) * jpiglo + kindex(1) = index0 + kindex(:) = kindex(:) + 1 ! start indices at 1 + + IF( .NOT. llhalo ) THEN + kindex(1) = kindex(1) - nn_hls + kindex(2) = kindex(2) - nn_hls + ENDIF + + END SUBROUTINE mpp_maxloc2d_dp + + +!== IN: ptab is an array ==! + + + SUBROUTINE mpp_maxloc3d_dp( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + REAL(dp) , INTENT(in ) :: ptab(:,:,:) ! array on which loctrans operation is applied + LOGICAL , INTENT(in ) :: ldmsk(:,:,:) ! local mask + REAL(dp) , INTENT( out) :: pmin ! Global minimum of ptab + INTEGER , INTENT( out) :: kindex(3) ! index of minimum in global frame + LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(dp) :: zmin ! local minimum + REAL(dp), DIMENSION(2,1) :: zain, zaout + LOGICAL :: llhalo + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo + ELSE ; llhalo = .FALSE. + ENDIF + ! + idim = SIZE(kindex) + ! + IF ( ANY( ldmsk(:,:,:) ) ) THEN ! there is at least 1 valid point... + ! + ALLOCATE ( ilocs(idim) ) + ! + ilocs = MAXLOC( ptab(:,:,:) , mask= ldmsk(:,:,:) ) + zmin = ptab(ilocs(1),ilocs(2),ilocs(3)) + ! + kindex(1) = mig( ilocs(1) ) + kindex(2) = mjg( ilocs(2) ) + kindex(3) = ilocs(3) + ! + DEALLOCATE (ilocs) + ! + index0 = kindex(1)-1 ! 1d index starting at 0 + index0 = index0 + jpiglo * (kindex(2)-1) + index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) + ELSE + ! special case for land processors + zmin = -HUGE(zmin) + index0 = 0 + END IF + ! + zain(1,:) = zmin + zain(2,:) = REAL(index0, dp) + ! + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_MAXLOC ,MPI_COMM_OCE, ierror) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + ! + pmin = zaout(1,1) + index0 = NINT( zaout(2,1) ) + kindex(3) = index0 / (jpiglo*jpjglo) + index0 = index0 - kindex(3) * (jpiglo*jpjglo) + kindex(2) = index0 / jpiglo + index0 = index0 - kindex(2) * jpiglo + kindex(1) = index0 + kindex(:) = kindex(:) + 1 ! start indices at 1 + + IF( .NOT. llhalo ) THEN + kindex(1) = kindex(1) - nn_hls + kindex(2) = kindex(2) - nn_hls + ENDIF + + END SUBROUTINE mpp_maxloc3d_dp + + + + + SUBROUTINE mppsync() + !!---------------------------------------------------------------------- + !! *** routine mppsync *** + !! + !! ** Purpose : Massively parallel processors, synchroneous + !! + !!----------------------------------------------------------------------- + INTEGER :: ierror + !!----------------------------------------------------------------------- + ! + CALL mpi_barrier( mpi_comm_oce, ierror ) + ! + END SUBROUTINE mppsync + + + SUBROUTINE mppstop( ld_abort ) + !!---------------------------------------------------------------------- + !! *** routine mppstop *** + !! + !! ** purpose : Stop massively parallel processors method + !! + !!---------------------------------------------------------------------- + LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number + LOGICAL :: ll_abort + INTEGER :: info, ierr + !!---------------------------------------------------------------------- + ll_abort = .FALSE. + IF( PRESENT(ld_abort) ) ll_abort = ld_abort + ! + IF(ll_abort) THEN + CALL mpi_abort( MPI_COMM_WORLD, 123, info ) + ELSE + CALL mppsync + CALL mpi_finalize( info ) + ENDIF + IF( ll_abort ) STOP 123 + ! + END SUBROUTINE mppstop + + + SUBROUTINE mpp_comm_free( kcom ) + !!---------------------------------------------------------------------- + INTEGER, INTENT(inout) :: kcom + !! + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + CALL MPI_COMM_FREE(kcom, ierr) + ! + END SUBROUTINE mpp_comm_free + + + SUBROUTINE mpp_ini_znl( kumout ) + !!---------------------------------------------------------------------- + !! *** routine mpp_ini_znl *** + !! + !! ** Purpose : Initialize special communicator for computing zonal sum + !! + !! ** Method : - Look for processors in the same row + !! - Put their number in nrank_znl + !! - Create group for the znl processors + !! - Create a communicator for znl processors + !! - Determine if processor should write znl files + !! + !! ** output + !! ndim_rank_znl = number of processors on the same row + !! ngrp_znl = group ID for the znl processors + !! ncomm_znl = communicator for the ice procs. + !! n_znl_root = number (in the world) of proc 0 in the ice comm. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kumout ! ocean.output logical units + ! + INTEGER :: jproc ! dummy loop integer + INTEGER :: ierr, ii ! local integer + INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork + !!---------------------------------------------------------------------- + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_world : ', ngrp_world + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - mpi_comm_world : ', mpi_comm_world + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - mpi_comm_oce : ', mpi_comm_oce + ! + ALLOCATE( kwork(jpnij), STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') + + IF( jpnj == 1 ) THEN + ngrp_znl = ngrp_world + ncomm_znl = mpi_comm_oce + ELSE + ! + CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr ) + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - kwork pour njmpp : ', kwork + !-$$ CALL flush(numout) + ! + ! Count number of processors on the same row + ndim_rank_znl = 0 + DO jproc=1,jpnij + IF ( kwork(jproc) == njmpp ) THEN + ndim_rank_znl = ndim_rank_znl + 1 + ENDIF + END DO + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ndim_rank_znl : ', ndim_rank_znl + !-$$ CALL flush(numout) + ! Allocate the right size to nrank_znl + IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl) + ALLOCATE(nrank_znl(ndim_rank_znl)) + ii = 0 + nrank_znl (:) = 0 + DO jproc=1,jpnij + IF ( kwork(jproc) == njmpp) THEN + ii = ii + 1 + nrank_znl(ii) = jproc -1 + ENDIF + END DO + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - nrank_znl : ', nrank_znl + !-$$ CALL flush(numout) + + ! Create the opa group + CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr) + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_opa : ', ngrp_opa + !-$$ CALL flush(numout) + + ! Create the znl group from the opa group + CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr ) + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_znl ', ngrp_znl + !-$$ CALL flush(numout) + + ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row + CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr ) + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ncomm_znl ', ncomm_znl + !-$$ CALL flush(numout) + ! + END IF + + ! Determines if processor if the first (starting from i=1) on the row + IF ( jpni == 1 ) THEN + l_znl_root = .TRUE. + ELSE + l_znl_root = .FALSE. + kwork (1) = nimpp + CALL mpp_min ( 'lib_mpp', kwork(1), kcom = ncomm_znl) + IF ( nimpp == kwork(1)) l_znl_root = .TRUE. + END IF + + DEALLOCATE(kwork) + + END SUBROUTINE mpp_ini_znl + + + SUBROUTINE mpp_ini_nc( khls ) + !!---------------------------------------------------------------------- + !! *** routine mpp_ini_nc *** + !! + !! ** Purpose : Initialize special communicators for MPI3 neighbourhood + !! collectives + !! + !! ** Method : - Create graph communicators starting from the processes + !! distribution along i and j directions + ! + !! ** output + !! mpi_nc_com4 = MPI3 neighbourhood collectives communicator + !! mpi_nc_com8 = MPI3 neighbourhood collectives communicator (with diagonals) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: khls ! halo size, default = nn_hls + ! + INTEGER, DIMENSION(:), ALLOCATABLE :: iSnei4, iRnei4, iSnei8, iRnei8 + INTEGER :: iScnt4, iRcnt4, iScnt8, iRcnt8 + INTEGER :: ierr + LOGICAL, PARAMETER :: ireord = .FALSE. + !!---------------------------------------------------------------------- + + iScnt4 = COUNT( mpiSnei(khls,1:4) >= 0 ) + iRcnt4 = COUNT( mpiRnei(khls,1:4) >= 0 ) + iScnt8 = COUNT( mpiSnei(khls,1:8) >= 0 ) + iRcnt8 = COUNT( mpiRnei(khls,1:8) >= 0 ) + + ALLOCATE( iSnei4(iScnt4), iRnei4(iRcnt4), iSnei8(iScnt8), iRnei8(iRcnt8) ) ! ok if icnt4 or icnt8 = 0 + + iSnei4 = PACK( mpiSnei(khls,1:4), mask = mpiSnei(khls,1:4) >= 0 ) + iRnei4 = PACK( mpiRnei(khls,1:4), mask = mpiRnei(khls,1:4) >= 0 ) + iSnei8 = PACK( mpiSnei(khls,1:8), mask = mpiSnei(khls,1:8) >= 0 ) + iRnei8 = PACK( mpiRnei(khls,1:8), mask = mpiRnei(khls,1:8) >= 0 ) + + CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt4, iSnei4, MPI_UNWEIGHTED, iRcnt4, iRnei4, MPI_UNWEIGHTED, & + & MPI_INFO_NULL, ireord, mpi_nc_com4(khls), ierr ) + CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt8, iSnei8, MPI_UNWEIGHTED, iRcnt8, iRnei8, MPI_UNWEIGHTED, & + & MPI_INFO_NULL, ireord, mpi_nc_com8(khls), ierr) + + DEALLOCATE( iSnei4, iRnei4, iSnei8, iRnei8 ) + END SUBROUTINE mpp_ini_nc + + + SUBROUTINE mpp_ini_northgather + !!---------------------------------------------------------------------- + !! *** routine mpp_ini_northgather *** + !! + !! ** Purpose : Initialize special communicator for north folding + !! condition together with global variables needed in the mpp folding + !! + !! ** Method : - Look for northern processors + !! - Put their number in nrank_north + !! - Create groups for the world processors and the north processors + !! - Create a communicator for northern processors + !! + !! ** output + !! ndim_rank_north = number of processors in the northern line + !! nrank_north (ndim_rank_north) = number of the northern procs. + !! ngrp_world = group ID for the world processors + !! ngrp_north = group ID for the northern processors + !! ncomm_north = communicator for the northern procs. + !! north_root = number (in the world) of proc 0 in the northern comm. + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr + INTEGER :: jjproc + INTEGER :: ii, ji + !!---------------------------------------------------------------------- + ! + ! + ! Look for how many procs on the northern boundary + ndim_rank_north = 0 + DO jjproc = 1, jpni + IF( nfproc(jjproc) /= -1 ) ndim_rank_north = ndim_rank_north + 1 + END DO + ! + ! Allocate the right size to nrank_north + IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north) + ALLOCATE( nrank_north(ndim_rank_north) ) + + ! Fill the nrank_north array with proc. number of northern procs. + ! Note : the rank start at 0 in MPI + ii = 0 + DO ji = 1, jpni + IF ( nfproc(ji) /= -1 ) THEN + ii=ii+1 + nrank_north(ii)=nfproc(ji) + END IF + END DO + ! + ! create the world group + CALL MPI_COMM_GROUP( mpi_comm_oce, ngrp_world, ierr ) + ! + ! Create the North group from the world group + CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr ) + ! + ! Create the North communicator , ie the pool of procs in the north group + CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) + ! + END SUBROUTINE mpp_ini_northgather + + + SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype ) + !!--------------------------------------------------------------------- + !! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD + !! + !! Modification of original codes written by David H. Bailey + !! This subroutine computes yddb(i) = ydda(i)+yddb(i) + !!--------------------------------------------------------------------- + INTEGER , INTENT(in) :: ilen, itype + COMPLEX(dp), DIMENSION(ilen), INTENT(in) :: ydda + COMPLEX(dp), DIMENSION(ilen), INTENT(inout) :: yddb + ! + REAL(dp) :: zerr, zt1, zt2 ! local work variables + INTEGER :: ji, ztmp ! local scalar + !!--------------------------------------------------------------------- + ! + ztmp = itype ! avoid compilation warning + ! + DO ji=1,ilen + ! Compute ydda + yddb using Knuth's trick. + zt1 = real(ydda(ji)) + real(yddb(ji)) + zerr = zt1 - real(ydda(ji)) + zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) & + + aimag(ydda(ji)) + aimag(yddb(ji)) + + ! The result is zt1 + zt2, after normalization. + yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),dp ) + END DO + ! + END SUBROUTINE DDPDD_MPI + + + SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) + !!---------------------------------------------------------------------- + !! *** routine mpp_report *** + !! + !! ** Purpose : report use of mpp routines per time-setp + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + INTEGER , OPTIONAL, INTENT(in ) :: kpk, kpl, kpf + LOGICAL , OPTIONAL, INTENT(in ) :: ld_lbc, ld_glb, ld_dlg + !! + CHARACTER(len=128) :: ccountname ! name of a subroutine to count communications + LOGICAL :: ll_lbc, ll_glb, ll_dlg + INTEGER :: ji, jj, jk, jh, jf, jcount ! dummy loop indices + !!---------------------------------------------------------------------- + ! + ll_lbc = .FALSE. + IF( PRESENT(ld_lbc) ) ll_lbc = ld_lbc + ll_glb = .FALSE. + IF( PRESENT(ld_glb) ) ll_glb = ld_glb + ll_dlg = .FALSE. + IF( PRESENT(ld_dlg) ) ll_dlg = ld_dlg + ! + ! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency + ncom_freq = ncom_fsbc + ! + IF ( ncom_stp == nit000+ncom_freq ) THEN ! avoid to count extra communications in potential initializations at nit000 + IF( ll_lbc ) THEN + IF( .NOT. ALLOCATED(ncomm_sequence) ) ALLOCATE( ncomm_sequence(ncom_rec_max,2) ) + IF( .NOT. ALLOCATED( crname_lbc) ) ALLOCATE( crname_lbc(ncom_rec_max ) ) + n_sequence_lbc = n_sequence_lbc + 1 + IF( n_sequence_lbc > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock + crname_lbc(n_sequence_lbc) = cdname ! keep the name of the calling routine + ncomm_sequence(n_sequence_lbc,1) = kpk*kpl ! size of 3rd and 4th dimensions + ncomm_sequence(n_sequence_lbc,2) = kpf ! number of arrays to be treated (multi) + ENDIF + IF( ll_glb ) THEN + IF( .NOT. ALLOCATED(crname_glb) ) ALLOCATE( crname_glb(ncom_rec_max) ) + n_sequence_glb = n_sequence_glb + 1 + IF( n_sequence_glb > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock + crname_glb(n_sequence_glb) = cdname ! keep the name of the calling routine + ENDIF + IF( ll_dlg ) THEN + IF( .NOT. ALLOCATED(crname_dlg) ) ALLOCATE( crname_dlg(ncom_rec_max) ) + n_sequence_dlg = n_sequence_dlg + 1 + IF( n_sequence_dlg > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock + crname_dlg(n_sequence_dlg) = cdname ! keep the name of the calling routine + ENDIF + ELSE IF ( ncom_stp == nit000+2*ncom_freq ) THEN + CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) + WRITE(numcom,*) ' ' + WRITE(numcom,*) ' ------------------------------------------------------------' + WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):' + WRITE(numcom,*) ' ------------------------------------------------------------' + WRITE(numcom,*) ' ' + WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc + jj = 0; jk = 0; jf = 0; jh = 0 + DO ji = 1, n_sequence_lbc + IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1 + IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1 + IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1 + jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2)) + END DO + WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk + WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf + WRITE(numcom,'(A,I3)') ' from which 3D : ', jj + WRITE(numcom,'(A,I10)') ' Array max size : ', jh*jpi*jpj + WRITE(numcom,*) ' ' + WRITE(numcom,*) ' lbc_lnk called' + DO ji = 1, n_sequence_lbc - 1 + IF ( crname_lbc(ji) /= 'already counted' ) THEN + ccountname = crname_lbc(ji) + crname_lbc(ji) = 'already counted' + jcount = 1 + DO jj = ji + 1, n_sequence_lbc + IF ( ccountname == crname_lbc(jj) ) THEN + jcount = jcount + 1 + crname_lbc(jj) = 'already counted' + END IF + END DO + WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname) + END IF + END DO + IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN + WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) + END IF + WRITE(numcom,*) ' ' + IF ( n_sequence_glb > 0 ) THEN + WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb + jj = 1 + DO ji = 2, n_sequence_glb + IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN + WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1)) + jj = 0 + END IF + jj = jj + 1 + END DO + WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb)) + DEALLOCATE(crname_glb) + ELSE + WRITE(numcom,*) ' No MPI global communication ' + ENDIF + WRITE(numcom,*) ' ' + IF ( n_sequence_dlg > 0 ) THEN + WRITE(numcom,'(A,I4)') ' Delayed global communications : ', n_sequence_dlg + jj = 1 + DO ji = 2, n_sequence_dlg + IF( crname_dlg(ji-1) /= crname_dlg(ji) ) THEN + WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(ji-1)) + jj = 0 + END IF + jj = jj + 1 + END DO + WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(n_sequence_dlg)) + DEALLOCATE(crname_dlg) + ELSE + WRITE(numcom,*) ' No MPI delayed global communication ' + ENDIF + WRITE(numcom,*) ' ' + WRITE(numcom,*) ' -----------------------------------------------' + WRITE(numcom,*) ' ' + DEALLOCATE(ncomm_sequence) + DEALLOCATE(crname_lbc) + ENDIF + END SUBROUTINE mpp_report + + + SUBROUTINE tic_tac (ld_tic, ld_global) + + LOGICAL, INTENT(IN) :: ld_tic + LOGICAL, OPTIONAL, INTENT(IN) :: ld_global + REAL(dp), DIMENSION(2), SAVE :: tic_wt + REAL(dp), SAVE :: tic_ct = 0._dp + INTEGER :: ii + + IF( ncom_stp <= nit000 ) RETURN + IF( ncom_stp == nitend ) RETURN + ii = 1 + IF( PRESENT( ld_global ) ) THEN + IF( ld_global ) ii = 2 + END IF + + IF ( ld_tic ) THEN + tic_wt(ii) = MPI_Wtime() ! start count tic->tac (waiting time) + IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic + ELSE + waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii) ! cumulate count tic->tac + tic_ct = MPI_Wtime() ! start count tac->tic (waiting time) + ENDIF + + END SUBROUTINE tic_tac + + + !!---------------------------------------------------------------------- + !! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam, load_nml routines + !!---------------------------------------------------------------------- + + SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , & + & cd6, cd7, cd8, cd9, cd10 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE stop_opa *** + !! + !! ** Purpose : print in ocean.outpput file a error message and + !! increment the error number (nstop) by one. + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cd1 + CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5 + CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 + ! + CHARACTER(LEN=8) :: clfmt ! writing format + INTEGER :: inum + !!---------------------------------------------------------------------- + ! + nstop = nstop + 1 + ! + IF( cd1 == 'STOP' .AND. narea /= 1 ) THEN ! Immediate stop: add an arror message in 'ocean.output' file + CALL ctl_opn( inum, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) + WRITE(inum,*) + WRITE(inum,*) ' ==>>> Look for "E R R O R" messages in all existing *ocean.output* files' + CLOSE(inum) + ENDIF + IF( numout == 6 ) THEN ! force to open ocean.output file if not already opened + CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) + ENDIF + ! + WRITE(numout,*) + WRITE(numout,*) ' ===>>> : E R R O R' + WRITE(numout,*) + WRITE(numout,*) ' ===========' + WRITE(numout,*) + WRITE(numout,*) TRIM(cd1) + IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) + IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) + IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) + IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) + IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) + IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) + IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) + IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) + IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) + WRITE(numout,*) + ! + CALL FLUSH(numout ) + IF( numstp /= -1 ) CALL FLUSH(numstp ) + IF( numrun /= -1 ) CALL FLUSH(numrun ) + IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice) + ! + IF( cd1 == 'STOP' ) THEN + WRITE(numout,*) + WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' + WRITE(numout,*) + CALL FLUSH(numout) + CALL SLEEP(60) ! make sure that all output and abort files are written by all cores. 60s should be enough... + CALL mppstop( ld_abort = .true. ) + ENDIF + ! + END SUBROUTINE ctl_stop + + + SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, & + & cd6, cd7, cd8, cd9, cd10 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE stop_warn *** + !! + !! ** Purpose : print in ocean.outpput file a error message and + !! increment the warning number (nwarn) by one. + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 + CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 + !!---------------------------------------------------------------------- + ! + nwarn = nwarn + 1 + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ===>>> : W A R N I N G' + WRITE(numout,*) + WRITE(numout,*) ' ===============' + WRITE(numout,*) + IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) + IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) + IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) + IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) + IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) + IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) + IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) + IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) + IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) + IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) + WRITE(numout,*) + ENDIF + CALL FLUSH(numout) + ! + END SUBROUTINE ctl_warn + + + SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ctl_opn *** + !! + !! ** Purpose : Open file and check if required file is available. + !! + !! ** Method : Fortan open + !!---------------------------------------------------------------------- + INTEGER , INTENT( out) :: knum ! logical unit to open + CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open + CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier + CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier + CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier + INTEGER , INTENT(in ) :: klengh ! record length + INTEGER , INTENT(in ) :: kout ! number of logical units for write + LOGICAL , INTENT(in ) :: ldwp ! boolean term for print + INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number + ! + CHARACTER(len=80) :: clfile + CHARACTER(LEN=10) :: clfmt ! writing format + INTEGER :: iost + INTEGER :: idg ! number of digits + !!---------------------------------------------------------------------- + ! + ! adapt filename + ! ---------------- + clfile = TRIM(cdfile) + IF( PRESENT( karea ) ) THEN + IF( karea > 1 ) THEN + ! Warning: jpnij is maybe not already defined when calling ctl_opn -> use mppsize instead of jpnij + idg = MAX( INT(LOG10(REAL(MAX(1,mppsize-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ')')") idg, idg ! '(a,a,ix.x)' + WRITE(clfile, clfmt) TRIM(clfile), '_', karea-1 + ENDIF + ENDIF + knum=get_unit() + IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null + ! + IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters + OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost ) + ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters + OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS='UNKNOWN', POSITION='APPEND', ERR=100, IOSTAT=iost ) + ELSE + OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost ) + ENDIF + IF( iost /= 0 .AND. TRIM(clfile) == '/dev/null' ) & ! for windows + & OPEN(UNIT=knum,FILE='NUL', FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost ) + IF( iost == 0 ) THEN + IF(ldwp .AND. kout > 0) THEN + WRITE(kout,*) ' file : ', TRIM(clfile),' open ok' + WRITE(kout,*) ' unit = ', knum + WRITE(kout,*) ' status = ', cdstat + WRITE(kout,*) ' form = ', cdform + WRITE(kout,*) ' access = ', cdacce + WRITE(kout,*) + ENDIF + ENDIF +100 CONTINUE + IF( iost /= 0 ) THEN + WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) + WRITE(ctmp2,*) ' ======= === ' + WRITE(ctmp3,*) ' unit = ', knum + WRITE(ctmp4,*) ' status = ', cdstat + WRITE(ctmp5,*) ' form = ', cdform + WRITE(ctmp6,*) ' access = ', cdacce + WRITE(ctmp7,*) ' iostat = ', iost + WRITE(ctmp8,*) ' we stop. verify the file ' + CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) + ENDIF + ! + END SUBROUTINE ctl_opn + + + SUBROUTINE ctl_nam ( kios, cdnam ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ctl_nam *** + !! + !! ** Purpose : Informations when error while reading a namelist + !! + !! ** Method : Fortan open + !!---------------------------------------------------------------------- + INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist + CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs + ! + CHARACTER(len=5) :: clios ! string to convert iostat in character for print + !!---------------------------------------------------------------------- + ! + WRITE (clios, '(I5.0)') kios + IF( kios < 0 ) THEN + CALL ctl_warn( 'end of record or file while reading namelist ' & + & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) ) + ENDIF + ! + IF( kios > 0 ) THEN + CALL ctl_stop( 'misspelled variable in namelist ' & + & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) ) + ENDIF + kios = 0 + ! + END SUBROUTINE ctl_nam + + + INTEGER FUNCTION get_unit() + !!---------------------------------------------------------------------- + !! *** FUNCTION get_unit *** + !! + !! ** Purpose : return the index of an unused logical unit + !!---------------------------------------------------------------------- + LOGICAL :: llopn + !!---------------------------------------------------------------------- + ! + get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO + llopn = .TRUE. + DO WHILE( (get_unit < 9999) .AND. llopn ) + get_unit = get_unit + 1 + INQUIRE( unit = get_unit, opened = llopn ) + END DO + IF( (get_unit == 9999) .AND. llopn ) THEN + CALL ctl_stop( 'STOP', 'get_unit: All logical units until 9999 are used...' ) + ENDIF + ! + END FUNCTION get_unit + + SUBROUTINE load_nml( cdnambuff , cdnamfile, kout, ldwp) + CHARACTER(LEN=:) , ALLOCATABLE, INTENT(INOUT) :: cdnambuff + CHARACTER(LEN=*), INTENT(IN ) :: cdnamfile + CHARACTER(LEN=256) :: chline + CHARACTER(LEN=1) :: csp + INTEGER, INTENT(IN) :: kout + LOGICAL, INTENT(IN) :: ldwp !: .true. only for the root broadcaster + INTEGER :: itot, iun, iltc, inl, ios, itotsav + ! + !csp = NEW_LINE('A') + ! a new line character is the best seperator but some systems (e.g.Cray) + ! seem to terminate namelist reads from internal files early if they + ! encounter new-lines. Use a single space for safety. + csp = ' ' + ! + ! Check if the namelist buffer has already been allocated. Return if it has. + ! + IF ( ALLOCATED( cdnambuff ) ) RETURN + IF( ldwp ) THEN + ! + ! Open namelist file + ! + CALL ctl_opn( iun, cdnamfile, 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, kout, ldwp ) + ! + ! First pass: count characters excluding comments and trimable white space + ! + itot=0 + 10 READ(iun,'(A256)',END=20,ERR=20) chline + iltc = LEN_TRIM(chline) + IF ( iltc.GT.0 ) THEN + inl = INDEX(chline, '!') + IF( inl.eq.0 ) THEN + itot = itot + iltc + 1 ! +1 for the newline character + ELSEIF( inl.GT.0 .AND. LEN_TRIM( chline(1:inl-1) ).GT.0 ) THEN + itot = itot + inl ! includes +1 for the newline character + ENDIF + ENDIF + GOTO 10 + 20 CONTINUE + ! + ! Allocate text cdnambuff for condensed namelist + ! +!$AGRIF_DO_NOT_TREAT + ALLOCATE( CHARACTER(LEN=itot) :: cdnambuff ) +!$AGRIF_END_DO_NOT_TREAT + itotsav = itot + ! + ! Second pass: read and transfer pruned characters into cdnambuff + ! + REWIND(iun) + itot=1 + 30 READ(iun,'(A256)',END=40,ERR=40) chline + iltc = LEN_TRIM(chline) + IF ( iltc.GT.0 ) THEN + inl = INDEX(chline, '!') + IF( inl.eq.0 ) THEN + inl = iltc + ELSE + inl = inl - 1 + ENDIF + IF( inl.GT.0 .AND. LEN_TRIM( chline(1:inl) ).GT.0 ) THEN + cdnambuff(itot:itot+inl-1) = chline(1:inl) + WRITE( cdnambuff(itot+inl:itot+inl), '(a)' ) csp + itot = itot + inl + 1 + ENDIF + ENDIF + GOTO 30 + 40 CONTINUE + itot = itot - 1 + IF( itotsav .NE. itot ) WRITE(*,*) 'WARNING in load_nml. Allocated ',itotsav,' for read buffer; but used ',itot + ! + ! Close namelist file + ! + CLOSE(iun) + !write(*,'(32A)') cdnambuff + ENDIF + CALL mpp_bcast_nml( cdnambuff, itot ) + END SUBROUTINE load_nml + + + !!---------------------------------------------------------------------- +END MODULE lib_mpp diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/module_example.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/module_example.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1d57d694e39ce40a2c5c09b060d50bf72b7a073c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/module_example.f90 @@ -0,0 +1,35 @@ + + + + + + + + + + + + + +MODULE exampl + !!====================================================================== + !! *** MODULE exampl *** + !! Ocean physics: brief description of the purpose of the module + !! (please no more than 2 lines) + !!====================================================================== + !! History : 3.0 ! 2008-06 (Author Names) Original code + !! - ! 2008-08 (Author names) brief description of modifications + !! 3.3 ! 2010-11 (Author names) - - + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! Default option : NO example + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE exa_mpl( kt, pvar1, pvar2, ptab ) ! Empty routine + INTEGER :: kt + REAL:: pvar1, pvar2, ptab(:,:) + WRITE(*,*) 'exa_mpl: You should not have seen this print! error?', kt, pvar1, pvar2, ptab(1,1) + END SUBROUTINE exa_mpl + + !!====================================================================== +END MODULE exampl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/mpp_map.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/mpp_map.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5aeaf3798b35e60d54cd670b24a437e9dc62f007 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/mpp_map.f90 @@ -0,0 +1,88 @@ + + + + + + + + + + + + + +MODULE mpp_map + !!====================================================================== + !! *** MODULE mpp_mpa *** + !! NEMOVAR: MPP global grid point mapping to processors + !!====================================================================== + !! History : 2.0 ! 2007-08 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! mppmap_init : Initialize mppmap. + !!---------------------------------------------------------------------- + USE par_kind, ONLY : wp ! Precision variables + USE par_oce , ONLY : jpi, jpj, Nis0, Nie0, Njs0, Nje0 ! Ocean parameters + USE dom_oce , ONLY : mig, mjg, narea ! Ocean space and time domain variables + USE lib_mpp , ONLY : mpi_comm_oce ! MPP library + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC :: mppmap_init, mppmap !: ??? + + INTEGER, DIMENSION(:,:), ALLOCATABLE :: mppmap ! ??? + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: mpp_map.F90 14229 2020-12-20 12:45:55Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE mppmap_init + !!---------------------------------------------------------------------- + !! *** ROUTINE mppmap_init *** + !! + !! ** Purpose : Setup a global map of processor rank for all gridpoints + !! + !! ** Method : MPI all reduce. + !! + !! ** Action : This does only work for MPI. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:), ALLOCATABLE :: imppmap ! + INTEGER :: ierr + +INCLUDE 'mpif.h' + !!---------------------------------------------------------------------- + + IF (.NOT. ALLOCATED(mppmap)) THEN + ALLOCATE( & + & mppmap(jpiglo,jpjglo) & + & ) + ENDIF + ! Initialize local imppmap + + ALLOCATE( & + & imppmap(jpiglo,jpjglo) & + & ) + imppmap(:,:) = 0 + +! ! Setup local grid points + imppmap(mig(1):mig(jpi),mjg(1):mjg(jpj)) = narea + + ! Get global data + + + ! Call the MPI library to find the max across processors + CALL mpi_allreduce( imppmap, mppmap, jpiglo*jpjglo, mpi_integer, & + & mpi_max, mpi_comm_oce, ierr ) + ! + END SUBROUTINE mppmap_init + + !!====================================================================== +END MODULE mpp_map diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/mppini.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/mppini.f90 new file mode 100644 index 0000000000000000000000000000000000000000..375f1ada0a4a0fa3407c6e5bd2b6a32bb05dd615 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/mppini.f90 @@ -0,0 +1,1384 @@ + + + + + + + + + + + + + +MODULE mppini + !!====================================================================== + !! *** MODULE mppini *** + !! Ocean initialization : distributed memory computing initialization + !!====================================================================== + !! History : 6.0 ! 1994-11 (M. Guyon) Original code + !! OPA 7.0 ! 1995-04 (J. Escobar, M. Imbard) + !! 8.0 ! 1998-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions + !! NEMO 1.0 ! 2004-01 (G. Madec, J.M Molines) F90 : free form , north fold jpni > 1 + !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add init_nfdcom + !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) init_nfdcom: setup avoiding MPI communication + !! 4.0 ! 2016-06 (G. Madec) use domain configuration file instead of bathymetry file + !! 4.0 ! 2017-06 (J.M. Molines, T. Lovato) merge of mppini and mppini_2 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! mpp_init : Lay out the global domain over processors with/without land processor elimination + !! init_ioipsl: IOIPSL initialization in mpp + !! init_nfdcom: Setup for north fold exchanges with explicit point-to-point messaging + !! init_doloop: set the starting/ending indices of DO-loop used in do_loop_substitute + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE bdy_oce ! open BounDarY + ! + USE lbcnfd ! Setup of north fold exchanges + USE lib_mpp ! distribued memory computing library + USE iom ! nemo I/O library + USE ioipsl ! I/O IPSL library + USE in_out_manager ! I/O Manager + + IMPLICIT NONE + PRIVATE + + PUBLIC mpp_init ! called by nemogcm.F90 + PUBLIC mpp_getnum ! called by prtctl + PUBLIC mpp_basesplit ! called by prtctl + PUBLIC mpp_is_ocean ! called by prtctl + + INTEGER :: numbot = -1 ! 'bottom_level' local logical unit + INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: mppini.F90 15302 2021-09-29 15:00:15Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + !!---------------------------------------------------------------------- + !! MPI massively parallel processing + !!---------------------------------------------------------------------- + + + SUBROUTINE mpp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init *** + !! + !! ** Purpose : Lay out the global domain over processors. + !! If land processors are to be eliminated, this program requires the + !! presence of the domain configuration file. Land processors elimination + !! is performed if jpni x jpnj /= jpnij. In this case, using the MPP_PREP + !! preprocessing tool, help for defining the best cutting out. + !! + !! ** Method : Global domain is distributed in smaller local domains. + !! Periodic condition is a function of the local domain position + !! (global boundary or neighbouring domain) and of the global periodic + !! + !! ** Action : - set domain parameters + !! nimpp : longitudinal index + !! njmpp : latitudinal index + !! narea : number for local area + !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jn, jp, jh + INTEGER :: ii, ij, ii2, ij2 + INTEGER :: inijmin ! number of oce subdomains + INTEGER :: inum, inum0 + INTEGER :: ifreq, il1, imil, il2, ijm1 + INTEGER :: ierr, ios + INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 + INTEGER, DIMENSION(16*n_hlsmax) :: ichanged + INTEGER, ALLOCATABLE, DIMENSION(: ) :: iin, ijn + INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: iimppt, ijpi, ipproc + INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: ijmppt, ijpj + INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: impi + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: inei + LOGICAL :: llbest, llauto + LOGICAL :: llwrtlay + LOGICAL :: llmpi_Iperio, llmpi_Jperio, llmpiNFold + LOGICAL :: ln_listonly + LOGICAL, ALLOCATABLE, DIMENSION(:,: ) :: llisOce ! is not land-domain only? + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: llnei ! are neighbourgs existing? + NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & + & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & + & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & + & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & + & cn_ice, nn_ice_dta, & + & ln_vol, nn_volctl, nn_rimwidth + NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly, nn_comm + !!---------------------------------------------------------------------- + ! + llwrtlay = lwm .OR. sn_cfctl%l_layout + ! + ! 0. read namelists parameters + ! ----------------------------------- + ! + READ ( numnam_ref, nammpp, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist' ) + READ ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) + ! + nn_hls = MAX(1, nn_hls) ! nn_hls must be > 0 + IF(lwp) THEN + WRITE(numout,*) ' Namelist nammpp' + IF( jpni < 1 .OR. jpnj < 1 ) THEN + WRITE(numout,*) ' jpni and jpnj will be calculated automatically' + ELSE + WRITE(numout,*) ' processor grid extent in i jpni = ', jpni + WRITE(numout,*) ' processor grid extent in j jpnj = ', jpnj + ENDIF + WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather + WRITE(numout,*) ' halo width (applies to both rows and columns) nn_hls = ', nn_hls + ENDIF + ! + IF(lwm) WRITE( numond, nammpp ) + ! + jpiglo = Ni0glo + 2 * nn_hls + jpjglo = Nj0glo + 2 * nn_hls + ! + ! do we need to take into account bdy_msk? + READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' ) + READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' ) + ! + IF( ln_read_cfg ) CALL iom_open( cn_domcfg, numbot ) + IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) + ! + IF( ln_listonly ) CALL bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core + ! + ! 1. Dimension arrays for subdomains + ! ----------------------------------- + ! + ! If dimensions of MPI processes grid weren't specified in the namelist file + ! then we calculate them here now that we have our communicator size + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'mpp_init:' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF + IF( jpni < 1 .OR. jpnj < 1 ) THEN + CALL bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes + llauto = .TRUE. + llbest = .TRUE. + ELSE + llauto = .FALSE. + CALL bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes + ! largest subdomain size for mpi decoposition jpni*jpnj given in the namelist + CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax ) + ! largest subdomain size for mpi decoposition inbi*inbj given by bestpartition + CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, inbi, inbj, iimax, ijmax ) + icnt1 = jpni*jpnj - mppsize ! number of land subdomains that should be removed to use mppsize mpi processes + IF(lwp) THEN + WRITE(numout,9000) ' The chosen domain decomposition ', jpni, ' x ', jpnj, ' with ', icnt1, ' land subdomains' + WRITE(numout,9002) ' - uses a total of ', mppsize,' mpi process' + WRITE(numout,9000) ' - has mpi subdomains with a maximum size of (jpi = ', jpimax, ', jpj = ', jpjmax, & + & ', jpi*jpj = ', jpimax*jpjmax, ')' + WRITE(numout,9000) ' The best domain decompostion ', inbi, ' x ', inbj, ' with ', icnt2, ' land subdomains' + WRITE(numout,9002) ' - uses a total of ', inbi*inbj-icnt2,' mpi process' + WRITE(numout,9000) ' - has mpi subdomains with a maximum size of (jpi = ', iimax, ', jpj = ', ijmax, & + & ', jpi*jpj = ', iimax* ijmax, ')' + ENDIF + IF( iimax*ijmax < jpimax*jpjmax ) THEN ! chosen subdomain size is larger that the best subdomain size + llbest = .FALSE. + IF ( inbi*inbj-icnt2 < mppsize ) THEN + WRITE(ctmp1,*) ' ==> You could therefore have smaller mpi subdomains with less mpi processes' + ELSE + WRITE(ctmp1,*) ' ==> You could therefore have smaller mpi subdomains with the same number of mpi processes' + ENDIF + CALL ctl_warn( ' ', ctmp1, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) + ELSE IF ( iimax*ijmax == jpimax*jpjmax .AND. (inbi*inbj-icnt2) < mppsize) THEN + llbest = .FALSE. + WRITE(ctmp1,*) ' ==> You could therefore have the same mpi subdomains size with less mpi processes' + CALL ctl_warn( ' ', ctmp1, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) + ELSE + llbest = .TRUE. + ENDIF + ENDIF + + ! look for land mpi subdomains... + ALLOCATE( llisOce(jpni,jpnj) ) + CALL mpp_is_ocean( llisOce ) + inijmin = COUNT( llisOce ) ! number of oce subdomains + + IF( mppsize < inijmin ) THEN ! too many oce subdomains: can happen only if jpni and jpnj are prescribed... + WRITE(ctmp1,9001) ' With this specified domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj + WRITE(ctmp2,9002) ' we can eliminate only ', jpni*jpnj - inijmin, ' land mpi subdomains therefore ' + WRITE(ctmp3,9001) ' the number of ocean mpi subdomains (', inijmin,') exceed the number of MPI processes:', mppsize + WRITE(ctmp4,*) ' ==>>> There is the list of best domain decompositions you should use: ' + CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) + CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core + ENDIF + + IF( mppsize > jpni*jpnj ) THEN ! not enough mpi subdomains for the total number of mpi processes + IF(lwp) THEN + WRITE(numout,9003) ' The number of mpi processes: ', mppsize + WRITE(numout,9003) ' exceeds the maximum number of subdomains (ocean+land) = ', jpni*jpnj + WRITE(numout,9001) ' defined by the following domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj + WRITE(numout, *) ' You should: ' + IF( llauto ) THEN + WRITE(numout,*) ' - either prescribe your domain decomposition with the namelist variables' + WRITE(numout,*) ' jpni and jpnj to match the number of mpi process you want to use, ' + WRITE(numout,*) ' even IF it not the best choice...' + WRITE(numout,*) ' - or keep the automatic and optimal domain decomposition by picking up one' + WRITE(numout,*) ' of the number of mpi process proposed in the list bellow' + ELSE + WRITE(numout,*) ' - either properly prescribe your domain decomposition with jpni and jpnj' + WRITE(numout,*) ' in order to be consistent with the number of mpi process you want to use' + WRITE(numout,*) ' even IF it not the best choice...' + WRITE(numout,*) ' - or use the automatic and optimal domain decomposition and pick up one of' + WRITE(numout,*) ' the domain decomposition proposed in the list bellow' + ENDIF + WRITE(numout,*) + ENDIF + CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core + ENDIF + + jpnij = mppsize ! force jpnij definition <-- remove as much land subdomains as needed to reach this condition + IF( mppsize > inijmin ) THEN + WRITE(ctmp1,9003) ' The number of mpi processes: ', mppsize + WRITE(ctmp2,9003) ' exceeds the maximum number of ocean subdomains = ', inijmin + WRITE(ctmp3,9002) ' we suppressed ', jpni*jpnj - mppsize, ' land subdomains ' + WRITE(ctmp4,9002) ' BUT we had to keep ', mppsize - inijmin, ' land subdomains that are useless...' + CALL ctl_warn( ctmp1, ctmp2, ctmp3, ctmp4, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) + ELSE ! mppsize = inijmin + IF(lwp) THEN + IF(llbest) WRITE(numout,*) ' ==> you use the best mpi decomposition' + WRITE(numout,*) + WRITE(numout,9003) ' Number of mpi processes: ', mppsize + WRITE(numout,9003) ' Number of ocean subdomains = ', inijmin + WRITE(numout,9003) ' Number of suppressed land subdomains = ', jpni*jpnj - inijmin + WRITE(numout,*) + ENDIF + ENDIF +9000 FORMAT (a, i4, a, i4, a, i7, a) +9001 FORMAT (a, i4, a, i4) +9002 FORMAT (a, i4, a) +9003 FORMAT (a, i5) + + ALLOCATE( nfimpp(jpni), nfproc(jpni), nfjpi(jpni), & + & iin(jpnij), ijn(jpnij), & + & iimppt(jpni,jpnj), ijmppt(jpni,jpnj), ijpi(jpni,jpnj), ijpj(jpni,jpnj), ipproc(jpni,jpnj), & + & inei(8,jpni,jpnj), llnei(8,jpni,jpnj), & + & impi(8,jpnij), & + & STAT=ierr ) + CALL mpp_sum( 'mppini', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' ) + + ! + ! 2. Index arrays for subdomains + ! ----------------------------------- + ! + CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) + CALL mpp_getnum( llisOce, ipproc, iin, ijn ) + ! + ii = iin(narea) + ij = ijn(narea) + jpi = ijpi(ii,ij) + jpj = ijpj(ii,ij) + jpk = MAX( 2, jpkglo ) + jpij = jpi*jpj + nimpp = iimppt(ii,ij) + njmpp = ijmppt(ii,ij) + ! + CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) + CALL init_locglo ! define now functions needed to convert indices from/to global to/from local domains + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'MPI Message Passing MPI - domain lay out over processors' + WRITE(numout,*) + WRITE(numout,*) ' defines mpp subdomains' + WRITE(numout,*) ' jpni = ', jpni + WRITE(numout,*) ' jpnj = ', jpnj + WRITE(numout,*) ' jpnij = ', jpnij + WRITE(numout,*) ' nimpp = ', nimpp + WRITE(numout,*) ' njmpp = ', njmpp + WRITE(numout,*) + WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo + WRITE(numout,*) ' sum ijpj(1,j) = ', SUM(ijpj(1,:)), ' jpjglo = ', jpjglo + + ! Subdomain grid print + ifreq = 4 + il1 = 1 + DO jn = 1, (jpni-1)/ifreq+1 + il2 = MIN(jpni,il1+ifreq-1) + WRITE(numout,*) + WRITE(numout,9400) ('***',ji=il1,il2-1) + DO jj = jpnj, 1, -1 + WRITE(numout,9403) (' ',ji=il1,il2-1) + WRITE(numout,9402) jj, (ijpi(ji,jj),ijpj(ji,jj),ji=il1,il2) + WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2) + WRITE(numout,9403) (' ',ji=il1,il2-1) + WRITE(numout,9400) ('***',ji=il1,il2-1) + END DO + WRITE(numout,9401) (ji,ji=il1,il2) + il1 = il1+ifreq + END DO + 9400 FORMAT(' ***' ,20('*************',a3) ) + 9403 FORMAT(' * ',20(' * ',a3) ) + 9401 FORMAT(' ' ,20(' ',i3,' ') ) + 9402 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ') ) + 9404 FORMAT(' * ' ,20(' ' ,i4,' * ') ) + ENDIF + ! + ! Store informations for the north pole folding communications + nfproc(:) = ipproc(:,jpnj) + nfimpp(:) = iimppt(:,jpnj) + nfjpi (:) = ijpi(:,jpnj) + ! + ! 3. Define Western, Eastern, Southern and Northern neighbors + corners in the subdomain grid reference + ! ------------------------------------------------------------------------------------------------------ + ! + ! note that North fold is has specific treatment for its MPI communications. + ! This must not be treated as a "usual" communication with a northern neighbor. + ! -> North fold processes have no Northern neighbor in the definition done bellow + ! + llmpi_Iperio = jpni > 1 .AND. l_Iperio ! do i-periodicity with an MPI communication? + llmpi_Jperio = jpnj > 1 .AND. l_Jperio ! do j-periodicity with an MPI communication? + ! + l_SelfPerio(1:2) = l_Iperio .AND. jpni == 1 ! west, east periodicity by itself + l_SelfPerio(3:4) = l_Jperio .AND. jpnj == 1 ! south, north periodicity by itself + l_SelfPerio(5:8) = l_SelfPerio(jpwe) .AND. l_SelfPerio(jpso) ! corners bi-periodicity by itself + ! + ! define neighbors mapping (1/2): default definition: ignore if neighbours are land-only subdomains or not + DO jj = 1, jpnj + DO ji = 1, jpni + ! + IF ( llisOce(ji,jj) ) THEN ! this subdomain has some ocean: it has neighbours + ! + inum0 = ji - 1 + ( jj - 1 ) * jpni ! index in the subdomains grid. start at 0 + ! + ! Is there a neighbor? + llnei(jpwe,ji,jj) = ji > 1 .OR. llmpi_Iperio ! West nei exists if not the first column or llmpi_Iperio + llnei(jpea,ji,jj) = ji < jpni .OR. llmpi_Iperio ! East nei exists if not the last column or llmpi_Iperio + llnei(jpso,ji,jj) = jj > 1 .OR. llmpi_Jperio ! South nei exists if not the first line or llmpi_Jperio + llnei(jpno,ji,jj) = jj < jpnj .OR. llmpi_Jperio ! North nei exists if not the last line or llmpi_Jperio + llnei(jpsw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpso,ji,jj) ! So-We nei exists if both South and West nei exist + llnei(jpse,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpso,ji,jj) ! So-Ea nei exists if both South and East nei exist + llnei(jpnw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpno,ji,jj) ! No-We nei exists if both North and West nei exist + llnei(jpne,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpno,ji,jj) ! No-Ea nei exists if both North and East nei exist + ! + ! Which index (starting at 0) have neighbors in the subdomains grid? + IF( llnei(jpwe,ji,jj) ) inei(jpwe,ji,jj) = inum0 - 1 + jpni * COUNT( (/ ji == 1 /) ) + IF( llnei(jpea,ji,jj) ) inei(jpea,ji,jj) = inum0 + 1 - jpni * COUNT( (/ ji == jpni /) ) + IF( llnei(jpso,ji,jj) ) inei(jpso,ji,jj) = inum0 - jpni + jpni * jpnj * COUNT( (/ jj == 1 /) ) + IF( llnei(jpno,ji,jj) ) inei(jpno,ji,jj) = inum0 + jpni - jpni * jpnj * COUNT( (/ jj == jpnj /) ) + IF( llnei(jpsw,ji,jj) ) inei(jpsw,ji,jj) = inei(jpso,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) + IF( llnei(jpse,ji,jj) ) inei(jpse,ji,jj) = inei(jpso,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) + IF( llnei(jpnw,ji,jj) ) inei(jpnw,ji,jj) = inei(jpno,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) + IF( llnei(jpne,ji,jj) ) inei(jpne,ji,jj) = inei(jpno,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) + ! + ELSE ! land-only domain has no neighbour + llnei(:,ji,jj) = .FALSE. + ENDIF + ! + END DO + END DO + ! + ! define neighbors mapping (2/2): check if neighbours are not land-only subdomains + DO jj = 1, jpnj + DO ji = 1, jpni + DO jn = 1, 8 + IF( llnei(jn,ji,jj) ) THEN ! if a neighbour is existing -> this should not be a land-only domain + ii = 1 + MOD( inei(jn,ji,jj) , jpni ) + ij = 1 + inei(jn,ji,jj) / jpni + llnei(jn,ji,jj) = llisOce( ii, ij ) + ENDIF + END DO + END DO + END DO + ! + ! update index of the neighbours in the subdomains grid + WHERE( .NOT. llnei ) inei = -1 + ! + ! Save processor layout in ascii file + IF (llwrtlay) THEN + CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) + WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo ( local: narea jpi jpj )' + WRITE(inum,'(6i7,a,3i7,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,' ( local: ',narea,jpi,jpj,' )' + WRITE(inum,*) + WRITE(inum, *) '------------------------------------' + WRITE(inum,'(a,i2)') ' Mapping of the default neighnourgs ' + WRITE(inum, *) '------------------------------------' + WRITE(inum,*) + WRITE(inum,'(a)') ' rank ii ij jpi jpj nimpp njmpp mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' + DO jp = 1, jpnij + ii = iin(jp) + ij = ijn(jp) + WRITE(inum,'(15i6)') jp-1, ii, ij, ijpi(ii,ij), ijpj(ii,ij), iimppt(ii,ij), ijmppt(ii,ij), inei(:,ii,ij) + END DO + ENDIF + + ! + ! 4. Define Western, Eastern, Southern and Northern neighbors + corners for each mpi process + ! ------------------------------------------------------------------------------------------ + ! + ! rewrite information from "subdomain grid" to mpi process list + ! Warning, for example: + ! position of the northern neighbor in the "subdomain grid" + ! position of the northern neighbor in the "mpi process list" + + ! default definition: no neighbors + impi(:,:) = -1 ! (starting at 0, -1 if no neighbourg) + + DO jp = 1, jpnij + ii = iin(jp) + ij = ijn(jp) + DO jn = 1, 8 + IF( llnei(jn,ii,ij) ) THEN ! must be tested as some land-domain can be kept to fit mppsize + ii2 = 1 + MOD( inei(jn,ii,ij) , jpni ) + ij2 = 1 + inei(jn,ii,ij) / jpni + impi(jn,jp) = ipproc( ii2, ij2 ) + ENDIF + END DO + END DO + + ! + ! 4. keep information for the local process + ! ----------------------------------------- + ! + ! set default neighbours + mpinei(:) = impi(:,narea) + DO jh = 1, n_hlsmax + mpiSnei(jh,:) = impi(:,narea) ! default definition + mpiRnei(jh,:) = impi(:,narea) + END DO + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' resulting internal parameters : ' + WRITE(numout,*) ' narea = ', narea + WRITE(numout,*) ' mpi nei west = ', mpinei(jpwe) , ' mpi nei east = ', mpinei(jpea) + WRITE(numout,*) ' mpi nei south = ', mpinei(jpso) , ' mpi nei north = ', mpinei(jpno) + WRITE(numout,*) ' mpi nei so-we = ', mpinei(jpsw) , ' mpi nei so-ea = ', mpinei(jpse) + WRITE(numout,*) ' mpi nei no-we = ', mpinei(jpnw) , ' mpi nei no-ea = ', mpinei(jpne) + ENDIF + ! + CALL mpp_ini_nc(nn_hls) ! Initialize communicator for neighbourhood collective communications + DO jh = 1, n_hlsmax + mpi_nc_com4(jh) = mpi_nc_com4(nn_hls) ! default definition + mpi_nc_com8(jh) = mpi_nc_com8(nn_hls) + END DO + ! ! Exclude exchanges which contain only land points + ! + IF( jpnij > 1 ) CALL init_excl_landpt + ! + ! ! Prepare mpp north fold + ! + llmpiNFold = jpni > 1 .AND. l_NFold ! is the North fold done with an MPI communication? + l_IdoNFold = ijn(narea) == jpnj .AND. l_NFold ! is this process doing North fold? + ! + IF( llmpiNFold ) CALL init_nfdcom( llwrtlay, inum ) ! init northfold communication, must be done after init_excl_landpt + ! + ! ! Save processor layout changes in ascii file + ! + DO jh = 1, n_hlsmax ! different halo size + DO ji = 1, 8 + ichanged(16*(jh-1) +ji) = COUNT( mpinei(ji:ji) /= mpiSnei(jh,ji:ji) ) + ichanged(16*(jh-1)+8+ji) = COUNT( mpinei(ji:ji) /= mpiRnei(jh,ji:ji) ) + END DO + END DO + CALL mpp_sum( "mpp_init", ichanged ) ! must be called by all processes + IF (llwrtlay) THEN + WRITE(inum,*) + WRITE(inum, *) '----------------------------------------------------------------------' + WRITE(inum,'(a,i2)') ' Mapping of the neighnourgs once excluding comm with only land points ' + WRITE(inum, *) '----------------------------------------------------------------------' + DO jh = 1, n_hlsmax ! different halo size + WRITE(inum,*) + WRITE(inum,'(a,i2)') 'halo size: ', jh + WRITE(inum, *) '---------' + WRITE(inum,'(a)') ' rank ii ij mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' + WRITE(inum, '(11i6,a)') narea-1, iin(narea), ijn(narea), mpinei(:), ' <- Org' + WRITE(inum,'(18x,8i6,a,i1,a)') mpiSnei(jh,:), ' <- Send ', COUNT( mpinei(:) /= mpiSnei(jh,:) ), ' modif' + WRITE(inum,'(18x,8i6,a,i1,a)') mpiRnei(jh,:), ' <- Recv ', COUNT( mpinei(:) /= mpiRnei(jh,:) ), ' modif' + WRITE(inum,*) ' total changes among all mpi tasks:' + WRITE(inum,*) ' mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' + WRITE(inum,'(a,8i6)') ' Send: ', ichanged(jh*16-15:jh*16-8) + WRITE(inum,'(a,8i6)') ' Recv: ', ichanged(jh*16 -7:jh*16 ) + END DO + ENDIF + ! + CALL init_ioipsl ! Prepare NetCDF output file (if necessary) + ! + IF (llwrtlay) CLOSE(inum) + ! + DEALLOCATE(iin, ijn, iimppt, ijmppt, ijpi, ijpj, ipproc, inei, llnei, impi, llisOce) + ! + END SUBROUTINE mpp_init + + + SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_basesplit *** + !! + !! ** Purpose : Lay out the global domain over processors. + !! + !! ** Method : Global domain is distributed in smaller local domains. + !! + !! ** Action : - set for all knbi*knbj domains: + !! kimppt : longitudinal index + !! kjmppt : latitudinal index + !! klci : first dimension + !! klcj : second dimension + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kiglo, kjglo + INTEGER, INTENT(in ) :: khls + INTEGER, INTENT(in ) :: knbi, knbj + INTEGER, INTENT( out) :: kimax, kjmax + INTEGER, DIMENSION(knbi,knbj), OPTIONAL, INTENT( out) :: kimppt, kjmppt + INTEGER, DIMENSION(knbi,knbj), OPTIONAL, INTENT( out) :: klci, klcj + ! + INTEGER :: ji, jj + INTEGER :: i2hls + INTEGER :: iresti, irestj, irm, ijpjmin + !!---------------------------------------------------------------------- + i2hls = 2*khls + ! + kimax = ( kiglo - i2hls + (knbi-1) ) / knbi + i2hls ! first dim. + kjmax = ( kjglo - i2hls + (knbj-1) ) / knbj + i2hls ! second dim. + IF( .NOT. PRESENT(kimppt) ) RETURN + ! + ! 1. Dimension arrays for subdomains + ! ----------------------------------- + ! Computation of local domain sizes klci() klcj() + ! These dimensions depend on global sizes knbi,knbj and kiglo,kjglo + ! The subdomains are squares lesser than or equal to the global + ! dimensions divided by the number of processors minus the overlap array. + ! + iresti = 1 + MOD( kiglo - i2hls - 1 , knbi ) + irestj = 1 + MOD( kjglo - i2hls - 1 , knbj ) + ! + ! Need to use kimax and kjmax here since jpi and jpj not yet defined + klci(1:iresti ,:) = kimax + klci(iresti+1:knbi ,:) = kimax-1 + IF( MINVAL(klci) < 3*khls ) THEN + WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpi must be >= ', 3*khls + WRITE(ctmp2,*) ' We have ', MINVAL(klci) + CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) + ENDIF + IF( l_NFold ) THEN + ! minimize the size of the last row to compensate for the north pole folding coast + IF( c_NFtype == 'T' ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos + IF( c_NFtype == 'F' ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos + irm = knbj - irestj ! total number of lines to be removed + klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row + irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove + irestj = knbj - 1 - irm + klcj(:, irestj+1:knbj-1) = kjmax-1 + ELSE + klcj(:, irestj+1:knbj ) = kjmax-1 + ENDIF + klcj(:,1:irestj) = kjmax + IF( MINVAL(klcj) < 3*khls ) THEN + WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpj must be >= ', 3*khls + WRITE(ctmp2,*) ' We have ', MINVAL(klcj) + CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) + ENDIF + + ! 2. Index arrays for subdomains + ! ------------------------------- + kimppt(:,:) = 1 + kjmppt(:,:) = 1 + ! + IF( knbi > 1 ) THEN + DO jj = 1, knbj + DO ji = 2, knbi + kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i2hls + END DO + END DO + ENDIF + ! + IF( knbj > 1 )THEN + DO jj = 2, knbj + DO ji = 1, knbi + kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i2hls + END DO + END DO + ENDIF + + END SUBROUTINE mpp_basesplit + + + SUBROUTINE bestpartition( knbij, knbi, knbj, knbcnt, ldlist ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bestpartition *** + !! + !! ** Purpose : + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: knbij ! total number of subdomains (knbi*knbj) + INTEGER, OPTIONAL, INTENT( out) :: knbi, knbj ! number if subdomains along i and j (knbi and knbj) + INTEGER, OPTIONAL, INTENT( out) :: knbcnt ! number of land subdomains + LOGICAL, OPTIONAL, INTENT(in ) :: ldlist ! .true.: print the list the best domain decompositions (with land) + ! + INTEGER :: ji, jj, ii, iitarget + INTEGER :: iszitst, iszjtst + INTEGER :: isziref, iszjref + INTEGER :: iszimin, iszjmin + INTEGER :: inbij, iszij + INTEGER :: inbimax, inbjmax, inbijmax, inbijold + INTEGER :: isz0, isz1 + INTEGER, DIMENSION( :), ALLOCATABLE :: indexok + INTEGER, DIMENSION( :), ALLOCATABLE :: inbi0, inbj0, inbij0 ! number of subdomains along i,j + INTEGER, DIMENSION( :), ALLOCATABLE :: iszi0, iszj0, iszij0 ! max size of the subdomains along i,j + INTEGER, DIMENSION( :), ALLOCATABLE :: inbi1, inbj1, inbij1 ! number of subdomains along i,j + INTEGER, DIMENSION( :), ALLOCATABLE :: iszi1, iszj1, iszij1 ! max size of the subdomains along i,j + LOGICAL :: llist + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llmsk2d ! max size of the subdomains along i,j + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisOce ! - - + REAL(wp):: zpropland + !!---------------------------------------------------------------------- + ! + llist = .FALSE. + IF( PRESENT(ldlist) ) llist = ldlist + + CALL mpp_init_landprop( zpropland ) ! get the proportion of land point over the gloal domain + inbij = NINT( REAL(knbij, wp) / ( 1.0 - zpropland ) ) ! define the largest possible value for jpni*jpnj + ! + IF( llist ) THEN ; inbijmax = inbij*2 + ELSE ; inbijmax = inbij + ENDIF + ! + ALLOCATE(inbi0(inbijmax),inbj0(inbijmax),iszi0(inbijmax),iszj0(inbijmax)) + ! + inbimax = 0 + inbjmax = 0 + isziref = jpiglo*jpjglo+1 ! define a value that is larger than the largest possible + iszjref = jpiglo*jpjglo+1 + ! + ! WARNING, see also init_excl_landpt: minimum subdomain size defined here according to nn_hls (and not n_hlsmax) + ! --> If, one day, we want to use local halos largers than nn_hls, we must replace nn_hls by n_hlsmax + ! + iszimin = 3*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain + iszjmin = 3*nn_hls + IF( c_NFtype == 'T' ) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos + IF( c_NFtype == 'F' ) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos + ! + ! get the list of knbi that gives a smaller jpimax than knbi-1 + ! get the list of knbj that gives a smaller jpjmax than knbj-1 + DO ji = 1, inbijmax + iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain i-size + IF( iszitst < isziref .AND. iszitst >= iszimin ) THEN + isziref = iszitst + inbimax = inbimax + 1 + inbi0(inbimax) = ji + iszi0(inbimax) = isziref + ENDIF + iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain j-size + IF( iszjtst < iszjref .AND. iszjtst >= iszjmin ) THEN + iszjref = iszjtst + inbjmax = inbjmax + 1 + inbj0(inbjmax) = ji + iszj0(inbjmax) = iszjref + ENDIF + END DO + IF( inbimax == 0 ) THEN + WRITE(ctmp1,'(a,i2,a,i2)') ' mpp_ini bestpartition: Ni0glo (', Ni0glo, ') is too small to be used with nn_hls = ', nn_hls + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( inbjmax == 0 ) THEN + WRITE(ctmp1,'(a,i2,a,i2)') ' mpp_ini bestpartition: Nj0glo (', Nj0glo, ') is too small to be used with nn_hls = ', nn_hls + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + + ! combine these 2 lists to get all possible knbi*knbj < inbijmax + ALLOCATE( llmsk2d(inbimax,inbjmax) ) + DO jj = 1, inbjmax + DO ji = 1, inbimax + IF ( inbi0(ji) * inbj0(jj) <= inbijmax ) THEN ; llmsk2d(ji,jj) = .TRUE. + ELSE ; llmsk2d(ji,jj) = .FALSE. + ENDIF + END DO + END DO + isz1 = COUNT(llmsk2d) + ALLOCATE( inbi1(isz1), inbj1(isz1), iszi1(isz1), iszj1(isz1) ) + ii = 0 + DO jj = 1, inbjmax + DO ji = 1, inbimax + IF( llmsk2d(ji,jj) .EQV. .TRUE. ) THEN + ii = ii + 1 + inbi1(ii) = inbi0(ji) + inbj1(ii) = inbj0(jj) + iszi1(ii) = iszi0(ji) + iszj1(ii) = iszj0(jj) + ENDIF + END DO + END DO + DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) + DEALLOCATE( llmsk2d ) + + ALLOCATE( inbij1(isz1), iszij1(isz1) ) + inbij1(:) = inbi1(:) * inbj1(:) + iszij1(:) = iszi1(:) * iszj1(:) + + ! if there is no land and no print + IF( .NOT. llist .AND. numbot == -1 .AND. numbdy == -1 ) THEN + ! get the smaller partition which gives the smallest subdomain size + ii = MINLOC(inbij1, mask = iszij1 == MINVAL(iszij1), dim = 1) + knbi = inbi1(ii) + knbj = inbj1(ii) + IF(PRESENT(knbcnt)) knbcnt = 0 + DEALLOCATE( inbi1, inbj1, inbij1, iszi1, iszj1, iszij1 ) + RETURN + ENDIF + + ! extract only the partitions which reduce the subdomain size in comparison with smaller partitions + ALLOCATE( indexok(isz1) ) ! to store indices of the best partitions + isz0 = 0 ! number of best partitions + inbij = 1 ! start with the min value of inbij1 => 1 + iszij = jpiglo*jpjglo+1 ! default: larger than global domain + DO WHILE( inbij <= inbijmax ) ! if we did not reach the max of inbij1 + ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results + IF ( iszij1(ii) < iszij ) THEN + ii = MINLOC( iszi1+iszj1, mask = iszij1 == iszij1(ii) .AND. inbij1 == inbij, dim = 1) ! select the smaller perimeter if multiple min + isz0 = isz0 + 1 + indexok(isz0) = ii + iszij = iszij1(ii) + ENDIF + inbij = MINVAL(inbij1, mask = inbij1 > inbij) ! warning: return largest integer value if mask = .false. everywhere + END DO + DEALLOCATE( inbij1, iszij1 ) + + ! keep only the best partitions (sorted by increasing order of subdomains number and decreassing subdomain size) + ALLOCATE( inbi0(isz0), inbj0(isz0), iszi0(isz0), iszj0(isz0) ) + DO ji = 1, isz0 + ii = indexok(ji) + inbi0(ji) = inbi1(ii) + inbj0(ji) = inbj1(ii) + iszi0(ji) = iszi1(ii) + iszj0(ji) = iszj1(ii) + END DO + DEALLOCATE( indexok, inbi1, inbj1, iszi1, iszj1 ) + + IF( llist ) THEN + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' For your information:' + WRITE(numout,*) ' list of the best partitions including land supression' + WRITE(numout,*) ' -----------------------------------------------------' + WRITE(numout,*) + ENDIF + ji = isz0 ! initialization with the largest value + ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) + CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) + inbijold = COUNT(llisOce) + DEALLOCATE( llisOce ) + DO ji =isz0-1,1,-1 + ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) + CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) + inbij = COUNT(llisOce) + DEALLOCATE( llisOce ) + IF(lwp .AND. inbij < inbijold) THEN + WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & + & 'nb_cores oce: ', inbij, ', land domains excluded: ', inbi0(ji)*inbj0(ji) - inbij, & + & ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,wp) / REAL(inbi0(ji)*inbj0(ji),wp) *100., & + & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' + inbijold = inbij + ENDIF + END DO + DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' -----------------------------------------------------------' + ENDIF + CALL mppsync + CALL mppstop( ld_abort = .TRUE. ) + ENDIF + + DEALLOCATE( iszi0, iszj0 ) + inbij = inbijmax + 1 ! default: larger than possible + ii = isz0+1 ! start from the end of the list (smaller subdomains) + DO WHILE( inbij > knbij ) ! while the number of ocean subdomains exceed the number of procs + ii = ii -1 + ALLOCATE( llisOce(inbi0(ii), inbj0(ii)) ) + CALL mpp_is_ocean( llisOce ) ! must be done by all core + inbij = COUNT(llisOce) + DEALLOCATE( llisOce ) + END DO + knbi = inbi0(ii) + knbj = inbj0(ii) + IF(PRESENT(knbcnt)) knbcnt = knbi * knbj - inbij + DEALLOCATE( inbi0, inbj0 ) + ! + END SUBROUTINE bestpartition + + + SUBROUTINE mpp_init_landprop( propland ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init_landprop *** + !! + !! ** Purpose : the the proportion of land points in the surface land-sea mask + !! + !! ** Method : read iproc strips (of length Ni0glo) of the land-sea mask + !!---------------------------------------------------------------------- + REAL(wp), INTENT( out) :: propland ! proportion of land points in the global domain (between 0 and 1) + ! + INTEGER, DIMENSION(jpni*jpnj) :: kusedom_1d + INTEGER :: inboce, iarea + INTEGER :: iproc, idiv, ijsz + INTEGER :: ijstr + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce + !!---------------------------------------------------------------------- + ! do nothing if there is no land-sea mask + IF( numbot == -1 .and. numbdy == -1 ) THEN + propland = 0. + RETURN + ENDIF + + ! number of processes reading the bathymetry file + iproc = MINVAL( (/mppsize, Nj0glo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time + + ! we want to read iproc strips of the land-sea mask. -> pick up iproc processes every idiv processes starting at 1 + IF( iproc == 1 ) THEN ; idiv = mppsize + ELSE ; idiv = ( mppsize - 1 ) / ( iproc - 1 ) + ENDIF + + iarea = (narea-1)/idiv ! involed process number (starting counting at 0) + IF( MOD( narea-1, idiv ) == 0 .AND. iarea < iproc ) THEN ! beware idiv can be = to 1 + ! + ijsz = Nj0glo / iproc ! width of the stripe to read + IF( iarea < MOD(Nj0glo,iproc) ) ijsz = ijsz + 1 + ijstr = iarea*(Nj0glo/iproc) + MIN(iarea, MOD(Nj0glo,iproc)) + 1 ! starting j position of the reading + ! + ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip + CALL read_mask( 1, ijstr, Ni0glo, ijsz, lloce ) + inboce = COUNT(lloce) ! number of ocean point in the stripe + DEALLOCATE(lloce) + ! + ELSE + inboce = 0 + ENDIF + CALL mpp_sum( 'mppini', inboce ) ! total number of ocean points over the global domain + ! + propland = REAL( Ni0glo*Nj0glo - inboce, wp ) / REAL( Ni0glo*Nj0glo, wp ) + ! + END SUBROUTINE mpp_init_landprop + + + SUBROUTINE mpp_is_ocean( ldIsOce ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_is_ocean *** + !! + !! ** Purpose : Check for a mpi domain decomposition inbi x inbj which + !! subdomains, including 1 halo (even if nn_hls>1), contain + !! at least 1 ocean point. + !! We must indeed ensure that each subdomain that is a neighbour + !! of a land subdomain, has only land points on its boundary + !! (inside the inner subdomain) with the land subdomain. + !! This is needed to get the proper bondary conditions on + !! a subdomain with a closed boundary. + !! + !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask + !!---------------------------------------------------------------------- + LOGICAL, DIMENSION(:,:), INTENT( out) :: ldIsOce ! .true. if a sub domain constains 1 ocean point + ! + INTEGER :: idiv, iimax, ijmax, iarea + INTEGER :: inbi, inbj, inx, iny, inry, isty + INTEGER :: ji, jj, jn + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: inboce ! number oce oce pint in each mpi subdomain + INTEGER, ALLOCATABLE, DIMENSION(: ) :: inboce_1d + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean + !!---------------------------------------------------------------------- + ! do nothing if there is no land-sea mask + IF( numbot == -1 .AND. numbdy == -1 ) THEN + ldIsOce(:,:) = .TRUE. + RETURN + ENDIF + ! + inbi = SIZE( ldIsOce, dim = 1 ) + inbj = SIZE( ldIsOce, dim = 2 ) + ! + ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 + IF ( inbj == 1 ) THEN ; idiv = mppsize + ELSE IF ( mppsize < inbj ) THEN ; idiv = 1 + ELSE ; idiv = ( mppsize - 1 ) / ( inbj - 1 ) + ENDIF + ! + ALLOCATE( inboce(inbi,inbj), inboce_1d(inbi*inbj) ) + inboce(:,:) = 0 ! default no ocean point found + ! + DO jn = 0, (inbj-1)/mppsize ! if mppsize < inbj : more strips than mpi processes (because of potential land domains) + ! + iarea = (narea-1)/idiv + jn * mppsize + 1 ! involed process number (starting counting at 1) + IF( MOD( narea-1, idiv ) == 0 .AND. iarea <= inbj ) THEN ! beware idiv can be = to 1 + ! + ALLOCATE( iimppt(inbi,inbj), ijmppt(inbi,inbj), ijpi(inbi,inbj), ijpj(inbi,inbj) ) + CALL mpp_basesplit( Ni0glo, Nj0glo, 0, inbi, inbj, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj ) + ! + inx = Ni0glo + 2 ; iny = ijpj(1,iarea) + 2 ! strip size + 1 halo on each direction (even if nn_hls>1) + ALLOCATE( lloce(inx, iny) ) ! allocate the strip + inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction + isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? + CALL read_mask( 1, ijmppt(1,iarea) - 2 + isty, Ni0glo, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip + ! + IF( iarea == 1 ) THEN ! the first line was not read + IF( l_Jperio ) THEN ! north-south periodocity + CALL read_mask( 1, Nj0glo, Ni0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce + ELSE + lloce(2:inx-1, 1) = .FALSE. ! closed boundary + ENDIF + ENDIF + IF( iarea == inbj ) THEN ! the last line was not read + IF( l_Jperio ) THEN ! north-south periodocity + CALL read_mask( 1, 1, Ni0glo, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce + ELSEIF( c_NFtype == 'T' ) THEN ! north-pole folding T-pivot, T-point + lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) + DO ji = 3,inx-1 + lloce(ji,iny ) = lloce(inx-ji+2,iny-2) ! ok, we have at least 3 lines + END DO + DO ji = inx/2+2,inx-1 + lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) + END DO + ELSEIF( c_NFtype == 'F' ) THEN ! north-pole folding F-pivot, T-point, 1 halo + lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) + lloce(inx -1,iny-1) = lloce(2 ,iny-1) + DO ji = 2,inx-1 + lloce(ji,iny) = lloce(inx-ji+1,iny-1) + END DO + ELSE ! closed boundary + lloce(2:inx-1,iny) = .FALSE. + ENDIF + ENDIF + ! ! first and last column were not read + IF( l_Iperio ) THEN + lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity + ELSE + lloce(1,:) = .FALSE. ; lloce(inx,:) = .FALSE. ! closed boundary + ENDIF + ! + DO ji = 1, inbi + inboce(ji,iarea) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ijpi(ji,1)+1,:) ) ! lloce as 2 points more than Ni0glo + END DO + ! + DEALLOCATE(lloce) + DEALLOCATE(iimppt, ijmppt, ijpi, ijpj) + ! + ENDIF + END DO + + inboce_1d = RESHAPE(inboce, (/ inbi*inbj /)) + CALL mpp_sum( 'mppini', inboce_1d ) + inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) + ldIsOce(:,:) = inboce(:,:) /= 0 + DEALLOCATE(inboce, inboce_1d) + ! + ! Only when using XIOS: XIOS does a domain decomposition only in bands (for IO performances). + ! XIOS is crashing if one of these bands contains only land-domains which have been suppressed. + ! -> solution (before a fix of xios): force to keep at least one land-domain by band of mpi domains + DO jj = 1, inbj + IF( COUNT( ldIsOce(:,jj) ) == 0 ) ldIsOce(1,jj) = .TRUE. ! for to keep 1st MPI domain in the row of domains + END DO + ! + END SUBROUTINE mpp_is_ocean + + + SUBROUTINE read_mask( kistr, kjstr, kicnt, kjcnt, ldoce ) + !!---------------------------------------------------------------------- + !! *** ROUTINE read_mask *** + !! + !! ** Purpose : Read relevant bathymetric information in order to + !! provide a land/sea mask used for the elimination + !! of land domains, in an mpp computation. + !! + !! ** Method : read stipe of size (Ni0glo,...) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kistr, kjstr ! starting i and j position of the reading + INTEGER , INTENT(in ) :: kicnt, kjcnt ! number of points to read in i and j directions + LOGICAL, DIMENSION(kicnt,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean + ! + INTEGER :: inumsave ! local logical unit + REAL(wp), DIMENSION(kicnt,kjcnt) :: zbot, zbdy + !!---------------------------------------------------------------------- + ! + inumsave = numout ; numout = numnul ! redirect all print to /dev/null + ! + IF( numbot /= -1 ) THEN + CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) + ELSE + zbot(:,:) = 1._wp ! put a non-null value + ENDIF + ! + IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists + CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) + zbot(:,:) = zbot(:,:) * zbdy(:,:) + ENDIF + ! + ldoce(:,:) = NINT(zbot(:,:)) > 0 + numout = inumsave + ! + END SUBROUTINE read_mask + + + SUBROUTINE mpp_getnum( ldIsOce, kproc, kipos, kjpos ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_getnum *** + !! + !! ** Purpose : give a number to each MPI subdomains (starting at 0) + !! + !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed + !!---------------------------------------------------------------------- + LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldIsOce ! F if land process + INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if not existing, starting at 0) + INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) + INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) + ! + INTEGER :: ii, ij, jarea, iarea0 + INTEGER :: icont, i2add , ini, inj, inij + !!---------------------------------------------------------------------- + ! + ini = SIZE(ldIsOce, dim = 1) + inj = SIZE(ldIsOce, dim = 2) + inij = SIZE(kipos) + ! + ! specify which subdomains are oce subdomains; other are land subdomains + kproc(:,:) = -1 + icont = -1 + DO jarea = 1, ini*inj + iarea0 = jarea - 1 + ii = 1 + MOD(iarea0,ini) + ij = 1 + iarea0/ini + IF( ldIsOce(ii,ij) ) THEN + icont = icont + 1 + kproc(ii,ij) = icont + kipos(icont+1) = ii + kjpos(icont+1) = ij + ENDIF + END DO + ! if needed add some land subdomains to reach inij active subdomains + i2add = inij - COUNT( ldIsOce ) + DO jarea = 1, ini*inj + iarea0 = jarea - 1 + ii = 1 + MOD(iarea0,ini) + ij = 1 + iarea0/ini + IF( .NOT. ldIsOce(ii,ij) .AND. i2add > 0 ) THEN + icont = icont + 1 + kproc(ii,ij) = icont + kipos(icont+1) = ii + kjpos(icont+1) = ij + i2add = i2add - 1 + ENDIF + END DO + ! + END SUBROUTINE mpp_getnum + + + SUBROUTINE init_excl_landpt + !!---------------------------------------------------------------------- + !! *** ROUTINE *** + !! + !! ** Purpose : exclude exchanges which contain only land points + !! + !! ** Method : if a send or receive buffer constains only land point we + !! flag off the corresponding communication + !! Warning: this selection depend on the halo size -> loop on halo size + !! + !!---------------------------------------------------------------------- + INTEGER :: inumsave + INTEGER :: jh + INTEGER :: ipi, ipj + INTEGER :: iiwe, iiea, iist, iisz + INTEGER :: ijso, ijno, ijst, ijsz + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zmsk + LOGICAL , DIMENSION(Ni_0,Nj_0,1) :: lloce + !!---------------------------------------------------------------------- + ! + ! read the land-sea mask on the inner domain + CALL read_mask( nimpp, njmpp, Ni_0, Nj_0, lloce(:,:,1) ) + ! + ! Here we look only at communications excluding the NP folding. + ! --> we switch off lbcnfd at this stage (init_nfdcom called after init_excl_landpt)... + l_IdoNFold = .FALSE. + ! + ! WARNING, see also bestpartition: minimum subdomain size defined in bestpartition according to nn_hls. + ! If, one day, we want to use local halos largers than nn_hls, we must replace nn_hls by n_hlsmax in bestpartition + ! + DO jh = 1, MIN(nn_hls, n_hlsmax) ! different halo size + ! + ipi = Ni_0 + 2*jh ! local domain size + ipj = Nj_0 + 2*jh + ! + ALLOCATE( zmsk(ipi,ipj) ) + zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = REAL(COUNT(lloce, dim = 3), wp) ! define inner domain -> need REAL to use lbclnk + CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh) ! fill halos + ! Beware, coastal F points can be used in the code -> we may need communications for these points F points even if tmask = 0 + ! -> the mask we must use here is equal to 1 as soon as one of the 4 neighbours is oce (sum of the mask, not multiplication) + zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = zmsk(jh+1:jh+Ni_0,jh+1 :jh+Nj_0 ) + zmsk(jh+1+1:jh+Ni_0+1,jh+1 :jh+Nj_0 ) & + & + zmsk(jh+1:jh+Ni_0,jh+1+1:jh+Nj_0+1) + zmsk(jh+1+1:jh+Ni_0+1,jh+1+1:jh+Nj_0+1) + CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh) ! fill halos again! + ! + iiwe = jh ; iiea = Ni_0 ! bottom-left corner - 1 of the sent data + ijso = jh ; ijno = Nj_0 + IF( nn_comm == 1 ) THEN + iist = 0 ; iisz = ipi + ijst = jh ; ijsz = Nj_0 + ELSE + iist = jh ; iisz = Ni_0 + ijst = jh ; ijsz = Nj_0 + ENDIF +IF( nn_comm == 1 ) THEN ! SM: NOT WORKING FOR NEIGHBOURHOOD COLLECTIVE COMMUNICATIONS, I DON'T KNOW WHY... + ! do not send if we send only land points + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiSnei(jh,jpwe) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiSnei(jh,jpea) = -1 + IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpso) = -1 + IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpno) = -1 + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpsw) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpse) = -1 + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpnw) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpne) = -1 + ! + iiwe = iiwe-jh ; iiea = iiea+jh ! bottom-left corner - 1 of the received data + ijso = ijso-jh ; ijno = ijno+jh + ! do not send if we send only land points + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiRnei(jh,jpwe) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiRnei(jh,jpea) = -1 + IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpso) = -1 + IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpno) = -1 + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpsw) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpse) = -1 + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpnw) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpne) = -1 +ENDIF + ! + ! Specific (and rare) problem in corner treatment because we do 1st West-East comm, next South-North comm + IF( nn_comm == 1 ) THEN + IF( mpiSnei(jh,jpwe) > -1 ) mpiSnei(jh, (/jpsw,jpnw/) ) = -1 ! SW and NW corners already sent through West nei + IF( mpiSnei(jh,jpea) > -1 ) mpiSnei(jh, (/jpse,jpne/) ) = -1 ! SE and NE corners already sent through East nei + IF( mpiRnei(jh,jpso) > -1 ) mpiRnei(jh, (/jpsw,jpse/) ) = -1 ! SW and SE corners will be received through South nei + IF( mpiRnei(jh,jpno) > -1 ) mpiRnei(jh, (/jpnw,jpne/) ) = -1 ! NW and NE corners will be received through North nei + ENDIF + ! + DEALLOCATE( zmsk ) + ! + CALL mpp_ini_nc(jh) ! Initialize/Update communicator for neighbourhood collective communications + ! + END DO + + END SUBROUTINE init_excl_landpt + + + SUBROUTINE init_ioipsl + !!---------------------------------------------------------------------- + !! *** ROUTINE init_ioipsl *** + !! + !! ** Purpose : + !! + !! ** Method : + !! + !! History : + !! 9.0 ! 04-03 (G. Madec ) MPP-IOIPSL + !! " " ! 08-12 (A. Coward) addition in case of jpni*jpnj < jpnij + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(2) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid + !!---------------------------------------------------------------------- + + ! The domain is split only horizontally along i- or/and j- direction + ! So we need at the most only 1D arrays with 2 elements. + ! Set idompar values equivalent to the jpdom_local_noextra definition + ! used in IOM. This works even if jpnij .ne. jpni*jpnj. + iglo( :) = (/ Ni0glo, Nj0glo /) + iloc( :) = (/ Ni_0 , Nj_0 /) + iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig0(Nis0) but mig0 is not yet defined! + iabsl(:) = iabsf(:) + iloc(:) - 1 + ihals(:) = (/ 0 , 0 /) + ihale(:) = (/ 0 , 0 /) + idid( :) = (/ 1 , 2 /) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'mpp init_ioipsl : iloc = ', iloc + WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf + WRITE(numout,*) ' ihals = ', ihals + WRITE(numout,*) ' ihale = ', ihale + ENDIF + ! + CALL flio_dom_set ( jpnij, narea-1, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) + ! + END SUBROUTINE init_ioipsl + + + SUBROUTINE init_nfdcom( ldwrtlay, knum ) + !!---------------------------------------------------------------------- + !! *** ROUTINE init_nfdcom *** + !! ** Purpose : Setup for north fold exchanges with explicit + !! point-to-point messaging + !! + !! ** Method : Initialization of the northern neighbours lists. + !!---------------------------------------------------------------------- + !! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) + !! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC) + !! 3.0 ! 2021-09 complete rewrite using informations from gather north fold + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in ) :: ldwrtlay ! true if additional prints in layout.dat + INTEGER, INTENT(in ) :: knum ! layout.dat unit + ! + REAL(wp), DIMENSION(jpi,jpj,2,4) :: zinfo + INTEGER , DIMENSION(10) :: irknei ! too many elements but safe... + INTEGER :: ji, jj, jg, jn ! dummy loop indices + INTEGER :: iitmp + LOGICAL :: lnew + !!---------------------------------------------------------------------- + ! + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> North fold boundary prepared for jpni >1' + ENDIF + ! + CALL mpp_ini_northgather ! we need to init the nfd with gathering in all cases as it is used to define the no-gather case + ! + IF(ldwrtlay) THEN ! additional prints in layout.dat + WRITE(knum,*) + WRITE(knum,*) + WRITE(knum,*) 'Number of subdomains located along the north fold : ', ndim_rank_north + WRITE(knum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north + DO jn = 1, ndim_rank_north, 5 + WRITE(knum,*) nrank_north( jn:MINVAL( (/jn+4,ndim_rank_north/) ) ) + END DO + ENDIF + + nfd_nbnei = 0 ! defaul def (useless?) + IF( ln_nnogather ) THEN + ! + ! Use the "gather nfd" to know how to do the nfd: for ji point, which process send data from which of its ji-index? + ! Note that nfd is perfectly symetric: I receive data from X <=> I send data to X (-> no deadlock) + ! + zinfo(:,:,:,:) = HUGE(0._wp) ! default def to make sure we don't use the halos + DO jg = 1, 4 ! grid type: T, U, V, F + DO jj = nn_hls+1, jpj-nn_hls ! inner domain (warning do_loop_substitute not yet defined) + DO ji = nn_hls+1, jpi-nn_hls ! inner domain (warning do_loop_substitute not yet defined) + zinfo(ji,jj,1,jg) = REAL(narea, wp) ! mpi_rank + 1 (as default lbc_lnk fill is 0 + zinfo(ji,jj,2,jg) = REAL(ji, wp) ! ji of this proc + END DO + END DO + END DO + ! + ln_nnogather = .FALSE. ! force "classical" North pole folding to fill all halos -> should be no more HUGE values... + CALL lbc_lnk( 'mppini', zinfo(:,:,:,1), 'T', 1._wp ) ! Do 4 calls instead of 1 to save memory as the nogather version + CALL lbc_lnk( 'mppini', zinfo(:,:,:,2), 'U', 1._wp ) ! creates buffer arrays with jpiglo as the first dimension + CALL lbc_lnk( 'mppini', zinfo(:,:,:,3), 'V', 1._wp ) ! + CALL lbc_lnk( 'mppini', zinfo(:,:,:,4), 'F', 1._wp ) ! + ln_nnogather = .TRUE. + + IF( l_IdoNFold ) THEN ! only the procs involed in the NFD must take care of this + + ALLOCATE( nfd_rksnd(jpi,4), nfd_jisnd(jpi,4) ) ! neighbour rand and remote ji-index for each grid (T, U, V, F) + nfd_rksnd(:,:) = NINT( zinfo(:, jpj, 1, :) ) - 1 ! neighbour MPI rank + nfd_jisnd(:,:) = NINT( zinfo(:, jpj, 2, :) ) - nn_hls ! neighbour ji index (shifted as we don't send the halos) + WHERE( nfd_rksnd == -1 ) nfd_jisnd = 1 ! use ji=1 if no neighbour, see mpp_nfd_generic.h90 + + nfd_nbnei = 1 ! Number of neighbour sending data for the nfd. We have at least 1 neighbour! + irknei(1) = nfd_rksnd(1,1) ! which is the 1st one (I can be neighbour of myself, exclude land-proc are also ok) + DO jg = 1, 4 + DO ji = 1, jpi ! we must be able to fill the full line including halos + lnew = .TRUE. ! new neighbour? + DO jn = 1, nfd_nbnei + IF( irknei(jn) == nfd_rksnd(ji,jg) ) lnew = .FALSE. ! already found + END DO + IF( lnew ) THEN + jn = nfd_nbnei + 1 + nfd_nbnei = jn + irknei(jn) = nfd_rksnd(ji,jg) + ENDIF + END DO + END DO + + ALLOCATE( nfd_rknei(nfd_nbnei) ) + nfd_rknei(:) = irknei(1:nfd_nbnei) + ! re-number nfd_rksnd according to the indexes of nfd_rknei + DO jg = 1, 4 + DO ji = 1, jpi + iitmp = nfd_rksnd(ji,jg) ! must store a copy of nfd_rksnd(ji,jg) to make sure we don't change it twice + DO jn = 1, nfd_nbnei + IF( iitmp == nfd_rknei(jn) ) nfd_rksnd(ji,jg) = jn + END DO + END DO + END DO + + IF( ldwrtlay ) THEN + WRITE(knum,*) + WRITE(knum,*) 'north fold exchanges with explicit point-to-point messaging :' + WRITE(knum,*) ' number of neighbours for the NF: nfd_nbnei : ', nfd_nbnei + IF( nfd_nbnei > 0 ) WRITE(knum,*) ' neighbours MPI ranks : ', nfd_rknei + ENDIF + + ENDIF ! l_IdoNFold + ! + ENDIF ! ln_nnogather + ! + END SUBROUTINE init_nfdcom + + + SUBROUTINE init_doloop + !!---------------------------------------------------------------------- + !! *** ROUTINE init_doloop *** + !! + !! ** Purpose : set the starting/ending indices of DO-loop + !! These indices are used in do_loop_substitute.h90 + !!---------------------------------------------------------------------- + ! + Nis0 = 1+nn_hls + Njs0 = 1+nn_hls + Nie0 = jpi-nn_hls + Nje0 = jpj-nn_hls + ! + Ni_0 = Nie0 - Nis0 + 1 + Nj_0 = Nje0 - Njs0 + 1 + ! + jpkm1 = jpk-1 ! " " + ! + END SUBROUTINE init_doloop + + + SUBROUTINE init_locglo + !!---------------------------------------------------------------------- + !! *** ROUTINE init_locglo *** + !! + !! ** Purpose : initialization of global domain <--> local domain indices + !! + !! ** Method : + !! + !! ** Action : - mig , mjg : local domain indices ==> global domain, including halos, indices + !! - mig0, mjg0: local domain indices ==> global domain, excluding halos, indices + !! - mi0 , mi1 : global domain indices ==> local domain indices + !! - mj0 , mj1 (if global point not in the local domain ==> mi0>mi1 and/or mj0>mj1) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop argument + !!---------------------------------------------------------------------- + ! + ALLOCATE( mig(jpi), mjg(jpj), mig0(jpi), mjg0(jpj) ) + ALLOCATE( mi0(jpiglo), mi1(jpiglo), mj0(jpjglo), mj1(jpjglo) ) + ! + DO ji = 1, jpi ! local domain indices ==> global domain indices, including halos + mig(ji) = ji + nimpp - 1 + END DO + DO jj = 1, jpj + mjg(jj) = jj + njmpp - 1 + END DO + ! ! local domain indices ==> global domain indices, excluding halos + ! + mig0(:) = mig(:) - nn_hls + mjg0(:) = mjg(:) - nn_hls + ! ! global domain, including halos, indices ==> local domain indices + ! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the + ! ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. + DO ji = 1, jpiglo + mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) ) + mi1(ji) = MAX( 0 , MIN( ji - nimpp + 1, jpi ) ) + END DO + DO jj = 1, jpjglo + mj0(jj) = MAX( 1 , MIN( jj - njmpp + 1, jpj+1 ) ) + mj1(jj) = MAX( 0 , MIN( jj - njmpp + 1, jpj ) ) + END DO + ! + END SUBROUTINE init_locglo + + !!====================================================================== +END MODULE mppini diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/nemogcm.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/nemogcm.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a5801b2149221065da1a11282bcfa4adbed1bb2f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/nemogcm.f90 @@ -0,0 +1,559 @@ + + + + + + + + + + + + + +MODULE nemogcm + !!====================================================================== + !! *** MODULE nemogcm *** + !! Ocean system : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice) + !!====================================================================== + !! History : OPA ! 1990-10 (C. Levy, G. Madec) Original code + !! 7.0 ! 1991-11 (M. Imbard, C. Levy, G. Madec) + !! 7.1 ! 1993-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar, + !! P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1 + !! - ! 1992-06 (L.Terray) coupling implementation + !! - ! 1993-11 (M.A. Filiberti) IGLOO sea-ice + !! 8.0 ! 1996-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar, + !! P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0 + !! 8.1 ! 1997-06 (M. Imbard, G. Madec) + !! 8.2 ! 1999-11 (M. Imbard, H. Goosse) sea-ice model + !! ! 1999-12 (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols) OPEN-MP + !! ! 2000-07 (J-M Molines, M. Imbard) Open Boundary Conditions (CLIPPER) + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and modules + !! - ! 2004-06 (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces + !! - ! 2004-08 (C. Talandier) New trends organization + !! - ! 2005-06 (C. Ethe) Add the 1D configuration possibility + !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! - ! 2006-03 (L. Debreu, C. Mazauric) Agrif implementation + !! - ! 2006-04 (G. Madec, R. Benshila) Step reorganization + !! - ! 2007-07 (J. Chanut, A. Sellar) Unstructured open boundaries (BDY) + !! 3.2 ! 2009-08 (S. Masson) open/write in the listing file in mpp + !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface + !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.3.1! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation + !! - ! 2011-11 (C. Harris) decomposition changes for running with CICE + !! 3.6 ! 2012-05 (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening + !! - ! 2014-12 (G. Madec) remove KPP scheme and cross-land advection (cla) + !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! nemo_gcm : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice + !! nemo_init : initialization of the NEMO system + !! nemo_ctl : initialisation of the contol print + !! nemo_closefile: close remaining open files + !! nemo_alloc : dynamical allocation + !!---------------------------------------------------------------------- + USE step_oce ! module used in the ocean time stepping module (step.F90) + ! + USE phycst ! physical constant (par_cst routine) + USE domain ! domain initialization (dom_init & dom_cfg routines) + USE wet_dry ! Wetting and drying setting (wad_init routine) + USE usrdef_nam ! user defined configuration namelist + USE tide_mod, ONLY : tide_init ! tidal components initialization (tide_init routine) + USE bdyini , ONLY : bdy_init ! open boundary cond. setting (bdy_init routine) + USE istate ! initial state setting (istate_init routine) + USE trdini ! dyn/tra trends initialization (trd_init routine) + USE icbini ! handle bergs, initialisation + USE icbstp , ONLY : icb_end ! handle bergs, close iceberg files + USE cpl_oasis3 ! OASIS3 coupling + USE dyndmp ! Momentum damping (C1D only) + USE step_diu ! diurnal bulk SST timestepping (called from here if run offline) + USE crsini ! initialise grid coarsening utility + USE dia25h , ONLY : dia_25h_init ! 25h mean output (initialisation) + USE c1d ! 1D configuration + USE stpmlf ! NEMO time-stepping (stp_MLF routine) + ! + USE lib_mpp ! distributed memory computing + USE mppini ! shared/distributed memory setting (mpp_init routine) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE halo_mng ! halo manager + + IMPLICIT NONE + PRIVATE + + PUBLIC nemo_gcm ! called by model.F90 + PUBLIC nemo_init ! needed by AGRIF + PUBLIC nemo_alloc ! needed by TAM + + CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing + + ! need MPI_Wtime + INCLUDE 'mpif.h' + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: nemogcm.F90 15267 2021-09-17 09:04:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE nemo_gcm + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_gcm *** + !! + !! ** Purpose : NEMO solves the primitive equations on an orthogonal + !! curvilinear mesh on the sphere. + !! + !! ** Method : - model general initialization + !! - launch the time-stepping (stp routine) + !! - finalize the run by closing files and communications + !! + !! References : Madec, Delecluse, Imbard, and Levy, 1997: internal report, IPSL. + !! Madec, 2008, internal report, IPSL. + !!---------------------------------------------------------------------- + INTEGER :: istp ! time step index + REAL(wp):: zstptiming ! elapsed time for 1 time step + !!---------------------------------------------------------------------- + ! + ! !-----------------------! + CALL nemo_init !== Initialisations ==! + ! !-----------------------! + ! check that all process are still there... If some process have an error, + ! they will never enter in step and other processes will wait until the end of the cpu time! + CALL mpp_max( 'nemogcm', nstop ) + + IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA + + ! !-----------------------! + ! !== time stepping ==! + ! !-----------------------! + ! + ! !== set the model time-step ==! + ! + istp = nit000 + ! + ! + IF( .NOT.ln_diurnal_only ) THEN !== Standard time-stepping ==! + ! + DO WHILE( istp <= nitend .AND. nstop == 0 ) + ! + ncom_stp = istp + IF( ln_timing ) THEN + zstptiming = MPI_Wtime() + IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming + IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time + ENDIF + ! + CALL stp_MLF( istp ) + istp = istp + 1 + ! + IF( lwp .AND. ln_timing ) WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming + ! + END DO + ! + ELSE !== diurnal SST time-steeping only ==! + ! + DO WHILE( istp <= nitend .AND. nstop == 0 ) + CALL stp_diurnal( istp ) ! time step only the diurnal SST + istp = istp + 1 + END DO + ! + ENDIF + ! + ! + IF( ln_diaobs ) CALL dia_obs_wri + ! + IF( ln_icebergs ) CALL icb_end( nitend ) + + ! !------------------------! + ! !== finalize the run ==! + ! !------------------------! + IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA + ! + IF( nstop /= 0 .AND. lwp ) THEN ! error print + WRITE(ctmp1,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found' + IF( ngrdstop > 0 ) THEN + WRITE(ctmp9,'(i2)') ngrdstop + WRITE(ctmp2,*) ' E R R O R detected in Agrif grid '//TRIM(ctmp9) + WRITE(ctmp3,*) ' Look for "E R R O R" messages in all existing '//TRIM(ctmp9)//'_ocean_output* files' + CALL ctl_stop( ' ', ctmp1, ' ', ctmp2, ' ', ctmp3 ) + ELSE + WRITE(ctmp2,*) ' Look for "E R R O R" messages in all existing ocean_output* files' + CALL ctl_stop( ' ', ctmp1, ' ', ctmp2 ) + ENDIF + ENDIF + ! + IF( ln_timing ) CALL timing_finalize + ! + CALL nemo_closefile + ! + CALL xios_finalize ! end mpp communications with xios + IF( lk_oasis ) CALL cpl_finalize ! end coupling and mpp communications with OASIS + ! + IF(lwm) THEN + IF( nstop == 0 ) THEN ; STOP 0 + ELSE ; STOP 123 + ENDIF + ENDIF + ! + END SUBROUTINE nemo_gcm + + + SUBROUTINE nemo_init + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_init *** + !! + !! ** Purpose : initialization of the NEMO GCM + !!---------------------------------------------------------------------- + INTEGER :: ios, ilocal_comm ! local integers + !! + NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, nn_isplt, nn_jsplt , nn_ictls, & + & nn_ictle, nn_jctls , nn_jctle + NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr + !!---------------------------------------------------------------------- + ! + cxios_context = 'nemo' + ! + ! !-------------------------------------------------! + ! ! set communicator & select the local rank ! + ! ! must be done as soon as possible to get narea ! + ! !-------------------------------------------------! + ! + IF( Agrif_Root() ) THEN + IF( lk_oasis ) THEN + CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis + CALL xios_initialize( "not used" , local_comm =ilocal_comm ) ! send nemo communicator to xios + ELSE + CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios + ENDIF + ENDIF + CALL mpp_start( ilocal_comm ) + ! + narea = mpprank + 1 ! mpprank: the rank of proc (0 --> mppsize -1 ) + lwm = (narea == 1) ! control of output namelists + ! + ! !---------------------------------------------------------------! + ! ! Open output files, reference and configuration namelist files ! + ! !---------------------------------------------------------------! + ! + ! open ocean.output as soon as possible to get all output prints (including errors messages) + IF( lwm ) CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) + ! open reference and configuration namelist files + CALL load_nml( numnam_ref, 'namelist_ref', -1, lwm ) + CALL load_nml( numnam_cfg, 'namelist_cfg', -1, lwm ) + IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) + ! open /dev/null file to be able to supress output write easily + IF( Agrif_Root() ) THEN + CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) + ENDIF + ! !--------------------! + ! ! Open listing units ! -> need sn_cfctl from namctl to define lwp + ! !--------------------! + ! + READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist' ) + READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist' ) + ! + ! finalize the definition of namctl variables + IF( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax .OR. MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) & + & CALL nemo_set_cfctl( sn_cfctl, .FALSE. ) + ! + lwp = (narea == 1) .OR. sn_cfctl%l_oceout ! control of all listing output print + ! + IF(lwp) THEN ! open listing units + ! + IF( .NOT. lwm ) & ! alreay opened for narea == 1 + & CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) + ! + WRITE(numout,*) + WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC' + WRITE(numout,*) ' NEMO team' + WRITE(numout,*) ' Ocean General Circulation Model' + WRITE(numout,*) ' NEMO version 4.0 (2020) ' + WRITE(numout,*) + WRITE(numout,*) " ._ ._ ._ ._ ._ " + WRITE(numout,*) " _.-._)`\_.-._)`\_.-._)`\_.-._)`\_.-._)`\_ " + WRITE(numout,*) + WRITE(numout,*) " o _, _, " + WRITE(numout,*) " o .' ( .-' / " + WRITE(numout,*) " o _/..._'. .' / " + WRITE(numout,*) " ( o .-'` ` '-./ _.' " + WRITE(numout,*) " ) ( o) ;= <_ ( " + WRITE(numout,*) " ( '-.,\\__ __.-;`\ '. ) " + WRITE(numout,*) " ) ) \) |`\ \) '. \ ( ( " + WRITE(numout,*) " ( ( \_/ '-._\ ) ) " + WRITE(numout,*) " ) ) jgs ` ( ( " + WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " + WRITE(numout,*) + ! + WRITE(numout,cform_aaa) ! Flag AAAAAAA + ! + ! ! Control print of the working precision + WRITE(numout,*) + IF( wp == dp ) THEN ; WRITE(numout,*) "par_kind : wp = Working precision = dp = double-precision" + ELSE ; WRITE(numout,*) "par_kind : wp = Working precision = sp = single-precision" + ENDIF + WRITE(numout,*) "~~~~~~~~ ****************" + WRITE(numout,*) + ! + ENDIF + ! + IF(lwm) WRITE( numond, namctl ) + ! + ! !------------------------------------! + ! ! Set global domain size parameters ! + ! !------------------------------------! + ! + READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist' ) + READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist' ) + ! + IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file + CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) + ELSE ! user-defined namelist + CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) + ENDIF + ! + IF(lwm) WRITE( numond, namcfg ) + ! + ! !-----------------------------------------! + ! ! mpp parameters and domain decomposition ! + ! !-----------------------------------------! + CALL mpp_init + + + CALL halo_mng_init() + ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays + CALL nemo_alloc() + + ! Initialise time level indices + Nbb = 1 ; Nnn = 2 ; Naa = 3 ; Nrhs = Naa + ! !-------------------------------! + ! ! NEMO general initialization ! + ! !-------------------------------! + + CALL nemo_ctl ! Control prints of namctl and namcfg + ! + ! ! General initialization + IF( ln_timing ) CALL timing_init ! timing + IF( ln_timing ) CALL timing_start( 'nemo_init') + ! + CALL phy_cst ! Physical constants + CALL eos_init ! Equation of state + CALL wad_init ! Wetting and drying options + + CALL dom_init( Nbb, Nnn, Naa ) ! Domain + IF( ln_crs ) CALL crs_init( Nnn ) ! coarsened grid: domain initialization + IF( sn_cfctl%l_prtctl ) & + & CALL prt_ctl_init ! Print control + + CALL diurnal_sst_bulk_init ! diurnal sst + IF( ln_diurnal ) CALL diurnal_sst_coolskin_init ! cool skin + ! + IF( ln_diurnal_only ) THEN ! diurnal only: a subset of the initialisation routines + CALL istate_init( Nbb, Nnn, Naa ) ! ocean initial state (Dynamics and tracers) + CALL sbc_init( Nbb, Nnn, Naa ) ! Forcings : surface module + CALL tra_qsr_init ! penetrative solar radiation qsr + IF( ln_diaobs ) THEN ! Observation & model comparison + CALL dia_obs_init( Nnn ) ! Initialize observational data + CALL dia_obs( nit000 - 1, Nnn ) ! Observation operator for restart + ENDIF + IF( lk_asminc ) CALL asm_inc_init( Nbb, Nnn, Nrhs ) ! Assimilation increments + ! + RETURN ! end of initialization + ENDIF + ! + + CALL istate_init( Nbb, Nnn, Naa ) ! ocean initial state (Dynamics and tracers) + + ! ! external forcing + CALL tide_init ! tidal harmonics + CALL sbc_init( Nbb, Nnn, Naa ) ! surface boundary conditions (including sea-ice) + CALL bdy_init ! Open boundaries initialisation + + ! ! Ocean physics + CALL zdf_phy_init( Nnn ) ! Vertical physics + + ! ! Lateral physics + CALL ldf_tra_init ! Lateral ocean tracer physics + CALL ldf_eiv_init ! eddy induced velocity param. must be done after ldf_tra_init + CALL ldf_dyn_init ! Lateral ocean momentum physics + + ! ! Active tracers + IF( ln_traqsr ) CALL tra_qsr_init ! penetrative solar radiation qsr + CALL tra_bbc_init ! bottom heat flux + CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme + CALL tra_dmp_init ! internal tracer damping + CALL tra_adv_init ! horizontal & vertical advection + CALL tra_ldf_init ! lateral mixing + + ! ! Dynamics + IF( ln_c1d ) CALL dyn_dmp_init ! internal momentum damping + CALL dyn_adv_init ! advection (vector or flux form) + CALL dyn_vor_init ! vorticity term including Coriolis + CALL dyn_ldf_init ! lateral mixing + CALL dyn_hpg_init( Nnn ) ! horizontal gradient of Hydrostatic pressure + CALL dyn_spg_init ! surface pressure gradient + + ! ! Icebergs + CALL icb_init( rn_Dt, nit000) ! initialise icebergs instance + + ! ice shelf + CALL isf_init( Nbb, Nnn, Naa ) + IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing + + ! ! Misc. options + CALL sto_par_init ! Stochastic parametrization + IF( ln_sto_eos ) CALL sto_pts_init ! RRandom T/S fluctuations + + ! ! Diagnostics + CALL flo_init( Nnn ) ! drifting Floats + IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics + CALL dia_dct_init ! Sections tranports + CALL dia_hsb_init( Nnn ) ! heat content, salt content and volume budgets + CALL trd_init( Nnn ) ! Mixed-layer/Vorticity/Integral constraints trends + CALL dia_obs_init( Nnn ) ! Initialize observational data + CALL dia_25h_init( Nbb ) ! 25h mean outputs + CALL dia_detide_init ! Weights computation for daily detiding of model diagnostics + IF( ln_diaobs ) CALL dia_obs( nit000-1, Nnn ) ! Observation operator for restart + CALL dia_mlr_init ! Initialisation of IOM context management for multiple-linear-regression analysis + + ! ! Assimilation increments + IF( lk_asminc ) CALL asm_inc_init( Nbb, Nnn, Nrhs ) ! Initialize assimilation increments + ! + IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA + ! + IF( ln_timing ) CALL timing_stop( 'nemo_init') + ! + END SUBROUTINE nemo_init + + + SUBROUTINE nemo_ctl + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_ctl *** + !! + !! ** Purpose : control print setting + !! + !! ** Method : - print namctl and namcfg information and check some consistencies + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'nemo_ctl: Control prints' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist namctl' + WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat + WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat + WRITE(numout,*) ' sn_cfctl%l_oceout = ', sn_cfctl%l_oceout + WRITE(numout,*) ' sn_cfctl%l_layout = ', sn_cfctl%l_layout + WRITE(numout,*) ' sn_cfctl%l_prtctl = ', sn_cfctl%l_prtctl + WRITE(numout,*) ' sn_cfctl%l_prttrc = ', sn_cfctl%l_prttrc + WRITE(numout,*) ' sn_cfctl%l_oasout = ', sn_cfctl%l_oasout + WRITE(numout,*) ' sn_cfctl%procmin = ', sn_cfctl%procmin + WRITE(numout,*) ' sn_cfctl%procmax = ', sn_cfctl%procmax + WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr + WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr + WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing + WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl + ENDIF + ! + IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' Namelist namcfg' + WRITE(numout,*) ' read domain configuration file ln_read_cfg = ', ln_read_cfg + WRITE(numout,*) ' filename to be read cn_domcfg = ', TRIM(cn_domcfg) + WRITE(numout,*) ' keep closed seas in the domain (if exist) ln_closea = ', ln_closea + WRITE(numout,*) ' create a configuration definition file ln_write_cfg = ', ln_write_cfg + WRITE(numout,*) ' filename to be written cn_domcfg_out = ', TRIM(cn_domcfg_out) + WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr + ENDIF + ! + IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', & + & 'Compile with key_nosignedzero enabled:', & + & '--> add -Dkey_nosignedzero to the definition of %CPP in your arch file' ) + ! + ! + END SUBROUTINE nemo_ctl + + + SUBROUTINE nemo_closefile + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_closefile *** + !! + !! ** Purpose : Close the files + !!---------------------------------------------------------------------- + ! + IF( lk_mpp ) CALL mppsync + ! + CALL iom_close ! close all input/output files managed by iom_* + ! + IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file + IF( numrun /= -1 ) CLOSE( numrun ) ! run statistics file + IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist + IF( lwm.AND.numoni /= -1 ) CLOSE( numoni ) ! ice output namelist + IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution) + IF( numout /= 6 ) CLOSE( numout ) ! standard model output file + IF( numdct_vol /= -1 ) CLOSE( numdct_vol ) ! volume transports + IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports + IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports + ! + numout = 6 ! redefine numout in case it is used after this point... + ! + END SUBROUTINE nemo_closefile + + + SUBROUTINE nemo_alloc + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_alloc *** + !! + !! ** Purpose : Allocate all the dynamic arrays of the OCE modules + !! + !! ** Method : + !!---------------------------------------------------------------------- + USE diawri , ONLY : dia_wri_alloc + USE dom_oce , ONLY : dom_oce_alloc + USE trc_oce , ONLY : trc_oce_alloc + USE bdy_oce , ONLY : bdy_oce_alloc + ! + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + ierr = oce_alloc () ! ocean + ierr = ierr + dia_wri_alloc() + ierr = ierr + dom_oce_alloc() ! ocean domain + ierr = ierr + zdf_oce_alloc() ! ocean vertical physics + ierr = ierr + trc_oce_alloc() ! shared TRC / TRA arrays + ierr = ierr + bdy_oce_alloc() ! bdy masks (incl. initialization) + ! + CALL mpp_sum( 'nemogcm', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' ) + ! + END SUBROUTINE nemo_alloc + + + SUBROUTINE nemo_set_cfctl(sn_cfctl, setto ) + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_set_cfctl *** + !! + !! ** Purpose : Set elements of the output control structure to setto. + !! + !! ** Method : Note this routine can be used to switch on/off some + !! types of output for selected areas. + !!---------------------------------------------------------------------- + TYPE(sn_ctl), INTENT(inout) :: sn_cfctl + LOGICAL , INTENT(in ) :: setto + !!---------------------------------------------------------------------- + sn_cfctl%l_runstat = setto + sn_cfctl%l_trcstat = setto + sn_cfctl%l_oceout = setto + sn_cfctl%l_layout = setto + sn_cfctl%l_prtctl = setto + sn_cfctl%l_prttrc = setto + sn_cfctl%l_oasout = setto + END SUBROUTINE nemo_set_cfctl + + !!====================================================================== +END MODULE nemogcm diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_averg_h2d.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_averg_h2d.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9477149c15faf1f0bf433382683b0d63c2a6e929 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_averg_h2d.f90 @@ -0,0 +1,834 @@ + + + + + + + + + + + + + +MODULE obs_averg_h2d + !!====================================================================== + !! *** MODULE obs_averg_h2d *** + !! Observation diagnostics: Perform the horizontal averaging + !! from model grid to observation footprint + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_averg_h2d : Horizontal averaging to the observation footprint + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE par_oce, ONLY : & + & jpi, jpj + USE phycst, ONLY : & ! Physical constants + & rad, & + & ra, & + & rpi + USE dom_oce, ONLY : & + & e1t, e2t, & + & e1f, e2f, & + & glamt, gphit + USE in_out_manager + USE obs_const, ONLY : & + & obfillflt ! Fillvalue + USE obs_utils ! Utility functions + USE lib_mpp, ONLY : & + & ctl_warn, ctl_stop, & + & mpp_min, lk_mpp + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE obs_avg_h2d_rad, & ! Horizontal averaging using a radial footprint + & obs_avg_h2d_rec, & ! Horizontal averaging using a rectangular footprint + & obs_deg2dist, & ! Conversion of distance in degrees to distance in metres + & obs_dist2corners ! Distance from the centre of obs footprint to the corners of a grid box + + PUBLIC obs_avg_h2d, & ! Horizontal averaging to the observation footprint + & obs_avg_h2d_init, & ! Set up weights for the averaging + & obs_max_fpsize ! Works out the maximum number of grid points required for the averaging + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_averg_h2d.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + SUBROUTINE obs_avg_h2d_init( kpk, kpk2, kmaxifp, kmaxjfp, k2dint, plam, pphi, & + & pglam, pgphi, pglamf, pgphif, pmask, plamscl, pphiscl, lindegrees, & + & pweig, iminpoints ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_avg_h2d_init *** + !! + !! ** Purpose : Computes weights for horizontal averaging to the + !! observation footprint. + !! + !! ** Method : Horizontal averaging to the observation footprint using + !! model values at a defined area. + !! + !! Averaging schemes : + !! + !! Two horizontal averaging schemes are available: + !! - weighted radial footprint (k2dint = 5) + !! - weighted rectangular footprint (k2dint = 6) + !! + !! History : + !! ! 13-10 (M. Martin) + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk, & ! Parameter values for automatic arrays + & kpk2, & + & kmaxifp, & ! Max size of model points in i-direction for obs footprint + & kmaxjfp, & ! Max size of model points in j-direction for obs footprint + & k2dint ! Averaging scheme options - see header + REAL(KIND=wp), INTENT(INOUT) :: & + & plam, & ! Geographical (lat,lon) coordinates of + & pphi ! observation + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: & + & pglam, & ! Model variable lon + & pgphi ! Model variable lat + REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: & + & pglamf, & ! Model variable lon at corners of grid-boxes + & pgphif ! Model variable lat at corners of grid-boxes + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & ! Diameter (lat,lon) of obs footprint in metres + & pphiscl ! This is the full width (rather than half-width) + LOGICAL, INTENT(IN) :: & + & lindegrees ! T=> obs footprint specified in degrees, F=> in metres + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: & + & pweig ! Weights for averaging + INTEGER, INTENT(IN), OPTIONAL :: & + & iminpoints ! Reject point which is not surrounded + ! by at least iminpoints sea points + + !! * Local declarations + INTEGER :: & + & jk + INTEGER :: & + & ikmax + + + !------------------------------------------------------------------------ + ! + !------------------------------------------------------------------------ + + !------------------------------------------------------------------------ + ! Initialize number of levels + !------------------------------------------------------------------------ + IF ( kpk2 == 1 ) THEN + ikmax = 1 + ELSEIF ( kpk2 == kpk) THEN + ikmax = kpk-1 + ENDIF + + + SELECT CASE (k2dint) + CASE(5) + CALL obs_avg_h2d_rad( kpk2, ikmax, kmaxifp, kmaxjfp, plam, pphi, & + & plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig ) + CASE(6) + CALL obs_avg_h2d_rec( kpk2, ikmax, kmaxifp, kmaxjfp, plam, pphi, & + & plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig ) + END SELECT + + + END SUBROUTINE obs_avg_h2d_init + + + SUBROUTINE obs_avg_h2d_rad( kpk2, kmax, kmaxifp, kmaxjfp, plam, pphi, & + & plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_avg_h2d_rad *** + !! + !! ** Purpose : Computes weights for horizontal averaging to the + !! observation using a radial footprint. + !! + !! ** Method : Calculate whether each grid box is completely or + !! partially within the observation footprint. + !! If it is partially in the footprint then calculate + !! the ratio of the area inside the footprint to the total + !! area of the grid box. + !! + !! History : + !! ! 14-01 (M. Martin) + !!----------------------------------------------------------------------- + !! * Modules used + USE phycst, ONLY : & ! Physical constants + & ra, & + & rpi + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + + INTEGER, INTENT(IN) :: & + & kmaxifp, & ! Max size of model points in i-direction for obs footprint + & kmaxjfp ! Max size of model points in j-direction for obs footprint + + REAL(KIND=wp), INTENT(IN) :: & + & plam, & + & pphi ! Geographical (lat,lon) coordinates of + ! observation + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & ! Diameter (lat,lon) of obs footprint in metres or degrees (see below) + & pphiscl ! This is the full width (rather than half-width) + LOGICAL, INTENT(IN) :: & + & lindegrees ! T=>scales specified in degrees, F=> in metres + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: & + & pglam, & ! Model variable lon + & pgphi ! Model variable lat + REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: & + & pglamf, & ! Model variable lon at corners of grid boxes + & pgphif ! Model variable lat at corners of grid boxes + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: & + & pweig ! Weights for interpolation + + !! Local declarations + INTEGER :: ji, jj, jk + INTEGER :: jvert, jis, jjs + INTEGER :: jnumvert, jnumvertbig + INTEGER, PARAMETER :: & + & jnumsubgrid = 20 ! The number of sub grid-boxes (in x and y directions) used to approximate area of obs fp + + REAL(KIND=wp), DIMENSION(4) :: & + & zxvert, zyvert, & ! The lon/lat of the vertices(corners) of the grid box in m relative to centre of obs fp + & zdist ! Distance of each vertex to the centre of the obs footprint + REAL(KIND=wp), DIMENSION(4) :: & + & zxgrid, zygrid, & ! Distance of each vertex of grid box to the centre of the grid box in x/y directions + & zdgrid + REAL(KIND=wp) :: & + & zdx, zdy, & ! The sub grid-box sizes (in metres) + & zarea_subbox, & ! The area of each sub grid-box (in metres squared) + & zxpos, zypos, & ! The x,y position (relative to centre of obs footprint) of the centre of each sub grid-box + & zsubdist, & ! The distance of the centre of each sub grid-box from the centre of the obs footprint + & zarea_fp, & ! Total area of obs footprint within the grid box + & zareabox ! Total area of the grid box + REAL(KIND=wp) :: & + & zphiscl_m, & ! Diameter of obs footprint in metres + & zlamscl_m + !--------------------------------------------------------------------------------------------------- + !Initialise weights to zero. + pweig(:,:,:) = 0.0_wp + + !Two footprint sizes can be specified in the namelist but this routine assumes a circular footprint. + !If the two sizes are different then write out a warning. + IF ( pphiscl /= plamscl ) THEN + CALL ctl_warn( 'obs_avg_h2d_rad:', & + & 'The two components of the obs footprint size are not equal', & + & 'yet the radial option has been selected - using pphiscl here' ) + ENDIF + + DO jk = 1, kmax + DO ji = 1, kmaxifp + DO jj = 1, kmaxjfp + + IF ( pmask(ji,jj,jk) == 1.0_wp ) THEN + + IF ( lindegrees ) THEN + !If the scales are specified in degrees, work out the + !scales (metres) in x/y directions + CALL obs_deg2dist( 1, 1, pglam(ji,jj), pgphi(ji,jj), & + & plamscl, pphiscl, zlamscl_m, zphiscl_m ) + ELSE + zphiscl_m = pphiscl + ENDIF + + + ! Work out the area of the grid box using distance of corners relative to centre of grid box + CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), & + & pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), & + & pglam(ji,jj), pgphi(ji,jj), zxgrid, zygrid, zdgrid) + zareabox = ABS( zxgrid(1) - zxgrid(2) ) * ABS( zygrid(1) - zygrid(4) ) + + !1. Determine how many of the vertices of the grid box lie within the circle + + !For each vertex, calculate its location and distance relative + !to the centre of the observation footprint + + CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), & + & pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), & + & plam, pphi, zxvert, zyvert, zdist) + + jnumvert = 0 + jnumvertbig = 0 + DO jvert = 1, 4 + + !If the distance to the center to the observation footprint is less + !than the radius of the footprint (half the diameter) then this + !vertex is within the observation footprint + IF ( zdist(jvert) <= ( zphiscl_m / 2.0_wp ) ) jnumvert = jnumvert + 1 + + !For expediency, check if the vertices are "nearly" within the obs + !footprint as if none of them are close to the edge of the footprint + !then the footprint is unlikely to be intersecting the grid box + IF ( zdist(jvert) - ( 0.5_wp * zareabox ) <= ( zphiscl_m / 2.0 ) ) & + & jnumvertbig = jnumvertbig + 1 + + END DO + + !2. If none of the vertices are even close to the edge of the obs + !footprint then leave weight as zero and cycle to next grid box. + IF ( jnumvertbig == 0 ) CYCLE + + !3. If all the vertices of the box are within the observation footprint then the + ! whole grid box is within the footprint so set the weight to one and + ! move to the next grid box. + IF ( jnumvert == 4 ) THEN + pweig(ji,jj,jk) = 1.0_wp + CYCLE + ENDIF + + + !4. Use a brute force technique for calculating the area within + ! the grid box covered by the obs footprint. + ! (alternative could be to use formulae on + ! http://mathworld.wolfram.com/Circle-LineIntersection.html) + ! For now split the grid box into a specified number of smaller + ! boxes and add up the area of those whose centre is within the obs footprint. + ! Order of vertices is 1=topleft, 2=topright, 3=bottomright, 4=bottomleft + zdx = ABS( zxvert(3) - zxvert(4) ) / REAL(jnumsubgrid, wp) + zdy = ABS( zyvert(1) - zyvert(4) ) / REAL(jnumsubgrid, wp) + zarea_subbox = zdx * zdy + + zarea_fp = 0.0_wp + DO jis = 1, jnumsubgrid + zxpos = zxvert(4) + ( REAL(jis, wp) * zdx ) - (0.5_wp * zdx ) + DO jjs = 1, jnumsubgrid + !Find the distance of the centre of this sub grid box to the + !centre of the obs footprint + zypos = zyvert(4) + ( REAL(jjs, wp) * zdy ) - ( 0.5_wp * zdy ) + zsubdist = SQRT( (zxpos * zxpos) + (zypos * zypos) ) + IF ( zsubdist < ( zphiscl_m / 2.0_wp ) ) & + & zarea_fp = zarea_fp + zarea_subbox + END DO + END DO + + !6. Calculate the ratio of the area of the footprint within the box + ! to the total area of the grid box and use this fraction to weight + ! the model value in this grid box. + pweig(ji,jj,jk) = MIN( zarea_fp / zareabox, 1.0_wp ) + + END IF !pmask + END DO + END DO + END DO + + END SUBROUTINE obs_avg_h2d_rad + + + SUBROUTINE obs_avg_h2d_rec( kpk2, kmax, kmaxifp, kmaxjfp, plam, pphi, & + & plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_avg_h2d_rec *** + !! + !! ** Purpose : Computes weights for horizontal averaging to the + !! observation using a rectangular footprint which + !! is aligned with lines of lat/lon. + !! + !! ** Method : Horizontal averaging to the observation footprint using + !! model values at a defined area. + !! + !! History : + !! ! 14-01 (M. Martin) + !!----------------------------------------------------------------------- + !! * Modules used + USE phycst, ONLY : & ! Physical constants + & ra, & + & rpi + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + + INTEGER, INTENT(IN) :: & + & kmaxifp, & ! Max size of model points in i-direction for obs footprint + & kmaxjfp ! Max size of model points in j-direction for obs footprint + + REAL(KIND=wp), INTENT(IN) :: & + & plam, & + & pphi ! Geographical (lat,lon) coordinates of + ! observation + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & + & pphiscl ! Width in x/y directions of obs footprint in metres + ! This is the full width (rather than half-width) + LOGICAL, INTENT(IN) :: & + & lindegrees !T=> scales specified in degrees, F=> in metres + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: & + & pglam, & ! Model variable lat at centre of grid boxes + & pgphi ! Model variable lon at centre of grid boxes + REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: & + & pglamf, & ! Model variable lat at corners of grid boxes + & pgphif ! Model variable lon at corners of grid boxes + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: & + & pweig ! Weights for interpolation + + !! Local declarations + INTEGER :: ji, jj, jk + INTEGER :: jvert + INTEGER, DIMENSION(4) :: & + & jnumvert + REAL(KIND=wp), DIMENSION(4) :: & + & zxvert, zyvert ! The lon/lat of the vertices(corners) of the grid box in m relative to centre of obs fp + REAL(KIND=wp), DIMENSION(4) :: & + & zdist ! Distance of each vertex to the centre of the obs footprint + REAL(KIND=wp), DIMENSION(4) :: & + & zxgrid, zygrid, & ! Distance of each vertex of grid box to the centre of the grid box in x/y directions + & zdgrid + REAL(KIND=wp) :: & + & zareabox, & ! Total area of grid box + & zarea_fp, & ! Total area of obs footprint + & zarea_intersect ! Area of the intersection between the grid box and the obs footprint + REAL(KIND=wp) :: & + & zlamscl_m, & + & zphiscl_m ! Total width (lat,lon) of obs footprint in metres + REAL(KIND=wp) :: & + & z_awidth, z_aheight, & ! Width and height of model grid box + & z_cwidth, z_cheight ! Width and height of union of model grid box and obs footprint + REAL(KIND=wp) :: & + & zleft, zright, & ! Distance (metres) of corners area of intersection + & ztop, zbottom ! between grid box and obs footprint + + !----------------------------------------------------------------------- + + !Initialise weights to zero + pweig(:,:,:) = 0.0_wp + + !Loop over the grid boxes which have been identified as potentially being within the + !observation footprint + DO jk = 1, kmax + DO ji = 1, kmaxifp + DO jj = 1, kmaxjfp + + IF ( pmask(ji,jj,jk) == 1.0_wp ) THEN + + + IF ( lindegrees ) THEN + !If the scales are specified in degrees, work out the + !scales (metres) in x/y directions + CALL obs_deg2dist( 1, 1, pglam(ji,jj), pgphi(ji,jj), & + & plamscl, pphiscl, zlamscl_m, zphiscl_m ) + ELSE + zlamscl_m = plamscl + zphiscl_m = pphiscl + ENDIF + + ! Work out the area of the grid box using distance of corners relative to centre of grid box + CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), & + & pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), & + & pglam(ji,jj), pgphi(ji,jj), zxgrid, zygrid, zdgrid) + + !Calculate width and height of model grid box + z_awidth = ABS( zxgrid(1) - zxgrid(2) ) + z_aheight = ABS( zygrid(1) - zygrid(4) ) + zareabox = z_awidth * z_aheight + + ! Work out area of the observation footprint + zarea_fp = zlamscl_m * zphiscl_m + + ! For each corner of the grid box, calculate its location and distance relative + ! to the centre of the observation footprint + CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), & + & pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), & + & plam, pphi, zxvert, zyvert, zdist) + + !Work out maximum width and height of rectangle covered by corners of obs fp and grid box + z_cwidth = MAX( zxvert(1), zxvert(2), -zlamscl_m/2.0_wp, zlamscl_m/2.0_wp ) - & + & MIN( zxvert(1), zxvert(2), -zlamscl_m/2.0_wp, zlamscl_m/2.0_wp ) + + z_cheight = MAX( zyvert(1), zyvert(4), zphiscl_m/2.0_wp, -zphiscl_m/2.0_wp ) - & + & MIN( zyvert(1), zyvert(4), zphiscl_m/2.0_wp, -zphiscl_m/2.0_wp ) + + IF ( ( z_cwidth >= z_awidth + zlamscl_m ) .OR. & + & ( z_cheight >= z_aheight + zphiscl_m ) ) THEN + !The obs footprint and the model grid box don't overlap so set weight to zero + pweig(ji,jj,jk) = 0.0_wp + ELSE IF ( ( z_cwidth == zlamscl_m ) .AND. & + & ( z_cheight == zphiscl_m ) ) THEN + !The grid box is totally contained within the obs footprint so set weight to one + pweig(ji,jj,jk) = 1.0_wp + ELSE IF ( ( z_cwidth == z_awidth ) .AND. & + & ( z_cheight == z_aheight ) ) THEN + !The obs footprint is totally contained within the grid box so set weight as ratio of the two + pweig(ji,jj,jk) = zarea_fp / zareabox + ELSE + !The obs footprint and the grid box overlap so calculate the area of the intersection of the two + zleft = max(zxvert(1), -zlamscl_m/2.0_wp) + zright = min(zxvert(2), zlamscl_m/2.0_wp) + zbottom = max(zyvert(4), -zphiscl_m/2.0_wp) + ztop = min(zyvert(1), zphiscl_m/2.0_wp) + + IF ( ( zleft < zright ) .AND. ( zbottom < ztop ) ) THEN + zarea_intersect = ( zright - zleft ) * ( ztop - zbottom ) + pweig(ji,jj,jk) = zarea_intersect / zareabox + ENDIF + ENDIF + + END IF !pmask + END DO + END DO + END DO + + END SUBROUTINE obs_avg_h2d_rec + + SUBROUTINE obs_avg_h2d( kpk, kpk2, kmaxifp, kmaxjfp, pweig, pmod, pobsk ) + + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d *** + !! + !! ** Purpose : Horizontal averaging to the observation footprint. + !! + !! ** Method : Average the model points based on the weights already calculated. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 13/10. M. Martin. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk, & ! Parameter values for automatic arrays + & kpk2 + INTEGER, INTENT(IN) :: & + & kmaxifp, & ! Max size of model points in i-direction for obs footprint + & kmaxjfp ! Max size of model points in j-direction for obs footprint + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pweig ! Interpolation weights + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmod ! Model variable to interpolate + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsk ! Model profile interpolated to obs (i,j) pt + + INTEGER :: & + & jk + INTEGER :: & + & ikmax + REAL(KIND=wp) :: & + & zsum + + !------------------------------------------------------------------------ + ! Initialize number of levels + !------------------------------------------------------------------------ + IF ( kpk2 == 1 ) THEN + ikmax = 1 + ELSEIF ( kpk2 == kpk) THEN + ikmax = kpk-1 + ENDIF + + !------------------------------------------------------------------------ + ! Average model values to the observation footprint + !------------------------------------------------------------------------ + pobsk = obfillflt + + DO jk = 1, ikmax + + zsum = SUM( pweig(:,:,jk) ) + + IF ( zsum /= 0.0_wp ) THEN + pobsk(jk) = SUM ( pweig(:,:,jk) * pmod(:,:,jk), Mask=pweig(:,:,jk) > 0.0_wp ) + pobsk(jk) = pobsk(jk) / zsum + END IF + + END DO + + END SUBROUTINE obs_avg_h2d + + SUBROUTINE obs_max_fpsize( k2dint, plamscl, pphiscl, lindegrees, pmask, kmaxifp, kmaxjfp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_max_fpsize *** + !! + !! ** Purpose : Calculate maximum number of grid points which may + !! need to be used in the averaging in the global domain. + !! + !! + !! ** Method : Work out the minimum grid size and work out + !! how many of the smallest grid points would be needed + !! to cover the scale of the observation footprint. + !! This needs to be done using the max/min of the global domain + !! as the obs can be distributed from other parts of the grid. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 14/01. M. Martin. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER , INTENT(IN) :: & + & k2dint !Type of interpolation/averaging used + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & !Total width/radius in metres of the observation footprint + & pphiscl ! + LOGICAL, INTENT(IN) :: & + & lindegrees !T=> plamscl and pphiscl are specified in degrees + REAL(KIND=wp), DIMENSION(jpi,jpj), INTENT(IN) :: & + & pmask !Land/sea mask + !F=> plamscl and pphiscl are specified in metres + INTEGER, INTENT(OUT) :: & + & kmaxifp, & !Max number of grid points in i,j directions to use in averaging + & kmaxjfp !these have to be even so that the footprint is centred + + !! * Local variables + REAL(KIND=wp) :: & + & ze1min, & !Minimum global grid-size in i,j directions + & ze2min + REAL(KIND=wp) :: & + & zphiscl_m, & + & zlamscl_m + !------------------------------------------------------------------------ + + IF ( k2dint <= 4 ) THEN + !If interpolation is being used then only need to use a 2x2 footprint + kmaxifp = 2 + kmaxjfp = 2 + + ELSE + + IF ( lindegrees ) THEN + !If the scales are specified in degrees, work out the max + !distance (metres) in x/y directions + CALL obs_deg2dist( jpi, jpj, glamt, gphit, & + & plamscl, pphiscl, zlamscl_m, zphiscl_m ) + ELSE + zlamscl_m = plamscl + zphiscl_m = pphiscl + ENDIF + + ze1min = MINVAL( e1t(:,:), mask = pmask(:,:) == 1._wp ) + ze2min = MINVAL( e2t(:,:), mask = pmask(:,:) == 1._wp ) + + IF(lk_mpp) THEN + CALL mpp_min( 'obs_averg_h2d', ze1min ) + CALL mpp_min( 'obs_averg_h2d', ze2min ) + ENDIF + + kmaxifp = ceiling(zlamscl_m/ze1min) + 1 + kmaxjfp = ceiling(zphiscl_m/ze2min) + 1 + + !Ensure that these numbers are even + kmaxifp = kmaxifp + MOD(kmaxifp,2) + kmaxjfp = kmaxjfp + MOD(kmaxjfp,2) + + + ENDIF + + END SUBROUTINE obs_max_fpsize + + SUBROUTINE obs_deg2dist( ki, kj, pglam, pgphi, plamscl_deg, pphiscl_deg, & + & plamscl_max, pphiscl_max ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_deg2dist *** + !! + !! ** Purpose : Calculate the maximum distance in m of the length scale + !! in degrees. + !! + !! ** Method : At each lon/lat point, work out the distances in the + !! zonal and meridional directions. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 14/01. M. Martin. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER , INTENT(IN) :: & + & ki, kj !x/y dimensions of input lat/lon variables + REAL(KIND=wp), INTENT(IN), DIMENSION(ki,kj) :: & + & pglam, pgphi !Longitude and latitudes of grid points + REAL(KIND=wp), INTENT(IN) :: & + & plamscl_deg, & !Size in degrees of the observation footprint + & pphiscl_deg ! + REAL(KIND=wp), INTENT(OUT) :: & + & plamscl_max, & !Maximum size of obs footprint in metres + & pphiscl_max + + !! * Local declarations + INTEGER :: & + & ji, jj !Counters + REAL(KIND=wp) :: & + & zlon1, zlon2, & !Lon values surrounding centre of grid point + & zlat1, zlat2, & !Lat values surrounding centre of grid point + & zdlat, zdlon !Distance in radians in lat/lon directions + REAL(KIND=wp) :: & + & za1, za2, za, zc, zd + + plamscl_max = -1.0_wp + pphiscl_max = -1.0_wp + + DO ji = 1, ki + DO jj = 1, kj + + !Calculate distance in metres in zonal(x) direction + + zlon1 = rad * ( pglam(ji,jj) + ( 0.5_wp * plamscl_deg ) ) + zlon2 = rad * ( pglam(ji,jj) - ( 0.5_wp * plamscl_deg ) ) + zlat1 = rad * pgphi(ji,jj) + zlat2 = rad * pgphi(ji,jj) + zdlon = zlon2 - zlon1 + zdlat = zlat2 - zlat1 + + za1 = sin( zdlat/2.0_wp ) + za2 = sin( zdlon/2.0_wp ) + za = ( za1 * za1 ) + ( COS( zlat1 ) * COS( zlat2 ) * ( za2 * za2 ) ) + zc = 2.0_wp * atan2( SQRT( za ), SQRT( 1.0_wp-za ) ) + zd = ra * zc + + IF ( zd > plamscl_max ) plamscl_max = zd + + !Calculate distance in metres in meridional(y) direction + + zlon1 = rad * pglam(ji,jj) + zlon2 = rad * pglam(ji,jj) + zlat1 = rad * ( pgphi(ji,jj) + ( 0.5_wp * pphiscl_deg ) ) + zlat2 = rad * ( pgphi(ji,jj) - ( 0.5_wp * pphiscl_deg ) ) + zdlon = zlon2 - zlon1 + zdlat = zlat2 - zlat1 + + za1 = sin( zdlat/2.0_wp ) + za2 = sin( zdlon/2.0_wp ) + za = ( za1 * za1 ) + ( COS( zlat1 ) * COS( zlat2 ) * ( za2 * za2 ) ) + zc = 2.0_wp * atan2( SQRT( za ), SQRT( 1.0_wp-za ) ) + zd = ra * zc + + IF ( zd > pphiscl_max ) pphiscl_max = zd + + END DO + END DO + + END SUBROUTINE obs_deg2dist + + SUBROUTINE obs_dist2corners(pglam_bl, pglam_br, pglam_tl, pglam_tr, & + & pgphi_bl, pgphi_br, pgphi_tl, pgphi_tr, & + & plam, pphi, pxvert, pyvert, pdist) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_dist2corners *** + !! + !! ** Purpose : Calculate distance from centre of obs footprint to the corners of a grid box + !! + !! ** Method : Use great circle distance formulae. + !! Order of corners is 1=topleft, 2=topright, 3=bottomright, 4=bottomleft + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 14/01. M. Martin. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: & + & pglam_bl, pglam_br, & !lon at corners of grid box + & pglam_tl, pglam_tr + REAL(KIND=wp), INTENT(IN) :: & + & pgphi_bl, pgphi_br, & !lat at corners of grid box + & pgphi_tl, pgphi_tr + REAL(KIND=wp), INTENT(IN) :: & + & pphi, plam !lat/lon of centre of obs footprint + REAL(KIND=wp), DIMENSION(4), INTENT(OUT) :: & + & pxvert, pyvert !x/y location (in metres relative to centre of obs footprint) of corners + REAL(KIND=wp), DIMENSION(4), INTENT(OUT) :: & + & pdist !distance (in metres) of each corner relative to centre of obs footprint + + !! * Local variables + INTEGER :: & + & jvert !Counter for corners + REAL(KIND=wp) :: & + & zphi, zlam !Local values for lon/lat of corners + REAL(KIND=wp) :: & + & za1, za2, & !For great circle distance calculations + & zb1, zb2, & + & zc1, zc2 + REAL(KIND=wp) :: & + & zdist_centre_lat, & !Distances in lat/lon directions (in metres) + & zdist_centre_lon + + !!----------------------------------------------------------------------- + + ! Work out latitudinal and longitudinal distance from centre of + ! obs fp to corners of grid box + DO jvert = 1, 4 + SELECT CASE(jvert) + CASE(1) + zphi = pgphi_tl + zlam = pglam_tl + CASE(2) + zphi = pgphi_tr + zlam = pglam_tr + CASE(3) + zphi = pgphi_br + zlam = pglam_br + CASE(4) + zphi = pgphi_bl + zlam = pglam_bl + END SELECT + + IF (zlam == plam ) THEN + pxvert(jvert) = 0.0_wp + ELSE + za1 = SIN( zphi * rad ) + za2 = SIN( zphi * rad ) + zb1 = COS( zphi * rad ) * COS( zlam * rad ) + zb2 = COS( zphi * rad ) * COS( plam * rad ) + zc1 = COS( zphi * rad ) * SIN( zlam * rad ) + zc2 = COS( zphi * rad ) * SIN( plam * rad ) + pxvert(jvert) = grt_cir_dis( za1, za2, zb1, zb2, zc1, zc2 ) + pxvert(jvert) = ra * pxvert(jvert) + IF ( zlam < plam ) pxvert(jvert) = - pxvert(jvert) + ENDIF + + IF ( zphi == pphi ) THEN + pyvert(jvert) = 0.0_wp + ELSE + za1 = SIN( zphi * rad ) + za2 = SIN( pphi * rad ) + zb1 = COS( zphi * rad ) * COS( zlam * rad ) + zb2 = COS( pphi * rad ) * COS( zlam * rad ) + zc1 = COS( zphi * rad ) * SIN( zlam * rad ) + zc2 = COS( pphi * rad ) * SIN( zlam * rad ) + pyvert(jvert) = grt_cir_dis( za1, za2, zb1, zb2, zc1, zc2 ) + pyvert(jvert) = ra * pyvert(jvert) + IF ( zphi < pphi ) pyvert(jvert) = - pyvert(jvert) + ENDIF + + !Calculate the distance of each vertex relative to centre of obs footprint + pdist(jvert) = SQRT( ( pxvert(jvert) * pxvert(jvert) ) + & + & ( pyvert(jvert) * pyvert(jvert) ) ) + + END DO + + END SUBROUTINE obs_dist2corners + +END MODULE obs_averg_h2d diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_const.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_const.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4917bbb6f5e28dd45ecd0335c2f9414f8e10a635 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_const.f90 @@ -0,0 +1,35 @@ + + + + + + + + + + + + + +MODULE obs_const + !!===================================================================== + !! *** MODULE obs_const *** + !! Observation diagnostics: Constants used by many modules + !!===================================================================== + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_const.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & sp + IMPLICIT NONE + + !! * Routine/type accessibility + PUBLIC + + REAL(kind=sp), PARAMETER :: obfillflt=99999. + +END MODULE obs_const diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_conv.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_conv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..42dfe388d4e9452660ace11f3ab1391be9c394f1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_conv.f90 @@ -0,0 +1,351 @@ + + + + + + + + + + + + + +MODULE obs_conv + !!===================================================================== + !! *** MODULE obs_conv *** + !! Observation diagnostics: Various conversion functions + !!===================================================================== + !! + !! potemp : Compute potential temperature from insitu temperature, + !! salinity and pressure + !! fspott : Compute potential temperature from insitu temperature, + !! salinity and pressure + !! atg : Compute adiabatic temperature gradient deg c per decibar + !! theta : Compute potential temperature from insitu temperature, + !! salinity and pressure + !! depth : Compute depth from pressure and latitude. + !! p_to_dep : Compute depth from pressure and latitude + !! (approximate version) + !! dep_to_p : Compute pressure from depth and latitude + !! (approximate version) + !!--------------------------------------------------------------------- + !! * Modules used + USE par_kind + IMPLICIT NONE + + !! * Function accessibility + PRIVATE + PUBLIC & + & potemp, & + & fspott, & + & atg, & + & theta, & + & depth, & + & p_to_dep, & + & dep_to_p + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_conv.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_conv_functions.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION potemp( ps, pt, pp, ppr ) + !!---------------------------------------------------------------------- + !! *** FUNCTION potemp *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: potemp(35,20,2000,0) = 19.621967 + !! + !! References : T. J. Mcdougall, D. R. Jackett, D. G. Wright + !! and R. Feistel + !! Accurate and computationally efficient algoritms for + !! potential temperatures and density of seawater + !! Journal of atmospheric and oceanic technology + !! Vol 20, 2003, pp 730-741 + !! + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + + REAL(KIND=wp), INTENT(IN) :: ps + REAL(KIND=wp), INTENT(IN) :: pt + REAL(KIND=wp), INTENT(IN) :: pp + REAL(KIND=wp), INTENT(IN) :: ppr + + !! * Local declarations + REAL(KIND=wp) :: zpol + REAL(KIND=wp), PARAMETER :: a1 = 1.067610e-05 + REAL(KIND=wp), PARAMETER :: a2 = -1.434297e-06 + REAL(KIND=wp), PARAMETER :: a3 = -7.566349e-09 + REAL(KIND=wp), PARAMETER :: a4 = -8.535585e-06 + REAL(KIND=wp), PARAMETER :: a5 = 3.074672e-08 + REAL(KIND=wp), PARAMETER :: a6 = 1.918639e-08 + REAL(KIND=wp), PARAMETER :: a7 = 1.788718e-10 + + zpol = a1 + a2 * ps + a3 * ( pp + ppr ) + a4 * pt & + & + a5 * ps * pt + a6 * pt * pt + a7 * pt * ( pp + ppr ) + + potemp = pt + ( pp - ppr ) * zpol + + END FUNCTION potemp + + REAL(KIND=wp) FUNCTION fspott( pft, pfs, pfp ) + !!---------------------------------------------------------------------- + !! *** FUNCTION fspott *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : Check value: fspott(10,25,1000) = 8.4678516 + !! + !! References : A. E. Gill + !! Atmosphere-Ocean Dynamics + !! Volume 30 (International Geophysics) + !! + !! History : + !! ! 07-05 (K. Mogensen) NEMO adopting of OPAVAR code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pft ! in situ temperature in degrees Celsius + REAL(KIND=wp) :: pfs ! salinity in psu + REAL(KIND=wp) :: pfp ! pressure in bars + + fspott = & + & pft - pfp * ( ( 3.6504e-4 & + & + pft * ( 8.3198e-5 & + & + pft * ( -5.4065e-7 & + & + pft * 4.0274e-9 ) ) ) & + & + ( pfs - 35.0 ) * ( 1.7439e-5 & + & - pft * 2.9778e-7 ) & + & + pfp * ( 8.9309e-7 & + & + pft * ( -3.1628e-8 & + & + pft * 2.1987e-10 ) & + & - ( pfs - 35.0 ) * 4.1057e-9 & + & + pfp * ( -1.6056e-10 & + & + pft * 5.0484e-12 ) ) ) + + END FUNCTION fspott + + REAL(KIND=wp) FUNCTION atg( p_s, p_t, p_p ) + !!---------------------------------------------------------------------- + !! *** FUNCTION atg *** + !! + !! ** Purpose : Compute adiabatic temperature gradient deg c per decibar + !! + !! ** Method : A regression formula is used + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: atg(40,40,10000) = 3.255974e-4 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + + REAL(KIND=wp), INTENT(IN) :: p_s ! Salinity in PSU + REAL(KIND=wp), INTENT(IN) :: p_t ! Temperature in centigrades + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars. + + !! * Local declarations + + REAL(KIND=wp) :: z_ds + + z_ds = p_s - 35.0 + atg = ((( -2.1687e-16 * p_t + 1.8676e-14 ) * p_t - 4.6206e-13 ) * p_p & + & + (( 2.7759e-12 * p_t - 1.1351e-10 ) * z_ds + (( - 5.4481e-14 * p_t & + & + 8.733e-12 ) * p_t - 6.7795e-10 ) * p_t + 1.8741e-8)) * p_p & + & + ( -4.2393e-8 * p_t + 1.8932e-6 ) * z_ds & + & + (( 6.6228e-10 * p_t - 6.836e-8 ) * p_t + 8.5258e-6 ) * p_t + 3.5803e-5 + + END FUNCTION atg + + REAL(KIND=wp) FUNCTION theta( p_s, p_t0, p_p0, p_pr ) + !!---------------------------------------------------------------------- + !! *** FUNCTION theta *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: theta(40,40,10000,0) = 36.89073 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_s + REAL(KIND=wp), INTENT(IN) :: p_t0 + REAL(KIND=wp), INTENT(IN) :: p_p0 + REAL(KIND=wp), INTENT(IN) :: p_pr + + !! * Local declarations + REAL(KIND=wp) :: z_p + REAL(KIND=wp) :: z_t + REAL(KIND=wp) :: z_h + REAL(KIND=wp) :: z_xk + REAL(KIND=wp) :: z_q + + z_p = p_p0 + z_t = p_t0 + z_h = p_pr - z_p + z_xk = z_h * atg( p_s, z_t, z_p ) + Z_t = z_t + 0.5 * z_xk + z_q = z_xk + z_p = z_p + 0.5 * z_h + z_xk = z_h * atg( p_s, z_t, z_p ) + z_t = z_t + 0.29289322 * ( z_xk - z_q ) + z_q = 0.58578644 * z_xk + 0.121320344 * z_q + z_xk = z_h * atg( p_s, z_t, z_p ) + z_t = z_t + 1.707106781 * ( z_xk - z_q ) + z_q = 3.414213562 * z_xk - 4.121320244 * z_q + z_p = z_p + 0.5 * z_h + z_xk = z_h * atg( p_s, z_t, z_p ) + theta = z_t + ( z_xk - 2.0 * z_q ) / 6.0 + + END FUNCTION theta + + REAL(KIND=wp) FUNCTION depth( p_p, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION depth *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: depth(10000,30) = 9712.653 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_gr + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_gr = 9.780318 * ( 1.0 + ( 5.2788e-3 + 2.36e-5 * z_x ) * z_x ) + 1.092e-6 * p_p + depth = ((( -1.82e-15 * p_p + 2.279e-10 ) * p_p - 2.2512e-5 ) * p_p + 9.72659 ) * p_p + depth = depth / z_gr + + END FUNCTION depth + + REAL(KIND=wp) FUNCTION p_to_dep( p_p, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION p_to_dep *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : A regression formula is used. This version is less + !! accurate the "depth" but invertible. + !! + !! ** Action : + !! + !! References : P.M Saunders + !! Pratical conversion of pressure to depth + !! Journal of physical oceanography Vol 11, 1981, pp 573-574 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_c1 + REAL(KIND=wp) :: z_c2 + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_c1 = ( 5.92 + 5.25 * z_x ) * 1e-3 + z_c2 = 2.21e-6 + p_to_dep = (1 - z_c1) * p_p - z_c2 * p_p * p_p + + END FUNCTION p_to_dep + + REAL(KIND=wp) FUNCTION dep_to_p( p_dep, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION dep_to_p *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : The expression used in p_to_dep is inverted. + !! + !! ** Action : + !! + !! References : P.M Saunders + !! Pratical conversion of pressure to depth + !! Journal of physical oceanography Vol 11, 1981, pp 573-574 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_dep ! Depth in meters + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_c1 + REAL(KIND=wp) :: z_c2 + REAL(KIND=wp) :: z_d + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_c1 = ( 5.92 + 5.25 * z_x ) * 1e-3 + z_c2 = 2.21e-6 + z_d = ( z_c1 - 1 ) * ( z_c1 - 1 ) - 4 * z_c2 * p_dep + dep_to_p = (( 1 - z_c1 ) - SQRT( z_d )) / ( 2 * z_c2 ) + + END FUNCTION dep_to_p + +END MODULE obs_conv diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_fbm.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_fbm.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9f63bee0a046dedef9cb961c0bbaed34b7611756 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_fbm.f90 @@ -0,0 +1,2011 @@ + + + + + + + + + + + + + +MODULE obs_fbm + !!====================================================================== + !! *** MODULE obs_fbm *** + !! Observation operators : I/O + tools for feedback files + !!====================================================================== + !! History : + !! ! 08-11 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! init_obfbdata : Initialize sizes in obfbdata structure + !! alloc_obfbdata : Allocate data in an obfbdata structure + !! dealloc_obfbdata : Dellocate data in an obfbdata structure + !! copy_obfbdata : Copy an obfbdata structure + !! subsamp_obfbdata : Sumsample an obfbdata structure + !! merge_obfbdata : Merge multiple obfbdata structures into an one. + !! write_obfbdata : Write an obfbdata structure into a netCDF file. + !! read_obfbdata : Read an obfbdata structure from a netCDF file. + !!---------------------------------------------------------------------- + USE netcdf + USE obs_utils ! Various utilities for observation operators + + IMPLICIT NONE + PUBLIC + + ! Type kinds for feedback data. + + INTEGER, PARAMETER :: fbsp = SELECTED_REAL_KIND( 6, 37) !: single precision + INTEGER, PARAMETER :: fbdp = SELECTED_REAL_KIND(12,307) !: double precision + + ! Parameters for string lengths. + + INTEGER, PARAMETER :: ilenwmo = 8 !: Length of station identifier + INTEGER, PARAMETER :: ilentyp = 4 !: Length of type + INTEGER, PARAMETER :: ilenname = 8 !: Length of variable names + INTEGER, PARAMETER :: ilengrid = 1 !: Grid (e.g. 'T') length + INTEGER, PARAMETER :: ilenjuld = 14 !: Lenght of reference julian date + INTEGER, PARAMETER :: idefnqcf = 2 !: Default number of words in QC + ! flags + INTEGER, PARAMETER :: ilenlong = 128 !: Length of long name + INTEGER, PARAMETER :: ilenunit = 32 !: Length of units + + ! Missinge data indicators + + INTEGER, PARAMETER :: fbimdi = -99999 !: Integers + REAL(fbsp), PARAMETER :: fbrmdi = 99999 !: Reals + + ! Main data structure for observation feedback data. + + TYPE obfbdata + LOGICAL :: lalloc !: Allocation status for data + LOGICAL :: lgrid !: Include grid search info + INTEGER :: nvar !: Number of variables + INTEGER :: nobs !: Number of observations + INTEGER :: nlev !: Number of levels + INTEGER :: nadd !: Number of additional entries + INTEGER :: next !: Number of extra variables + INTEGER :: nqcf !: Number of words per qc flag + CHARACTER(LEN=ilenwmo), DIMENSION(:), POINTER :: & + & cdwmo !: Identifier + CHARACTER(LEN=ilentyp), DIMENSION(:), POINTER :: & + & cdtyp !: Instrument type + CHARACTER(LEN=ilenjuld) :: & + & cdjuldref !: Julian date reference + INTEGER, DIMENSION(:), POINTER :: & + & kindex !: Index of observations in the original file + INTEGER, DIMENSION(:), POINTER :: & + & ioqc, & !: Observation QC + & ipqc, & !: Position QC + & itqc !: Time QC + INTEGER, DIMENSION(:,:), POINTER :: & + & ioqcf, & !: Observation QC flags + & ipqcf, & !: Position QC flags + & itqcf !: Time QC flags + INTEGER, DIMENSION(:,:), POINTER :: & + & idqc !: Depth QC + INTEGER, DIMENSION(:,:,:), POINTER :: & + & idqcf !: Depth QC flags + REAL(KIND=fbdp), DIMENSION(:), POINTER :: & + & plam, & !: Longitude + & pphi, & !: Latitude + & ptim !: Time + REAL(KIND=fbsp), DIMENSION(:,:), POINTER :: & + & pdep !: Depth + CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & + & cname !: Name of variable + REAL(fbsp), DIMENSION(:,:,:), POINTER :: & + & pob !: Observation + CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: & + & coblong !: Observation long name (for output) + CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: & + & cobunit !: Observation units (for output) + INTEGER, DIMENSION(:,:), POINTER :: & + & ivqc !: Variable QC + INTEGER, DIMENSION(:,:,:), POINTER :: & + & ivqcf !: Variable QC flags + INTEGER, DIMENSION(:,:,:), POINTER :: & + & ivlqc !: Variable level QC + INTEGER, DIMENSION(:,:,:,:), POINTER :: & + & ivlqcf !: Variable level QC flags + INTEGER, DIMENSION(:,:), POINTER :: & + & iproc, & !: Processor of obs (no I/O for this variable). + & iobsi, & !: Global i index + & iobsj !: Global j index + INTEGER, DIMENSION(:,:,:), POINTER :: & + & iobsk !: k index + CHARACTER(LEN=ilengrid), DIMENSION(:), POINTER :: & + & cgrid !: Grid for this variable + CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & + & caddname !: Additional entries names + CHARACTER(LEN=ilenlong), DIMENSION(:,:), POINTER :: & + & caddlong !: Additional entries long name (for output) + CHARACTER(LEN=ilenunit), DIMENSION(:,:), POINTER :: & + & caddunit !: Additional entries units (for output) + REAL(fbsp), DIMENSION(:,:,:,:) , POINTER :: & + & padd !: Additional entries + CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & + & cextname !: Extra variables names + CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: & + & cextlong !: Extra variables long name (for output) + CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: & + & cextunit !: Extra variables units (for output) + REAL(fbsp), DIMENSION(:,:,:) , POINTER :: & + & pext !: Extra variables + END TYPE obfbdata + + PRIVATE putvaratt_obfbdata + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_fbm.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE init_obfbdata( fbdata ) + !!---------------------------------------------------------------------- + !! *** ROUTINE init_obfbdata *** + !! + !! ** Purpose : Initialize sizes in obfbdata structure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure + + fbdata%nvar = 0 + fbdata%nobs = 0 + fbdata%nlev = 0 + fbdata%nadd = 0 + fbdata%next = 0 + fbdata%nqcf = idefnqcf + fbdata%lalloc = .FALSE. + fbdata%lgrid = .FALSE. + + END SUBROUTINE init_obfbdata + + SUBROUTINE alloc_obfbdata( fbdata, kvar, kobs, klev, kadd, kext, lgrid, & + & kqcf) + !!---------------------------------------------------------------------- + !! *** ROUTINE alloc_obfbdata *** + !! + !! ** Purpose : Allocate data in an obfbdata structure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure to be allocated + INTEGER, INTENT(IN) :: kvar ! Number of variables + INTEGER, INTENT(IN) :: kobs ! Number of observations + INTEGER, INTENT(IN) :: klev ! Number of levels + INTEGER, INTENT(IN) :: kadd ! Number of additional entries + INTEGER, INTENT(IN) :: kext ! Number of extra variables + LOGICAL, INTENT(IN) :: lgrid ! Include grid search information + INTEGER, OPTIONAL :: kqcf ! Number of words for QC flags + !! * Local variables + INTEGER :: ji + INTEGER :: jv + + ! Check allocation status and deallocate previous allocated structures + + IF ( fbdata%lalloc ) THEN + CALL dealloc_obfbdata( fbdata ) + ENDIF + + ! Set dimensions + + fbdata%lalloc = .TRUE. + fbdata%nvar = kvar + fbdata%nobs = kobs + fbdata%nlev = MAX( klev, 1 ) + fbdata%nadd = kadd + fbdata%next = kext + IF ( PRESENT(kqcf) ) THEN + fbdata%nqcf = kqcf + ELSE + fbdata%nqcf = idefnqcf + ENDIF + + ! Set data not depending on number of observations + + fbdata%cdjuldref = REPEAT( 'X', ilenjuld ) + + ! Allocate and initialize standard data + + ALLOCATE( & + & fbdata%cname(fbdata%nvar), & + & fbdata%coblong(fbdata%nvar), & + & fbdata%cobunit(fbdata%nvar) & + & ) + DO ji = 1, fbdata%nvar + WRITE(fbdata%cname(ji),'(A,I2.2)')'V_',ji + fbdata%coblong(ji) = REPEAT( ' ', ilenlong ) + fbdata%cobunit(ji) = REPEAT( ' ', ilenunit ) + END DO + + ! Optionally also store grid search information + + IF ( lgrid ) THEN + ALLOCATE ( & + & fbdata%cgrid(fbdata%nvar) & + & ) + fbdata%cgrid(:) = REPEAT( 'X', ilengrid ) + fbdata%lgrid = .TRUE. + ENDIF + + ! Allocate and initialize additional entries if present + + IF ( fbdata%nadd > 0 ) THEN + ALLOCATE( & + & fbdata%caddname(fbdata%nadd), & + & fbdata%caddlong(fbdata%nadd, fbdata%nvar), & + & fbdata%caddunit(fbdata%nadd, fbdata%nvar) & + & ) + DO ji = 1, fbdata%nadd + WRITE(fbdata%caddname(ji),'(A,I2.2)')'A',ji + END DO + DO jv = 1, fbdata%nvar + DO ji = 1, fbdata%nadd + fbdata%caddlong(ji,jv) = REPEAT( ' ', ilenlong ) + fbdata%caddunit(ji,jv) = REPEAT( ' ', ilenunit ) + END DO + END DO + ENDIF + + ! Allocate and initialize additional variables if present + + IF ( fbdata%next > 0 ) THEN + ALLOCATE( & + & fbdata%cextname(fbdata%next), & + & fbdata%cextlong(fbdata%next), & + & fbdata%cextunit(fbdata%next) & + & ) + DO ji = 1, fbdata%next + WRITE(fbdata%cextname(ji),'(A,I2.2)')'E_',ji + fbdata%cextlong(ji) = REPEAT( ' ', ilenlong ) + fbdata%cextunit(ji) = REPEAT( ' ', ilenunit ) + END DO + ENDIF + + ! Data depending on number of observations is only allocated if nobs>0 + + IF ( fbdata%nobs > 0 ) THEN + + ALLOCATE( & + & fbdata%cdwmo(fbdata%nobs), & + & fbdata%cdtyp(fbdata%nobs), & + & fbdata%ioqc(fbdata%nobs), & + & fbdata%ioqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%ipqc(fbdata%nobs), & + & fbdata%ipqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%itqc(fbdata%nobs), & + & fbdata%itqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%idqc(fbdata%nlev,fbdata%nobs), & + & fbdata%idqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs), & + & fbdata%plam(fbdata%nobs), & + & fbdata%pphi(fbdata%nobs), & + & fbdata%pdep(fbdata%nlev,fbdata%nobs), & + & fbdata%ptim(fbdata%nobs), & + & fbdata%kindex(fbdata%nobs), & + & fbdata%ivqc(fbdata%nobs,fbdata%nvar), & + & fbdata%ivqcf(fbdata%nqcf,fbdata%nobs,fbdata%nvar), & + & fbdata%ivlqc(fbdata%nlev,fbdata%nobs,fbdata%nvar), & + & fbdata%ivlqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs,fbdata%nvar), & + & fbdata%pob(fbdata%nlev,fbdata%nobs,fbdata%nvar) & + & ) + fbdata%kindex(:) = fbimdi + fbdata%cdwmo(:) = REPEAT( 'X', ilenwmo ) + fbdata%cdtyp(:) = REPEAT( 'X', ilentyp ) + fbdata%ioqc(:) = fbimdi + fbdata%ioqcf(:,:) = fbimdi + fbdata%ipqc(:) = fbimdi + fbdata%ipqcf(:,:) = fbimdi + fbdata%itqc(:) = fbimdi + fbdata%itqcf(:,:) = fbimdi + fbdata%idqc(:,:) = fbimdi + fbdata%idqcf(:,:,:) = fbimdi + fbdata%plam(:) = fbrmdi + fbdata%pphi(:) = fbrmdi + fbdata%pdep(:,:) = fbrmdi + fbdata%ptim(:) = fbrmdi + fbdata%ivqc(:,:) = fbimdi + fbdata%ivqcf(:,:,:) = fbimdi + fbdata%ivlqc(:,:,:) = fbimdi + fbdata%ivlqcf(:,:,:,:) = fbimdi + fbdata%pob(:,:,:) = fbrmdi + + ! Optionally also store grid search information + + IF ( lgrid ) THEN + ALLOCATE ( & + & fbdata%iproc(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsi(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsj(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsk(fbdata%nlev,fbdata%nobs,fbdata%nvar) & + & ) + fbdata%iproc(:,:) = fbimdi + fbdata%iobsi(:,:) = fbimdi + fbdata%iobsj(:,:) = fbimdi + fbdata%iobsk(:,:,:) = fbimdi + fbdata%lgrid = .TRUE. + ENDIF + + ! Allocate and initialize additional entries if present + + IF ( fbdata%nadd > 0 ) THEN + ALLOCATE( & + & fbdata%padd(fbdata%nlev,fbdata%nobs,fbdata%nadd,fbdata%nvar) & + & ) + fbdata%padd(:,:,:,:) = fbrmdi + ENDIF + + ! Allocate and initialize additional variables if present + + IF ( fbdata%next > 0 ) THEN + ALLOCATE( & + & fbdata%pext(fbdata%nlev,fbdata%nobs,fbdata%next) & + & ) + fbdata%pext(:,:,:) = fbrmdi + ENDIF + + ENDIF + + END SUBROUTINE alloc_obfbdata + + SUBROUTINE dealloc_obfbdata( fbdata ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dealloc_obfbdata *** + !! + !! ** Purpose : Deallocate data in an obfbdata strucure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure + + ! Deallocate data + + DEALLOCATE( & + & fbdata%cname, & + & fbdata%coblong,& + & fbdata%cobunit & + & ) + + ! Deallocate optional grid search information + + IF ( fbdata%lgrid ) THEN + DEALLOCATE ( & + & fbdata%cgrid & + & ) + ENDIF + + ! Deallocate additional entries + + IF ( fbdata%nadd > 0 ) THEN + DEALLOCATE( & + & fbdata%caddname, & + & fbdata%caddlong, & + & fbdata%caddunit & + & ) + ENDIF + + ! Deallocate extra variables + + IF ( fbdata%next > 0 ) THEN + DEALLOCATE( & + & fbdata%cextname, & + & fbdata%cextlong, & + & fbdata%cextunit & + & ) + ENDIF + + ! Deallocate arrays depending on number of obs (if nobs>0 only). + + IF ( fbdata%nobs > 0 ) THEN + + DEALLOCATE( & + & fbdata%cdwmo, & + & fbdata%cdtyp, & + & fbdata%ioqc, & + & fbdata%ioqcf, & + & fbdata%ipqc, & + & fbdata%ipqcf, & + & fbdata%itqc, & + & fbdata%itqcf, & + & fbdata%idqc, & + & fbdata%idqcf, & + & fbdata%plam, & + & fbdata%pphi, & + & fbdata%pdep, & + & fbdata%ptim, & + & fbdata%kindex, & + & fbdata%ivqc, & + & fbdata%ivqcf, & + & fbdata%ivlqc, & + & fbdata%ivlqcf, & + & fbdata%pob & + & ) + + + ! Deallocate optional grid search information + + IF ( fbdata%lgrid ) THEN + DEALLOCATE ( & + & fbdata%iproc, & + & fbdata%iobsi, & + & fbdata%iobsj, & + & fbdata%iobsk & + & ) + ENDIF + + ! Deallocate additional entries + + IF ( fbdata%nadd > 0 ) THEN + DEALLOCATE( & + & fbdata%padd & + & ) + ENDIF + + ! Deallocate extra variables + + IF ( fbdata%next > 0 ) THEN + DEALLOCATE( & + & fbdata%pext & + & ) + ENDIF + + ENDIF + + ! Reset arrays sizes + + fbdata%lalloc = .FALSE. + fbdata%lgrid = .FALSE. + fbdata%nvar = 0 + fbdata%nobs = 0 + fbdata%nlev = 0 + fbdata%nadd = 0 + fbdata%next = 0 + + END SUBROUTINE dealloc_obfbdata + + SUBROUTINE copy_obfbdata( fbdata1, fbdata2, kadd, kext, lgrid, kqcf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE copy_obfbdata *** + !! + !! ** Purpose : Copy an obfbdata structure + !! + !! ** Method : Copy all data from fbdata1 to fbdata2 + !! If fbdata2 is allocated it needs to be compliant + !! with fbdata1. + !! Additional entries can be added by setting nadd + !! Additional extra fields can be added by setting next + !! Grid information can be included with lgrid=.true. + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata1 ! Input obsfbdata structure + TYPE(obfbdata) :: fbdata2 ! Output obsfbdata structure + INTEGER, INTENT(IN), OPTIONAL :: kadd ! Number of additional entries + INTEGER, INTENT(IN), OPTIONAL :: kext ! Number of extra variables + INTEGER, INTENT(IN), OPTIONAL :: kqcf ! Number of words per qc flags + LOGICAL, OPTIONAL :: lgrid ! Grid info on output file + + !! * Local variables + INTEGER :: nadd + INTEGER :: next + INTEGER :: nqcf + LOGICAL :: llgrid + INTEGER :: jv + INTEGER :: je + INTEGER :: ji + INTEGER :: jk + INTEGER :: jq + + ! Check allocation status of fbdata1 + + IF ( .NOT. fbdata1%lalloc ) THEN + CALL fatal_error( 'copy_obfbdata: input data not allocated', & + & 511 ) + ENDIF + + ! If nadd,next not specified use the ones from fbdata1 + ! Otherwise check that they have large than the original ones + + IF ( PRESENT(kadd) ) THEN + nadd = kadd + IF ( nadd < fbdata1%nadd ) THEN + CALL warning ( 'copy_obfbdata: ' // & + & 'nadd smaller than input nadd', 521 ) + ENDIF + ELSE + nadd = fbdata1%nadd + ENDIF + IF ( PRESENT(kext) ) THEN + next = kext + IF ( next < fbdata1%next ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'next smaller than input next', 530 ) + ENDIF + ELSE + next = fbdata1%next + ENDIF + IF ( PRESENT(lgrid) ) THEN + llgrid = lgrid + IF ( fbdata1%lgrid .AND. (.NOT. llgrid) ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'switching off grid info not possible', & + & 540 ) + ENDIF + ELSE + llgrid = fbdata1%lgrid + ENDIF + IF ( PRESENT(kqcf) ) THEN + nqcf = kqcf + IF ( nqcf < fbdata1%nqcf ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'nqcf smaller than input nqcf', 549 ) + ENDIF + ELSE + nqcf = fbdata1%nqcf + ENDIF + + ! Check allocation status of fbdata2 and + ! a) check that it conforms in size if already allocated + ! b) allocate it if not already allocated + + IF ( fbdata2%lalloc ) THEN + IF ( fbdata1%nvar > fbdata2%nvar ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output kvar smaller than input kvar', 562 ) + ENDIF + IF ( fbdata1%nobs > fbdata2%nobs ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output kobs smaller than input kobs', 566 ) + ENDIF + IF ( fbdata1%nlev > fbdata2%nlev ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output klev smaller than input klev', 570 ) + ENDIF + IF ( fbdata1%nadd > fbdata2%nadd ) THEN + CALL warning ( 'copy_obfbdata: ' // & + & 'output nadd smaller than input nadd', 574 ) + ENDIF + IF ( fbdata1%next > fbdata2%next ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output next smaller than input next', 578 ) + ENDIF + IF ( fbdata1%lgrid .NEQV. fbdata2%lgrid ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'lgrid inconsistent', 582 ) + ENDIF + IF ( fbdata1%next > fbdata2%next ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output next smaller than input next', 586 ) + ENDIF + IF ( fbdata1%nqcf > fbdata2%nqcf ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output smaller than input kext', 590 ) + ENDIF + ELSE + CALL alloc_obfbdata( fbdata2, fbdata1%nvar, fbdata1%nobs, & + & fbdata1%nlev, nadd, next, llgrid, kqcf = nqcf ) + ENDIF + + ! Copy the header data + + fbdata2%cdjuldref = fbdata1%cdjuldref + + DO ji = 1, fbdata1%nobs + fbdata2%cdwmo(ji) = fbdata1%cdwmo(ji) + fbdata2%cdtyp(ji) = fbdata1%cdtyp(ji) + fbdata2%ioqc(ji) = fbdata1%ioqc(ji) + fbdata2%ipqc(ji) = fbdata1%ipqc(ji) + fbdata2%itqc(ji) = fbdata1%itqc(ji) + fbdata2%plam(ji) = fbdata1%plam(ji) + fbdata2%pphi(ji) = fbdata1%pphi(ji) + fbdata2%ptim(ji) = fbdata1%ptim(ji) + fbdata2%kindex(ji) = fbdata1%kindex(ji) + DO jq = 1, fbdata1%nqcf + fbdata2%ioqcf(jq,ji) = fbdata1%ioqcf(jq,ji) + fbdata2%ipqcf(jq,ji) = fbdata1%ipqcf(jq,ji) + fbdata2%itqcf(jq,ji) = fbdata1%itqcf(jq,ji) + END DO + DO jk = 1, fbdata1%nlev + fbdata2%idqc(jk,ji) = fbdata1%idqc(jk,ji) + fbdata2%pdep(jk,ji) = fbdata1%pdep(jk,ji) + DO jq = 1, fbdata1%nqcf + fbdata2%idqcf(jq,jk,ji) = fbdata1%idqcf(jq,jk,ji) + END DO + END DO + END DO + + ! Copy the variable data + + DO jv = 1, fbdata1%nvar + fbdata2%cname(jv) = fbdata1%cname(jv) + fbdata2%coblong(jv) = fbdata1%coblong(jv) + fbdata2%cobunit(jv) = fbdata1%cobunit(jv) + DO ji = 1, fbdata1%nobs + fbdata2%ivqc(ji,jv) = fbdata1%ivqc(ji,jv) + DO jq = 1, fbdata1%nqcf + fbdata2%ivqcf(jq,ji,jv) = fbdata1%ivqcf(jq,ji,jv) + END DO + DO jk = 1, fbdata1%nlev + fbdata2%ivlqc(jk,ji,jv) = fbdata1%ivlqc(jk,ji,jv) + fbdata2%pob(jk,ji,jv) = fbdata1%pob(jk,ji,jv) + DO jq = 1, fbdata1%nqcf + fbdata2%ivlqcf(jq,jk,ji,jv) = fbdata1%ivlqcf(jq,jk,ji,jv) + END DO + END DO + END DO + END DO + + ! Copy grid information + + IF ( fbdata1%lgrid ) THEN + DO jv = 1, fbdata1%nvar + fbdata2%cgrid(jv) = fbdata1%cgrid(jv) + DO ji = 1, fbdata1%nobs + fbdata2%iproc(ji,jv) = fbdata1%iproc(ji,jv) + fbdata2%iobsi(ji,jv) = fbdata1%iobsi(ji,jv) + fbdata2%iobsj(ji,jv) = fbdata1%iobsj(ji,jv) + DO jk = 1, fbdata1%nlev + fbdata2%iobsk(jk,ji,jv) = fbdata1%iobsk(jk,ji,jv) + END DO + END DO + END DO + ENDIF + + ! Copy additional information + + DO je = 1, MIN( fbdata1%nadd, fbdata2%nadd ) + fbdata2%caddname(je) = fbdata1%caddname(je) + END DO + DO jv = 1, fbdata1%nvar + DO je = 1, MIN( fbdata1%nadd, fbdata2%nadd ) + fbdata2%caddlong(je,jv) = fbdata1%caddlong(je,jv) + fbdata2%caddunit(je,jv) = fbdata1%caddunit(je,jv) + DO ji = 1, fbdata1%nobs + DO jk = 1, fbdata1%nlev + fbdata2%padd(jk,ji,je,jv) = fbdata1%padd(jk,ji,je,jv) + END DO + END DO + END DO + END DO + + ! Copy extra information + + DO je = 1, fbdata1%next + fbdata2%cextname(je) = fbdata1%cextname(je) + fbdata2%cextlong(je) = fbdata1%cextlong(je) + fbdata2%cextunit(je) = fbdata1%cextunit(je) + END DO + DO je = 1, fbdata1%next + DO ji = 1, fbdata1%nobs + DO jk = 1, fbdata1%nlev + fbdata2%pext(jk,ji,je) = fbdata1%pext(jk,ji,je) + END DO + END DO + END DO + + END SUBROUTINE copy_obfbdata + + SUBROUTINE subsamp_obfbdata( fbdata1, fbdata2, llvalid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE susbamp_obfbdata *** + !! + !! ** Purpose : Subsample an obfbdata structure based on the + !! logical mask. + !! + !! ** Method : Copy all data from fbdata1 to fbdata2 if + !! llvalid(obs)==true + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata1 ! Input obsfbdata structure + TYPE(obfbdata) :: fbdata2 ! Output obsfbdata structure + LOGICAL, DIMENSION(fbdata1%nobs) :: llvalid ! Grid info on output file + !! * Local variables + INTEGER :: nobs + INTEGER :: jv + INTEGER :: je + INTEGER :: ji + INTEGER :: jk + INTEGER :: jq + INTEGER :: ij + + ! Check allocation status of fbdata1 + + IF ( .NOT. fbdata1%lalloc ) THEN + CALL fatal_error( 'copy_obfbdata: input data not allocated', & + & 726 ) + ENDIF + + ! Check allocation status of fbdata2 and abort if already allocated + + IF ( fbdata2%lalloc ) THEN + CALL fatal_error( 'subsample_obfbdata: ' // & + & 'fbdata2 already allocated', 733 ) + ENDIF + + ! Count number of subsampled observations + + nobs = COUNT(llvalid) + + ! Allocate new data structure + + CALL alloc_obfbdata( fbdata2, fbdata1%nvar, nobs, & + & fbdata1%nlev, fbdata1%nadd, fbdata1%next, & + & fbdata1%lgrid, kqcf = fbdata1%nqcf ) + + ! Copy the header data + + fbdata2%cdjuldref = fbdata1%cdjuldref + + ij = 0 + DO ji = 1, fbdata1%nobs + IF ( llvalid(ji) ) THEN + ij = ij +1 + fbdata2%cdwmo(ij) = fbdata1%cdwmo(ji) + fbdata2%cdtyp(ij) = fbdata1%cdtyp(ji) + fbdata2%ioqc(ij) = fbdata1%ioqc(ji) + fbdata2%ipqc(ij) = fbdata1%ipqc(ji) + fbdata2%itqc(ij) = fbdata1%itqc(ji) + fbdata2%plam(ij) = fbdata1%plam(ji) + fbdata2%pphi(ij) = fbdata1%pphi(ji) + fbdata2%ptim(ij) = fbdata1%ptim(ji) + fbdata2%kindex(ij) = fbdata1%kindex(ji) + DO jq = 1, fbdata1%nqcf + fbdata2%ioqcf(jq,ij) = fbdata1%ioqcf(jq,ji) + fbdata2%ipqcf(jq,ij) = fbdata1%ipqcf(jq,ji) + fbdata2%itqcf(jq,ij) = fbdata1%itqcf(jq,ji) + END DO + DO jk = 1, fbdata1%nlev + fbdata2%idqc(jk,ij) = fbdata1%idqc(jk,ji) + fbdata2%pdep(jk,ij) = fbdata1%pdep(jk,ji) + DO jq = 1, fbdata1%nqcf + fbdata2%idqcf(jq,jk,ij) = fbdata1%idqcf(jq,jk,ji) + END DO + END DO + ENDIF + END DO + + ! Copy the variable data + + DO jv = 1, fbdata1%nvar + fbdata2%cname(jv) = fbdata1%cname(jv) + fbdata2%coblong(jv) = fbdata1%coblong(jv) + fbdata2%cobunit(jv) = fbdata1%cobunit(jv) + ij = 0 + DO ji = 1, fbdata1%nobs + IF ( llvalid(ji) ) THEN + ij = ij + 1 + fbdata2%ivqc(ij,jv) = fbdata1%ivqc(ji,jv) + DO jq = 1, fbdata1%nqcf + fbdata2%ivqcf(jq,ij,jv) = fbdata1%ivqcf(jq,ji,jv) + END DO + DO jk = 1, fbdata1%nlev + fbdata2%ivlqc(jk,ij,jv) = fbdata1%ivlqc(jk,ji,jv) + fbdata2%pob(jk,ij,jv) = fbdata1%pob(jk,ji,jv) + DO jq = 1, fbdata1%nqcf + fbdata2%ivlqcf(jq,jk,ij,jv) = fbdata1%ivlqcf(jq,jk,ji,jv) + END DO + END DO + ENDIF + END DO + END DO + + ! Copy grid information + + IF ( fbdata1%lgrid ) THEN + DO jv = 1, fbdata1%nvar + fbdata2%cgrid(jv) = fbdata1%cgrid(jv) + ij = 0 + DO ji = 1, fbdata1%nobs + IF ( llvalid(ji) ) THEN + ij = ij + 1 + fbdata2%iproc(ij,jv) = fbdata1%iproc(ji,jv) + fbdata2%iobsi(ij,jv) = fbdata1%iobsi(ji,jv) + fbdata2%iobsj(ij,jv) = fbdata1%iobsj(ji,jv) + DO jk = 1, fbdata1%nlev + fbdata2%iobsk(jk,ij,jv) = fbdata1%iobsk(jk,ji,jv) + END DO + ENDIF + END DO + END DO + ENDIF + + ! Copy additional information + + DO je = 1, fbdata1%nadd + fbdata2%caddname(je) = fbdata1%caddname(je) + END DO + DO jv = 1, fbdata1%nvar + DO je = 1, fbdata1%nadd + fbdata2%caddlong(je,jv) = fbdata1%caddlong(je,jv) + fbdata2%caddunit(je,jv) = fbdata1%caddunit(je,jv) + ij = 0 + DO ji = 1, fbdata1%nobs + IF ( llvalid(ji) ) THEN + ij = ij + 1 + DO jk = 1, fbdata1%nlev + fbdata2%padd(jk,ij,je,jv) = fbdata1%padd(jk,ji,je,jv) + END DO + ENDIF + END DO + END DO + END DO + + ! Copy extra information + + DO je = 1, fbdata1%next + fbdata2%cextname(je) = fbdata1%cextname(je) + fbdata2%cextlong(je) = fbdata1%cextlong(je) + fbdata2%cextunit(je) = fbdata1%cextunit(je) + END DO + DO je = 1, fbdata1%next + ij = 0 + DO ji = 1, fbdata1%nobs + IF ( llvalid(ji) ) THEN + ij = ij + 1 + DO jk = 1, fbdata1%nlev + fbdata2%pext(jk,ij,je) = fbdata1%pext(jk,ji,je) + END DO + ENDIF + END DO + END DO + + END SUBROUTINE subsamp_obfbdata + + SUBROUTINE merge_obfbdata( nsets, fbdatain, fbdataout, iset, inum, iind ) + !!---------------------------------------------------------------------- + !! *** ROUTINE merge_obfbdata *** + !! + !! ** Purpose : Merge multiple obfbdata structures into an one. + !! + !! ** Method : The order of elements is based on the indices in + !! iind. + !! All input data are assumed to be consistent. This + !! is assumed to be checked before calling this routine. + !! Likewise output data is assume to be consistent as + !! well without error checking. + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN):: nsets ! Number of input data sets + TYPE(obfbdata), DIMENSION(nsets) :: fbdatain ! Input obsfbdata structure + TYPE(obfbdata) :: fbdataout ! Output obsfbdata structure + INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: & + & iset ! Set number for a given obs. + INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: & + & inum ! Number within set for an obs + INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: & + & iind ! Indices for copying. + !! * Local variables + + INTEGER :: js + INTEGER :: jo + INTEGER :: jv + INTEGER :: je + INTEGER :: ji + INTEGER :: jk + INTEGER :: jq + + ! Check allocation status of fbdatain + + DO js = 1, nsets + IF ( .NOT. fbdatain(js)%lalloc ) THEN + CALL fatal_error( 'merge_obfbdata: input data not allocated', & + & 906 ) + ENDIF + END DO + + ! Check allocation status of fbdataout + + IF ( .NOT.fbdataout%lalloc ) THEN + CALL fatal_error( 'merge_obfbdata: output data not allocated', & + & 914 ) + ENDIF + + ! Merge various names + + DO jv = 1, fbdatain(1)%nvar + fbdataout%cname(jv) = fbdatain(1)%cname(jv) + fbdataout%coblong(jv) = fbdatain(1)%coblong(jv) + fbdataout%cobunit(jv) = fbdatain(1)%cobunit(jv) + IF ( fbdatain(1)%lgrid ) THEN + fbdataout%cgrid(jv) = fbdatain(1)%cgrid(jv) + ENDIF + END DO + DO jv = 1, fbdatain(1)%nadd + fbdataout%caddname(jv) = fbdatain(1)%caddname(jv) + END DO + DO jv = 1, fbdatain(1)%nvar + DO je = 1, fbdatain(1)%nadd + fbdataout%caddlong(je,jv) = fbdatain(1)%caddlong(je,jv) + fbdataout%caddunit(je,jv) = fbdatain(1)%caddunit(je,jv) + END DO + END DO + DO jv = 1, fbdatain(1)%next + fbdataout%cextname(jv) = fbdatain(1)%cextname(jv) + fbdataout%cextlong(jv) = fbdatain(1)%cextlong(jv) + fbdataout%cextunit(jv) = fbdatain(1)%cextunit(jv) + END DO + fbdataout%cdjuldref = fbdatain(1)%cdjuldref + + ! Loop over total views + + DO jo = 1, fbdataout%nobs + + js = iset(iind(jo)) + ji = inum(iind(jo)) + + ! Merge the header data + + fbdataout%cdwmo(jo) = fbdatain(js)%cdwmo(ji) + fbdataout%cdtyp(jo) = fbdatain(js)%cdtyp(ji) + fbdataout%ioqc(jo) = fbdatain(js)%ioqc(ji) + fbdataout%ipqc(jo) = fbdatain(js)%ipqc(ji) + fbdataout%itqc(jo) = fbdatain(js)%itqc(ji) + fbdataout%plam(jo) = fbdatain(js)%plam(ji) + fbdataout%pphi(jo) = fbdatain(js)%pphi(ji) + fbdataout%ptim(jo) = fbdatain(js)%ptim(ji) + fbdataout%kindex(jo) = fbdatain(js)%kindex(ji) + DO jq = 1, fbdatain(js)%nqcf + fbdataout%ioqcf(jq,jo) = fbdatain(js)%ioqcf(jq,ji) + fbdataout%ipqcf(jq,jo) = fbdatain(js)%ipqcf(jq,ji) + fbdataout%itqcf(jq,jo) = fbdatain(js)%itqcf(jq,ji) + END DO + DO jk = 1, fbdatain(js)%nlev + fbdataout%pdep(jk,jo) = fbdatain(js)%pdep(jk,ji) + fbdataout%idqc(jk,jo) = fbdatain(js)%idqc(jk,ji) + DO jq = 1, fbdatain(js)%nqcf + fbdataout%idqcf(jq,jk,jo) = fbdatain(js)%idqcf(jq,jk,ji) + END DO + END DO + + ! Merge the variable data + + DO jv = 1, fbdatain(js)%nvar + fbdataout%ivqc(jo,jv) = fbdatain(js)%ivqc(ji,jv) + DO jq = 1, fbdatain(js)%nqcf + fbdataout%ivqcf(jq,jo,jv) = fbdatain(js)%ivqcf(jq,ji,jv) + END DO + DO jk = 1, fbdatain(js)%nlev + fbdataout%ivlqc(jk,jo,jv) = fbdatain(js)%ivlqc(jk,ji,jv) + fbdataout%pob(jk,jo,jv) = fbdatain(js)%pob(jk,ji,jv) + DO jq = 1, fbdatain(js)%nqcf + fbdataout%ivlqcf(jq,jk,jo,jv) = & + & fbdatain(js)%ivlqcf(jq,jk,ji,jv) + END DO + END DO + END DO + + ! Merge grid information + + IF ( fbdatain(js)%lgrid ) THEN + DO jv = 1, fbdatain(js)%nvar + fbdataout%cgrid(jv) = fbdatain(js)%cgrid(jv) + fbdataout%iproc(jo,jv) = fbdatain(js)%iproc(ji,jv) + fbdataout%iobsi(jo,jv) = fbdatain(js)%iobsi(ji,jv) + fbdataout%iobsj(jo,jv) = fbdatain(js)%iobsj(ji,jv) + DO jk = 1, fbdatain(js)%nlev + fbdataout%iobsk(jk,jo,jv) = fbdatain(js)%iobsk(jk,ji,jv) + END DO + END DO + ENDIF + + ! Merge additional information + + DO jv = 1, fbdatain(js)%nvar + DO je = 1, fbdatain(js)%nadd + DO jk = 1, fbdatain(js)%nlev + fbdataout%padd(jk,jo,je,jv) = fbdatain(js)%padd(jk,ji,je,jv) + END DO + END DO + END DO + + ! Merge extra information + + DO je = 1, fbdatain(js)%next + DO jk = 1, fbdatain(js)%nlev + fbdataout%pext(jk,jo,je) = fbdatain(js)%pext(jk,ji,je) + END DO + END DO + + END DO + + END SUBROUTINE merge_obfbdata + + SUBROUTINE write_obfbdata( cdfilename, fbdata ) + !!---------------------------------------------------------------------- + !! *** ROUTINE write_obfbdata *** + !! + !! ** Purpose : Write an obfbdata structure into a netCDF file. + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(len=*) :: cdfilename ! Output filename + TYPE(obfbdata) :: fbdata ! obsfbdata structure + !! * Local variables + CHARACTER(LEN=14), PARAMETER :: cpname = 'write_obfbdata' + ! Dimension ids + INTEGER :: idfile + INTEGER :: idodim + INTEGER :: idldim + INTEGER :: idvdim + INTEGER :: idadim + INTEGER :: idedim + INTEGER :: idsndim + INTEGER :: idsgdim + INTEGER :: idswdim + INTEGER :: idstdim + INTEGER :: idjddim + INTEGER :: idqcdim + INTEGER :: idvard + INTEGER :: idaddd + INTEGER :: idextd + INTEGER :: idcdwmo + INTEGER :: idcdtyp + INTEGER :: idplam + INTEGER :: idpphi + INTEGER :: idpdep + INTEGER :: idptim + INTEGER :: idptimr + INTEGER :: idioqc + INTEGER :: idioqcf + INTEGER :: idipqc + INTEGER :: idipqcf + INTEGER :: iditqc + INTEGER :: iditqcf + INTEGER :: ididqc + INTEGER :: ididqcf + INTEGER :: idkindex + INTEGER, DIMENSION(fbdata%nvar) :: & + & idpob, & + & idivqc, & + & idivqcf, & + & idivlqc, & + & idivlqcf, & + & idiobsi, & + & idiobsj, & + & idiobsk, & + & idcgrid + INTEGER, DIMENSION(fbdata%nadd,fbdata%nvar) :: idpadd + INTEGER, DIMENSION(fbdata%next) :: idpext + INTEGER, DIMENSION(1) :: incdim1 + INTEGER, DIMENSION(2) :: incdim2 + INTEGER, DIMENSION(3) :: incdim3 + INTEGER, DIMENSION(4) :: incdim4 + + INTEGER :: jv + INTEGER :: je + INTEGER :: ioldfill + CHARACTER(len=nf90_max_name) :: & + & cdtmp + CHARACTER(len=16), PARAMETER :: & + & cdqcconv = 'q where q =[0,9]' + CHARACTER(len=24), PARAMETER :: & + & cdqcfconv = 'NEMOVAR flag conventions' + CHARACTER(len=ilenlong) :: & + & cdltmp + + ! Open output filename + + CALL chkerr( nf90_create( TRIM( cdfilename ), nf90_clobber, idfile ), & + & cpname, 1107 ) + CALL chkerr( nf90_set_fill( idfile, nf90_nofill, ioldfill ), & + & cpname, 1109 ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'title', & + & 'NEMO observation operator output' ), & + & cpname, 1112 ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'Convention', & + & 'NEMO unified observation operator output' ),& + & cpname,1115 ) + + ! Create the dimensions + + CALL chkerr( nf90_def_dim( idfile, 'N_OBS' , fbdata%nobs, idodim ), & + & cpname,1120 ) + CALL chkerr( nf90_def_dim( idfile, 'N_LEVELS', fbdata%nlev, idldim ), & + & cpname,1122 ) + CALL chkerr( nf90_def_dim( idfile, 'N_VARS', fbdata%nvar, idvdim ), & + & cpname,1124 ) + CALL chkerr( nf90_def_dim( idfile, 'N_QCF', fbdata%nqcf, idqcdim ),& + & cpname,1126 ) + IF ( fbdata%nadd > 0 ) THEN + CALL chkerr( nf90_def_dim( idfile, 'N_ENTRIES', fbdata%nadd, idadim ), & + & cpname,1129 ) + ENDIF + IF ( fbdata%next > 0 ) THEN + CALL chkerr( nf90_def_dim( idfile, 'N_EXTRA', fbdata%next, idedim ), & + & cpname,1133 ) + ENDIF + CALL chkerr( nf90_def_dim( idfile, 'STRINGNAM', ilenname, idsndim ), & + & cpname,1136 ) + IF (fbdata%lgrid) THEN + CALL chkerr( nf90_def_dim( idfile, 'STRINGGRID', ilengrid, idsgdim ),& + & cpname,1139 ) + ENDIF + CALL chkerr( nf90_def_dim( idfile, 'STRINGWMO', ilenwmo, idswdim ), & + & cpname,1142 ) + CALL chkerr( nf90_def_dim( idfile, 'STRINGTYP', ilentyp, idstdim ), & + & cpname,1144 ) + CALL chkerr( nf90_def_dim( idfile, 'STRINGJULD', ilenjuld, idjddim ), & + & cpname,1146 ) + + ! Define netCDF variables for header information + + incdim2(1) = idsndim + incdim2(2) = idvdim + + CALL chkerr( nf90_def_var( idfile, 'VARIABLES', nf90_char, incdim2, & + & idvard ), cpname, 1154 ) + CALL putvaratt_obfbdata( idfile, idvard, & + & 'List of variables in feedback files' ) + + IF ( fbdata%nadd > 0 ) THEN + incdim2(1) = idsndim + incdim2(2) = idadim + CALL chkerr( nf90_def_var( idfile, 'ENTRIES', nf90_char, incdim2, & + & idaddd ), cpname, 1162 ) + CALL putvaratt_obfbdata( idfile, idaddd, & + & 'List of additional entries for each '// & + & 'variable in feedback files' ) + ENDIF + + IF ( fbdata%next > 0 ) THEN + incdim2(1) = idsndim + incdim2(2) = idedim + CALL chkerr( nf90_def_var( idfile, 'EXTRA', nf90_char, incdim2, & + & idextd ), cpname, 1172 ) + CALL putvaratt_obfbdata( idfile, idextd, & + & 'List of extra variables' ) + ENDIF + + incdim2(1) = idswdim + incdim2(2) = idodim + CALL chkerr( nf90_def_var( idfile, 'STATION_IDENTIFIER', & + & nf90_char, incdim2, & + & idcdwmo ), cpname, 1181 ) + CALL putvaratt_obfbdata( idfile, idcdwmo, & + & 'Station identifier' ) + incdim2(1) = idstdim + incdim2(2) = idodim + CALL chkerr( nf90_def_var( idfile, 'STATION_TYPE', & + & nf90_char, incdim2, & + & idcdtyp ), cpname, 1188 ) + CALL putvaratt_obfbdata( idfile, idcdtyp, & + & 'Code instrument type' ) + incdim1(1) = idodim + CALL chkerr( nf90_def_var( idfile, 'LONGITUDE', & + & nf90_double, incdim1, & + & idplam ), cpname, 1194 ) + CALL putvaratt_obfbdata( idfile, idplam, & + & 'Longitude', cdunits = 'degrees_east', & + & rfillvalue = fbrmdi ) + CALL chkerr( nf90_def_var( idfile, 'LATITUDE', & + & nf90_double, incdim1, & + & idpphi ), cpname, 1200 ) + CALL putvaratt_obfbdata( idfile, idpphi, & + & 'Latitude', cdunits = 'degrees_north', & + & rfillvalue = fbrmdi ) + incdim2(1) = idldim + incdim2(2) = idodim + CALL chkerr( nf90_def_var( idfile, 'DEPTH', & + & nf90_double, incdim2, & + & idpdep ), cpname, 1208 ) + CALL putvaratt_obfbdata( idfile, idpdep, & + & 'Depth', cdunits = 'metre', & + & rfillvalue = fbrmdi ) + incdim3(1) = idqcdim + incdim3(2) = idldim + incdim3(3) = idodim + CALL chkerr( nf90_def_var( idfile, 'DEPTH_QC', & + & nf90_int, incdim2, & + & ididqc ), cpname, 1217 ) + CALL putvaratt_obfbdata( idfile, ididqc, & + & 'Quality on depth', & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'DEPTH_QC_FLAGS', & + & nf90_int, incdim3, & + & ididqcf ), cpname, 1224 ) + CALL putvaratt_obfbdata( idfile, ididqcf, & + & 'Quality flags on depth', & + & conventions = cdqcfconv ) + CALL chkerr( nf90_def_var( idfile, 'JULD', & + & nf90_double, incdim1, & + & idptim ), cpname, 1230 ) + CALL putvaratt_obfbdata( idfile, idptim, & + & 'Julian day', & + & cdunits = 'days since JULD_REFERENCE', & + & conventions = 'relative julian days with '// & + & 'decimal part (as parts of day)', & + & rfillvalue = fbrmdi ) + incdim1(1) = idjddim + CALL chkerr( nf90_def_var( idfile, 'JULD_REFERENCE', & + & nf90_char, incdim1, & + & idptimr ), cpname, 1240 ) + CALL putvaratt_obfbdata( idfile, idptimr, & + & 'Date of reference for julian days ', & + & conventions = 'YYYYMMDDHHMMSS' ) + incdim1(1) = idodim + CALL chkerr( nf90_def_var( idfile, 'OBSERVATION_QC', & + & nf90_int, incdim1, & + & idioqc ), cpname, 1247 ) + CALL putvaratt_obfbdata( idfile, idioqc, & + & 'Quality on observation', & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + incdim2(1) = idqcdim + incdim2(2) = idodim + CALL chkerr( nf90_def_var( idfile, 'OBSERVATION_QC_FLAGS', & + & nf90_int, incdim2, & + & idioqcf ), cpname, 1256 ) + CALL putvaratt_obfbdata( idfile, idioqcf, & + & 'Quality flags on observation', & + & conventions = cdqcfconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'POSITION_QC', & + & nf90_int, incdim1, & + & idipqc ), cpname, 1263 ) + CALL putvaratt_obfbdata( idfile, idipqc, & + & 'Quality on position (latitude and longitude)', & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'POSITION_QC_FLAGS', & + & nf90_int, incdim2, & + & idipqcf ), cpname, 1270 ) + CALL putvaratt_obfbdata( idfile, idipqcf, & + & 'Quality flags on position', & + & conventions = cdqcfconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'JULD_QC', & + & nf90_int, incdim1, & + & iditqc ), cpname, 1277 ) + CALL putvaratt_obfbdata( idfile, iditqc, & + & 'Quality on date and time', & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'JULD_QC_FLAGS', & + & nf90_int, incdim2, & + & iditqcf ), cpname, 1284 ) + CALL putvaratt_obfbdata( idfile, iditqcf, & + & 'Quality flags on date and time', & + & conventions = cdqcfconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'ORIGINAL_FILE_INDEX', & + & nf90_int, incdim1, & + & idkindex ), cpname, 1291 ) + CALL putvaratt_obfbdata( idfile, idkindex, & + & 'Index in original data file', & + & ifillvalue = fbimdi ) + + ! Define netCDF variables for individual variables + + DO jv = 1, fbdata%nvar + + incdim1(1) = idodim + incdim2(1) = idldim + incdim2(2) = idodim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, & + & incdim2, idpob(jv) ), & + & cpname, 1306 ) + CALL putvaratt_obfbdata( idfile, idpob(jv), & + & fbdata%coblong(jv), & + & cdunits = fbdata%cobunit(jv), & + & rfillvalue = fbrmdi ) + + IF ( fbdata%nadd > 0 ) THEN + DO je = 1, fbdata%nadd + WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',& + & TRIM(fbdata%caddname(je)) + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, & + & incdim2, idpadd(je,jv) ), & + & cpname, 1318 ) + CALL putvaratt_obfbdata( idfile, idpadd(je,jv), & + & fbdata%caddlong(je,jv), & + & cdunits = fbdata%caddunit(je,jv), & + & rfillvalue = fbrmdi ) + END DO + ENDIF + + cdltmp = fbdata%coblong(jv) + IF (( cdltmp(1:1) >= 'A' ).AND.( cdltmp(1:1) <= 'Z' )) & + & cdltmp(1:1) = ACHAR(IACHAR(cdltmp(1:1)) + 32) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim1, idivqc(jv) ), & + & cpname, 1332 ) + CALL putvaratt_obfbdata( idfile, idivqc(jv), & + & 'Quality on '//cdltmp, & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + incdim2(1) = idqcdim + incdim2(2) = idodim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim2, idivqcf(jv) ), & + & cpname, 1342 ) + CALL putvaratt_obfbdata( idfile, idivqcf(jv), & + & 'Quality flags on '//cdltmp, & + & conventions = cdqcfconv, & + & ifillvalue = 0 ) + incdim2(1) = idldim + incdim2(2) = idodim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim2, idivlqc(jv) ), & + & cpname, 1352 ) + CALL putvaratt_obfbdata( idfile, idivlqc(jv), & + & 'Quality for each level on '//cdltmp, & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + incdim3(1) = idqcdim + incdim3(2) = idldim + incdim3(3) = idodim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim3, idivlqcf(jv) ), & + & cpname, 1363 ) + CALL putvaratt_obfbdata( idfile, idivlqcf(jv), & + & 'Quality flags for each level on '//& + & cdltmp, & + & conventions = cdqcfconv, & + & ifillvalue = 0 ) + + IF (fbdata%lgrid) THEN + incdim2(1) = idldim + incdim2(2) = idodim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim1, idiobsi(jv) ), & + & cpname, 1376 ) + CALL putvaratt_obfbdata( idfile, idiobsi(jv), & + & 'ORCA grid search I coordinate') + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim1, idiobsj(jv) ), & + & cpname, 1382 ) + CALL putvaratt_obfbdata( idfile, idiobsj(jv), & + & 'ORCA grid search J coordinate') + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim2, idiobsk(jv) ), & + & cpname, 1388 ) + CALL putvaratt_obfbdata( idfile, idiobsk(jv), & + & 'ORCA grid search K coordinate') + incdim1(1) = idsgdim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_char, incdim1, & + & idcgrid(jv) ), cpname, 1394 ) + CALL putvaratt_obfbdata( idfile, idcgrid(jv), & + & 'ORCA grid search grid (T,U,V)') + ENDIF + + END DO + + IF ( fbdata%next > 0 ) THEN + DO je = 1, fbdata%next + incdim2(1) = idldim + incdim2(2) = idodim + WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je)) + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, & + & incdim2, idpext(je) ), & + & cpname, 1408 ) + CALL putvaratt_obfbdata( idfile, idpext(je), & + & fbdata%cextlong(je), & + & cdunits = fbdata%cextunit(je), & + & rfillvalue = fbrmdi ) + END DO + ENDIF + + ! Stop definitions + + CALL chkerr( nf90_enddef( idfile ), cpname, 1418 ) + + ! Write the variables + + CALL chkerr( nf90_put_var( idfile, idvard, fbdata%cname ), & + & cpname, 1423 ) + + IF ( fbdata%nadd > 0 ) THEN + CALL chkerr( nf90_put_var( idfile, idaddd, fbdata%caddname ), & + & cpname, 1427 ) + ENDIF + + IF ( fbdata%next > 0 ) THEN + CALL chkerr( nf90_put_var( idfile, idextd, fbdata%cextname ), & + & cpname, 1432 ) + ENDIF + + CALL chkerr( nf90_put_var( idfile, idptimr, fbdata%cdjuldref ), & + & cpname, 1436 ) + + ! Only write the data if observation is available + + IF ( fbdata%nobs > 0 ) THEN + + CALL chkerr( nf90_put_var( idfile, idcdwmo, fbdata%cdwmo ), & + & cpname, 1443 ) + CALL chkerr( nf90_put_var( idfile, idcdtyp, fbdata%cdtyp ), & + & cpname, 1445 ) + CALL chkerr( nf90_put_var( idfile, idplam, fbdata%plam ), & + & cpname, 1447 ) + CALL chkerr( nf90_put_var( idfile, idpphi, fbdata%pphi ), & + & cpname, 1449 ) + CALL chkerr( nf90_put_var( idfile, idpdep, fbdata%pdep ), & + & cpname, 1451 ) + CALL chkerr( nf90_put_var( idfile, idptim, fbdata%ptim ), & + & cpname, 1453 ) + CALL chkerr( nf90_put_var( idfile, idioqc, fbdata%ioqc ), & + & cpname, 1455 ) + CALL chkerr( nf90_put_var( idfile, idioqcf, fbdata%ioqcf ), & + & cpname, 1457 ) + CALL chkerr( nf90_put_var( idfile, idipqc, fbdata%ipqc ), & + & cpname, 1459 ) + CALL chkerr( nf90_put_var( idfile, idipqcf, fbdata%ipqcf ), & + & cpname, 1461 ) + CALL chkerr( nf90_put_var( idfile, iditqc, fbdata%itqc ), & + & cpname, 1463 ) + CALL chkerr( nf90_put_var( idfile, iditqcf, fbdata%itqcf ), & + & cpname, 1465 ) + CALL chkerr( nf90_put_var( idfile, ididqc, fbdata%idqc ), & + & cpname, 1467 ) + CALL chkerr( nf90_put_var( idfile, ididqcf, fbdata%idqcf ), & + & cpname, 1469 ) + CALL chkerr( nf90_put_var( idfile, idkindex, fbdata%kindex ), & + & cpname, 1471 ) + + DO jv = 1, fbdata%nvar + CALL chkerr( nf90_put_var( idfile, idpob(jv), fbdata%pob(:,:,jv) ), & + & cpname, 1475 ) + IF ( fbdata%nadd > 0 ) THEN + DO je = 1, fbdata%nadd + CALL chkerr( nf90_put_var( idfile, idpadd(je,jv), & + & fbdata%padd(:,:,je,jv) ), & + & cpname, 1480 ) + END DO + ENDIF + CALL chkerr( nf90_put_var( idfile, idivqc(jv), & + & fbdata%ivqc(:,jv) ),& + & cpname, 1485 ) + CALL chkerr( nf90_put_var( idfile, idivqcf(jv), & + & fbdata%ivqcf(:,:,jv) ),& + & cpname, 1488 ) + CALL chkerr( nf90_put_var( idfile, idivlqc(jv), & + & fbdata%ivlqc(:,:,jv) ),& + & cpname, 1491 ) + CALL chkerr( nf90_put_var( idfile, idivlqcf(jv), & + & fbdata%ivlqcf(:,:,:,jv) ),& + & cpname, 1494 ) + IF (fbdata%lgrid) THEN + CALL chkerr( nf90_put_var( idfile, idiobsi(jv), & + & fbdata%iobsi(:,jv) ),& + & cpname, 1498 ) + CALL chkerr( nf90_put_var( idfile, idiobsj(jv), & + & fbdata%iobsj(:,jv) ),& + & cpname, 1501 ) + CALL chkerr( nf90_put_var( idfile, idiobsk(jv), & + & fbdata%iobsk(:,:,jv) ),& + & cpname, 1504 ) + CALL chkerr( nf90_put_var( idfile, idcgrid(jv), & + & fbdata%cgrid(jv) ), & + & cpname, 1507 ) + ENDIF + END DO + + IF ( fbdata%next > 0 ) THEN + DO je = 1, fbdata%next + CALL chkerr( nf90_put_var( idfile, idpext(je), & + & fbdata%pext(:,:,je) ), & + & cpname, 1515 ) + END DO + ENDIF + + ENDIF + + ! Close the file + + CALL chkerr( nf90_close( idfile ), cpname, 1523 ) + + + END SUBROUTINE write_obfbdata + + SUBROUTINE putvaratt_obfbdata( idfile, idvar, cdlongname, cdunits, & + & conventions, cfillvalue, & + & ifillvalue, rfillvalue ) + !!---------------------------------------------------------------------- + !! *** ROUTINE putvaratt_obfbdata *** + !! + !! ** Purpose : Write netcdf attributes for variable + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER :: idfile ! File netcdf id. + INTEGER :: idvar ! Variable netcdf id. + CHARACTER(len=*) :: cdlongname ! Long name for variable + CHARACTER(len=*), OPTIONAL :: cdunits ! Units for variable + CHARACTER(len=*), OPTIONAL :: cfillvalue ! Fill value for character variables + INTEGER, OPTIONAL, INTENT(IN) :: ifillvalue ! Fill value for integer variables + REAL(kind=fbsp), OPTIONAL :: rfillvalue ! Fill value for real variables + CHARACTER(len=*), OPTIONAL :: conventions ! Conventions for variable + !! * Local variables + CHARACTER(LEN=18), PARAMETER :: & + & cpname = 'putvaratt_obfbdata' + + CALL chkerr( nf90_put_att( idfile, idvar, 'long_name', & + & TRIM(cdlongname) ), & + & cpname, 1556 ) + + IF ( PRESENT(cdunits) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, 'units', & + & TRIM(cdunits) ), & + & cpname, 1562 ) + + ENDIF + + IF ( PRESENT(conventions) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, 'Conventions', & + & TRIM(conventions) ), & + & cpname, 1570 ) + + ENDIF + + IF ( PRESENT(cfillvalue) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & + & TRIM(cfillvalue) ), & + & cpname, 1578 ) + + ENDIF + + IF ( PRESENT(ifillvalue) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & + & ifillvalue ), & + & cpname, 1586 ) + + ENDIF + + IF ( PRESENT(rfillvalue) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & + & rfillvalue ), & + & cpname, 1594 ) + + ENDIF + + END SUBROUTINE putvaratt_obfbdata + + SUBROUTINE read_obfbdata( cdfilename, fbdata, ldgrid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE read_obfbdata *** + !! + !! ** Purpose : Read an obfbdata structure from a netCDF file. + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(len=*) :: cdfilename ! Input filename + TYPE(obfbdata) :: fbdata ! obsfbdata structure + LOGICAL, OPTIONAL, INTENT(IN) :: ldgrid ! Allow forcing of grid info + !! * Local variables + CHARACTER(LEN=14), PARAMETER :: cpname = 'read_obfbdata' + INTEGER :: idfile + INTEGER :: idodim + INTEGER :: idldim + INTEGER :: idvdim + INTEGER :: idadim + INTEGER :: idedim + INTEGER :: idgdim + INTEGER :: idvard + INTEGER :: idaddd + INTEGER :: idextd + INTEGER :: idcdwmo + INTEGER :: idcdtyp + INTEGER :: idplam + INTEGER :: idpphi + INTEGER :: idpdep + INTEGER :: idptim + INTEGER :: idptimr + INTEGER :: idioqc + INTEGER :: idioqcf + INTEGER :: idipqc + INTEGER :: idipqcf + INTEGER :: ididqc + INTEGER :: ididqcf + INTEGER :: iditqc + INTEGER :: iditqcf + INTEGER :: idkindex + INTEGER, DIMENSION(:), ALLOCATABLE :: & + & idpob, & + & idivqc, & + & idivqcf, & + & idivlqc, & + & idivlqcf, & + & idiobsi, & + & idiobsj, & + & idiobsk, & + & idcgrid, & + & idpext + INTEGER, DIMENSION(:,:), ALLOCATABLE :: & + & idpadd + INTEGER :: jv + INTEGER :: je + INTEGER :: nvar + INTEGER :: nobs + INTEGER :: nlev + INTEGER :: nadd + INTEGER :: next + LOGICAL :: lgrid + CHARACTER(len=NF90_MAX_NAME) :: cdtmp + + ! Check allocation status and deallocate previous allocated structures + + IF ( fbdata%lalloc ) THEN + CALL dealloc_obfbdata( fbdata ) + ENDIF + + ! Open input filename + + CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, idfile ), & + & cpname, 1675 ) + + ! Get input dimensions + + CALL chkerr( nf90_inq_dimid( idfile, 'N_OBS' , idodim ), & + & cpname,1680 ) + CALL chkerr( nf90_inquire_dimension( idfile, idodim, len=nobs ), & + & cpname,1682 ) + CALL chkerr( nf90_inq_dimid( idfile, 'N_LEVELS', idldim ), & + & cpname,1684 ) + CALL chkerr( nf90_inquire_dimension( idfile, idldim, len=nlev ), & + & cpname,1686 ) + CALL chkerr( nf90_inq_dimid( idfile, 'N_VARS', idvdim ), & + & cpname,1688 ) + CALL chkerr( nf90_inquire_dimension( idfile, idvdim, len=nvar ), & + & cpname,1690 ) + IF ( nf90_inq_dimid( idfile, 'N_ENTRIES', idadim ) == 0 ) THEN + CALL chkerr( nf90_inquire_dimension( idfile, idadim, len=nadd ), & + & cpname,1693 ) + ELSE + nadd = 0 + ENDIF + IF ( nf90_inq_dimid( idfile, 'N_EXTRA', idedim ) == 0 ) THEN + CALL chkerr( nf90_inquire_dimension( idfile, idedim, len=next ), & + & cpname,1699 ) + ELSE + next = 0 + ENDIF + ! + ! Check if this input file contains grid search informations + ! + lgrid = ( nf90_inq_dimid( idfile, 'STRINGGRID', idgdim ) == 0 ) + + ! Allocate data structure + + IF ( PRESENT(ldgrid) ) THEN + CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, & + & lgrid.OR.ldgrid ) + ELSE + CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, & + & lgrid ) + ENDIF + + ! Allocate netcdf identifiers + + ALLOCATE( & + & idpob(fbdata%nvar), & + & idivqc(fbdata%nvar), & + & idivqcf(fbdata%nvar), & + & idivlqc(fbdata%nvar), & + & idivlqcf(fbdata%nvar), & + & idiobsi(fbdata%nvar), & + & idiobsj(fbdata%nvar), & + & idiobsk(fbdata%nvar), & + & idcgrid(fbdata%nvar) & + & ) + IF ( fbdata%nadd > 0 ) THEN + ALLOCATE( & + & idpadd(fbdata%nadd,fbdata%nvar) & + & ) + ENDIF + IF ( fbdata%next > 0 ) THEN + ALLOCATE( & + & idpext(fbdata%next) & + & ) + ENDIF + + ! Read variables for header information + + CALL chkerr( nf90_inq_varid( idfile, 'VARIABLES',idvard ), & + & cpname, 1745 ) + CALL chkerr( nf90_get_var( idfile, idvard, fbdata%cname ), & + & cpname, 1747 ) + IF ( fbdata%nadd > 0 ) THEN + CALL chkerr( nf90_inq_varid( idfile, 'ENTRIES', idaddd ), & + & cpname, 1750 ) + CALL chkerr( nf90_get_var( idfile, idaddd, fbdata%caddname ), & + & cpname, 1752 ) + ENDIF + IF ( fbdata%next > 0 ) THEN + CALL chkerr( nf90_inq_varid( idfile, 'EXTRA', idextd ), & + & cpname, 1756 ) + CALL chkerr( nf90_get_var( idfile, idextd, fbdata%cextname ), & + & cpname, 1758 ) + ENDIF + + CALL chkerr( nf90_inq_varid( idfile, 'JULD_REFERENCE', idptimr ), & + & cpname, 1762 ) + CALL chkerr( nf90_get_var( idfile, idptimr, fbdata%cdjuldref ), & + & cpname, 1764 ) + + IF ( fbdata%nobs > 0 ) THEN + + CALL chkerr( nf90_inq_varid( idfile, 'STATION_IDENTIFIER', idcdwmo ),& + & cpname, 1769 ) + CALL chkerr( nf90_get_var( idfile, idcdwmo, fbdata%cdwmo ), & + & cpname, 1771 ) + CALL chkerr( nf90_inq_varid( idfile, 'STATION_TYPE', idcdtyp ), & + & cpname, 1773 ) + CALL chkerr( nf90_get_var( idfile, idcdtyp, fbdata%cdtyp), & + & cpname, 1775 ) + CALL chkerr( nf90_inq_varid( idfile, 'LONGITUDE', idplam ), & + & cpname, 1777 ) + CALL chkerr( nf90_get_var( idfile, idplam, fbdata%plam ), & + & cpname, 1779 ) + CALL chkerr( nf90_inq_varid( idfile, 'LATITUDE', idpphi ), & + & cpname, 1781 ) + CALL chkerr( nf90_get_var( idfile, idpphi, fbdata%pphi ), & + & cpname, 1783 ) + CALL chkerr( nf90_inq_varid( idfile, 'DEPTH', idpdep ), & + & cpname, 1785 ) + CALL chkerr( nf90_get_var( idfile, idpdep, fbdata%pdep ), & + & cpname, 1787 ) + CALL chkerr( nf90_inq_varid( idfile, 'JULD', idptim ), & + & cpname, 1789 ) + CALL chkerr( nf90_get_var( idfile, idptim, fbdata%ptim ), & + & cpname, 1791 ) + CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC', idioqc ), & + & cpname, 1793 ) + CALL chkerr( nf90_get_var( idfile, idioqc, fbdata%ioqc ), & + & cpname, 1795 ) + CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC_FLAGS', idioqcf ), & + & cpname, 1797 ) + CALL chkerr( nf90_get_var( idfile, idioqcf, fbdata%ioqcf ), & + & cpname, 1799 ) + CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC', idipqc ), & + & cpname, 1801 ) + CALL chkerr( nf90_get_var( idfile, idipqc, fbdata%ipqc ), & + & cpname, 1803 ) + CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC_FLAGS', idipqcf ), & + & cpname, 1805 ) + CALL chkerr( nf90_get_var( idfile, idipqcf, fbdata%ipqcf ), & + & cpname, 1807 ) + CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC', ididqc ), & + & cpname, 1809 ) + CALL chkerr( nf90_get_var( idfile, ididqc, fbdata%idqc ), & + & cpname, 1811 ) + CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC_FLAGS', ididqcf ), & + & cpname, 1813 ) + CALL chkerr( nf90_get_var( idfile, ididqcf, fbdata%idqcf ), & + & cpname, 1815 ) + CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC', iditqc ), & + & cpname, 1817 ) + CALL chkerr( nf90_get_var( idfile, iditqc, fbdata%itqc ), & + & cpname, 1819 ) + CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC_FLAGS', iditqcf ), & + & cpname, 1821 ) + CALL chkerr( nf90_get_var( idfile, iditqcf, fbdata%itqcf ), & + & cpname, 1823 ) + CALL chkerr( nf90_inq_varid( idfile, 'ORIGINAL_FILE_INDEX', idkindex ), & + & cpname, 1825 ) + CALL chkerr( nf90_get_var( idfile, idkindex, fbdata%kindex ), & + & cpname, 1827 ) + + ! Read netCDF variables for individual variables + + DO jv = 1, fbdata%nvar + + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), & + & cpname, 1835 ) + CALL chkerr( nf90_get_var( idfile, idpob(jv), & + & fbdata%pob(:,:,jv) ), & + & cpname, 1838 ) + CALL getvaratt_obfbdata( idfile, idpob(jv), & + & fbdata%coblong(jv), & + & fbdata%cobunit(jv) ) + + IF ( fbdata%nadd > 0 ) THEN + DO je = 1, fbdata%nadd + WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',& + & TRIM(fbdata%caddname(je)) + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), & + & cpname, 1848 ) + CALL chkerr( nf90_get_var( idfile, idpadd(je,jv), & + & fbdata%padd(:,:,je,jv) ), & + & cpname, 1851 ) + CALL getvaratt_obfbdata( idfile, idpadd(je,jv), & + & fbdata%caddlong(je,jv), & + & fbdata%caddunit(je,jv) ) + END DO + ENDIF + + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqc(jv) ), & + & cpname, 1860 ) + CALL chkerr( nf90_get_var( idfile, idivqc(jv), & + & fbdata%ivqc(:,jv) ), & + & cpname, 1863 ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqcf(jv) ), & + & cpname, 1866 ) + CALL chkerr( nf90_get_var( idfile, idivqcf(jv), & + & fbdata%ivqcf(:,:,jv) ), & + & cpname, 1869 ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqc(jv) ), & + & cpname, 1872 ) + CALL chkerr( nf90_get_var( idfile, idivlqc(jv), & + & fbdata%ivlqc(:,:,jv) ), & + & cpname, 1875 ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqcf(jv) ), & + & cpname, 1878 ) + CALL chkerr( nf90_get_var( idfile, idivlqcf(jv), & + & fbdata%ivlqcf(:,:,:,jv) ), & + & cpname, 1881 ) + IF ( lgrid ) THEN + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsi(jv) ), & + & cpname, 1885 ) + CALL chkerr( nf90_get_var( idfile, idiobsi(jv), & + & fbdata%iobsi(:,jv) ), & + & cpname, 1888 ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsj(jv) ), & + & cpname, 1891 ) + CALL chkerr( nf90_get_var( idfile, idiobsj(jv), & + & fbdata%iobsj(:,jv) ), & + & cpname, 1894 ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsk(jv) ), & + & cpname, 1897 ) + CALL chkerr( nf90_get_var( idfile, idiobsk(jv), & + & fbdata%iobsk(:,:,jv) ), & + & cpname, 1900 ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idcgrid(jv) ), & + & cpname, 1903 ) + CALL chkerr( nf90_get_var( idfile, idcgrid(jv), & + & fbdata%cgrid(jv) ), & + & cpname, 1906 ) + ENDIF + + END DO + + IF ( fbdata%next > 0 ) THEN + DO je = 1, fbdata%next + WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je)) + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), & + & cpname, 1915 ) + CALL chkerr( nf90_get_var( idfile, idpext(je), & + & fbdata%pext(:,:,je) ), & + & cpname, 1918 ) + CALL getvaratt_obfbdata( idfile, idpext(je), & + & fbdata%cextlong(je), & + & fbdata%cextunit(je) ) + END DO + ENDIF + + ELSE ! if no observations only get attributes + + DO jv = 1, fbdata%nvar + + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), & + & cpname, 1931 ) + CALL getvaratt_obfbdata( idfile, idpob(jv), & + & fbdata%coblong(jv), & + & fbdata%cobunit(jv) ) + + IF ( fbdata%nadd > 0 ) THEN + DO je = 1, fbdata%nadd + WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',& + & TRIM(fbdata%caddname(je)) + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), & + & cpname, 1941 ) + CALL getvaratt_obfbdata( idfile, idpadd(je,jv), & + & fbdata%caddlong(je,jv), & + & fbdata%caddunit(je,jv) ) + END DO + ENDIF + + END DO + + IF ( fbdata%next > 0 ) THEN + DO je = 1, fbdata%next + WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je)) + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), & + & cpname, 1954 ) + CALL getvaratt_obfbdata( idfile, idpext(je), & + & fbdata%cextlong(je), & + & fbdata%cextunit(je) ) + END DO + ENDIF + + ENDIF + + ! Close the file + + CALL chkerr( nf90_close( idfile ), cpname, 1965 ) + + END SUBROUTINE read_obfbdata + + SUBROUTINE getvaratt_obfbdata( idfile, idvar, cdlongname, cdunits ) + !!---------------------------------------------------------------------- + !! *** ROUTINE putvaratt_obfbdata *** + !! + !! ** Purpose : Read netcdf attributes for variable + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER :: idfile ! File netcdf id. + INTEGER :: idvar ! Variable netcdf id. + CHARACTER(len=*) :: cdlongname ! Long name for variable + CHARACTER(len=*) :: cdunits ! Units for variable + !! * Local variables + CHARACTER(LEN=18), PARAMETER :: cpname = 'getvaratt_obfbdata' + + CALL chkerr( nf90_get_att( idfile, idvar, 'long_name', & + & cdlongname ), & + & cpname, 1990 ) + + CALL chkerr( nf90_get_att( idfile, idvar, 'units', & + & cdunits ), & + & cpname, 1994 ) + + END SUBROUTINE getvaratt_obfbdata + +END MODULE obs_fbm diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_grid.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_grid.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2b6567a8ac1a28a666b61aa6d3e7e4289d4e1b90 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_grid.f90 @@ -0,0 +1,1786 @@ + + + + + + + + + + + + + +MODULE obs_grid + !!====================================================================== + !! *** MODULE obs_grid *** + !! Observation diagnostics: Various tools for grid searching etc. + !!====================================================================== + !!---------------------------------------------------------------------- + !! obs_grid_search : Find i,j on the ORCA grid from lat,lon + !! obs_level_search : Find level from depth + !! obs_zlevel_search : Find depth level from observed depth + !! obs_tlevel_search : Find temperature level from observed temp + !! obs_rlevel_search : Find density level from observed density + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE par_oce, ONLY : & ! Ocean parameters + & jpk, & + & jpni, & + & jpnj, & + & jpnij + USE dom_oce ! Ocean space and time domain variables + USE obs_mpp, ONLY : & ! MPP support routines for observation diagnostics + & obs_mpp_find_obs_proc, & + & mpp_global_max, & + & obs_mpp_max_integer + USE phycst, ONLY : & ! Physical constants + & rad + USE obs_utils, ONLY : & ! Observation operator utility functions + & grt_cir_dis, & + & chkerr + USE in_out_manager ! Printing support + USE netcdf + USE obs_const, ONLY : & + & obfillflt ! Fillvalue + USE lib_mpp, ONLY : & + & ctl_warn, ctl_stop + + IMPLICIT NONE + + !! * Routine accessibility + PUBLIC obs_grid_setup, & ! Setup grid searching + & obs_grid_search, & ! Find i, j on the ORCA grid from lat, lon + & obs_grid_deallocate, & ! Deallocate the look up table + & obs_level_search ! Find level from depth + + PRIVATE linquad, & ! Determine whether a point lies within a cell + & maxdist, & ! Find the maximum distance between 2 pts in a cell + & obs_grd_bruteforce, & ! Find i, j on the ORCA grid from lat, lon + & obs_grd_lookup ! Find i, j on the ORCA grid from lat, lon quicker + + !!* Module variables + + !! Default values + REAL(wp), PUBLIC :: rn_gridsearchres = 0.5 ! Resolution of grid + INTEGER, PRIVATE :: gsearch_nlons_def ! Num of longitudes + INTEGER, PRIVATE :: gsearch_nlats_def ! Num of latitudes + REAL(wp), PRIVATE :: gsearch_lonmin_def ! Min longitude + REAL(wp), PRIVATE :: gsearch_latmin_def ! Min latitude + REAL(wp), PRIVATE :: gsearch_dlon_def ! Lon spacing + REAL(wp), PRIVATE :: gsearch_dlat_def ! Lat spacing + !! Variable versions + INTEGER, PRIVATE :: nlons ! Num of longitudes + INTEGER, PRIVATE :: nlats ! Num of latitudes + REAL(wp), PRIVATE :: lonmin ! Min longitude + REAL(wp), PRIVATE :: latmin ! Min latitude + REAL(wp), PRIVATE :: dlon ! Lon spacing + REAL(wp), PRIVATE :: dlat ! Lat spacing + + INTEGER, PRIVATE :: maxxdiff, maxydiff ! Max diffs between model points + INTEGER, PRIVATE :: limxdiff, limydiff + + ! Data storage + REAL(wp), PRIVATE, DIMENSION(:,:), ALLOCATABLE :: & + & lons, & + & lats + INTEGER, PRIVATE, DIMENSION(:,:), ALLOCATABLE :: & + & ixpos, & + & iypos, & + & iprocn + + ! Switches + LOGICAL, PUBLIC :: ln_grid_search_lookup ! Use lookup table to speed up grid search + LOGICAL, PUBLIC :: ln_grid_global ! Use global distribution of observations + CHARACTER(LEN=44), PUBLIC :: & + & cn_gridsearchfile ! file name head for grid search lookup + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_grid.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_grid_search( kobsin, plam, pphi, kobsi, kobsj, kproc, & + & cdgrid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_grid_search *** + !! + !! ** Purpose : Search local gridpoints to find the grid box containing + !! the observations calls either + !! obs_grd_bruteforce - the original brute force search + !! or + !! obs_grd_lookup - uses a lookup table to do a fast + !!search + !!History : + !! ! 2007-12 (D. Lea) + !!------------------------------------------------------------------------ + + !! * Arguments + INTEGER :: & + & kobsin ! Size of the observation arrays + REAL(KIND=wp), DIMENSION(kobsin), INTENT(IN) :: & + & plam, & ! Longitude of obsrvations + & pphi ! Latitude of observations + INTEGER, DIMENSION(kobsin), INTENT(OUT) :: & + & kobsi, & ! I-index of observations + & kobsj, & ! J-index of observations + & kproc ! Processor number of observations + CHARACTER(LEN=1) :: & + & cdgrid ! Grid to search + + IF(kobsin > 0) THEN + + IF ( ln_grid_search_lookup .AND. ( cdgrid == 'T' ) ) THEN + CALL obs_grd_lookup( kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSE + IF ( cdgrid == 'T' ) THEN + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, jpi, 1, jpj, & + & narea-1, jpnij, & + & glamt, gphit, tmask, & + & kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSEIF ( cdgrid == 'U' ) THEN + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, jpi, 1, jpj, & + & narea-1, jpnij, & + & glamu, gphiu, umask, & + & kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSEIF ( cdgrid == 'V' ) THEN + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, jpi, 1, jpj, & + & narea-1, jpnij, & + & glamv, gphiv, vmask, & + & kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSEIF ( cdgrid == 'F' ) THEN + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, jpi, 1, jpj, & + & narea-1, jpnij, & + & glamf, gphif, fmask, & + & kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSE + CALL ctl_stop( 'Grid not supported' ) + ENDIF + ENDIF + + ENDIF + + END SUBROUTINE obs_grid_search + +SUBROUTINE obs_grd_bruteforce( kpi, kpj, kpiglo, kpjglo, & + & kldi, klei, kldj, klej, & + & kmyproc, ktotproc, & + & pglam, pgphi, pmask, & + & kobs, plam, pphi, kobsi, kobsj, & + & kproc) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_grd_bruteforce *** + !! + !! ** Purpose : Search gridpoints to find the grid box containing + !! the observations + !! + !! ** Method : Call to linquad + !! + !! ** Action : Return kproc holding the observation and kiobsi,kobsj + !! valid on kproc=kmyproc processor only. + !! + !! History : + !! ! 2001-11 (N. Daget, A. Weaver) + !! ! 2006-03 (A. Weaver) NEMOVAR migration. + !! ! 2006-05 (K. Mogensen) Moved to to separate routine. + !! ! 2007-10 (A. Vidard) Bug fix in wrap around checks; cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kpi ! Number of local longitudes + INTEGER, INTENT(IN) :: kpj ! Number of local latitudes + INTEGER, INTENT(IN) :: kpiglo ! Number of global longitudes + INTEGER, INTENT(IN) :: kpjglo ! Number of global latitudes + INTEGER, INTENT(IN) :: kldi ! Start of inner domain in i + INTEGER, INTENT(IN) :: klei ! End of inner domain in i + INTEGER, INTENT(IN) :: kldj ! Start of inner domain in j + INTEGER, INTENT(IN) :: klej ! End of inner domain in j + INTEGER, INTENT(IN) :: kmyproc ! Processor number for MPP + INTEGER, INTENT(IN) :: ktotproc ! Total number of processors + REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) :: & + & pglam, & ! Grid point longitude + & pgphi, & ! Grid point latitude + & pmask ! Grid point mask + INTEGER,INTENT(IN) :: kobs ! Size of the observation arrays + REAL(KIND=wp), DIMENSION(kobs), INTENT(IN) :: & + & plam, & ! Longitude of obsrvations + & pphi ! Latitude of observations + INTEGER, DIMENSION(kobs), INTENT(OUT) :: & + & kobsi, & ! I-index of observations + & kobsj, & ! J-index of observations + & kproc ! Processor number of observations + + !! * Local declarations + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zplam, zpphi + REAL(wp) :: zlammax + REAL(wp) :: zlam + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jo + INTEGER :: jlon + INTEGER :: jlat + INTEGER :: joffset + INTEGER :: jostride + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax,& + & zphitmin,& + & zlamtmax,& + & zlamtmin + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: & + & llinvalidcell + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zlamtm, & + & zphitm + + !----------------------------------------------------------------------- + ! Define grid setup for grid search + !----------------------------------------------------------------------- + IF (ln_grid_global) THEN + jlon = kpiglo + jlat = kpjglo + joffset = kmyproc + jostride = ktotproc + ELSE + jlon = kpi + jlat = kpj + joffset = 0 + jostride = 1 + ENDIF + !----------------------------------------------------------------------- + ! Set up data for grid search + !----------------------------------------------------------------------- + ALLOCATE( & + & zlamg(jlon,jlat), & + & zphig(jlon,jlat), & + & zmskg(jlon,jlat), & + & zphitmax(jlon-1,jlat-1), & + & zphitmin(jlon-1,jlat-1), & + & zlamtmax(jlon-1,jlat-1), & + & zlamtmin(jlon-1,jlat-1), & + & llinvalidcell(jlon-1,jlat-1), & + & zlamtm(4,jlon-1,jlat-1), & + & zphitm(4,jlon-1,jlat-1) & + & ) + !----------------------------------------------------------------------- + ! Copy data to local arrays + !----------------------------------------------------------------------- + IF (ln_grid_global) THEN + zlamg(:,:) = -1.e+10 + zphig(:,:) = -1.e+10 + zmskg(:,:) = -1.e+10 + DO jj = kldj, klej + DO ji = kldi, klei + zlamg(mig(ji),mjg(jj)) = pglam(ji,jj) + zphig(mig(ji),mjg(jj)) = pgphi(ji,jj) + zmskg(mig(ji),mjg(jj)) = pmask(ji,jj) + END DO + END DO + CALL mpp_global_max( zlamg ) + CALL mpp_global_max( zphig ) + CALL mpp_global_max( zmskg ) + ELSE + DO jj = 1, jlat + DO ji = 1, jlon + zlamg(ji,jj) = pglam(ji,jj) + zphig(ji,jj) = pgphi(ji,jj) + zmskg(ji,jj) = pmask(ji,jj) + END DO + END DO + ENDIF + !----------------------------------------------------------------------- + ! Copy longitudes and latitudes + !----------------------------------------------------------------------- + ALLOCATE( & + & zplam(kobs), & + & zpphi(kobs) & + & ) + DO jo = 1, kobs + zplam(jo) = plam(jo) + zpphi(jo) = pphi(jo) + END DO + !----------------------------------------------------------------------- + ! Set default values for output + !----------------------------------------------------------------------- + kproc(:) = -1 + kobsi(:) = -1 + kobsj(:) = -1 + !----------------------------------------------------------------------- + ! Copy grid positions to temporary arrays and renormalize to 0 to 360. + !----------------------------------------------------------------------- + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + zlamtm(1,ji,jj) = zlamg(ji ,jj ) + zphitm(1,ji,jj) = zphig(ji ,jj ) + zlamtm(2,ji,jj) = zlamg(ji+1,jj ) + zphitm(2,ji,jj) = zphig(ji+1,jj ) + zlamtm(3,ji,jj) = zlamg(ji+1,jj+1) + zphitm(3,ji,jj) = zphig(ji+1,jj+1) + zlamtm(4,ji,jj) = zlamg(ji ,jj+1) + zphitm(4,ji,jj) = zphig(ji ,jj+1) + END DO + END DO + WHERE ( zlamtm(:,:,:) < 0.0_wp ) + zlamtm(:,:,:) = zlamtm(:,:,:) + 360.0_wp + END WHERE + WHERE ( zlamtm(:,:,:) > 360.0_wp ) + zlamtm(:,:,:) = zlamtm(:,:,:) - 360.0_wp + END WHERE + !----------------------------------------------------------------------- + ! Handle case of the wraparound; beware, not working with orca180 + !----------------------------------------------------------------------- + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + zlammax = MAXVAL( zlamtm(:,ji,jj) ) + WHERE (zlammax - zlamtm(:, ji, jj) > 180 ) & + & zlamtm(:,ji,jj) = zlamtm(:,ji,jj) + 360._wp + zphitmax(ji,jj) = MAXVAL(zphitm(:,ji,jj)) + zphitmin(ji,jj) = MINVAL(zphitm(:,ji,jj)) + zlamtmax(ji,jj) = MAXVAL(zlamtm(:,ji,jj)) + zlamtmin(ji,jj) = MINVAL(zlamtm(:,ji,jj)) + END DO + END DO + !----------------------------------------------------------------------- + ! Search for boxes with only land points mark them invalid + !----------------------------------------------------------------------- + llinvalidcell(:,:) = .FALSE. + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + llinvalidcell(ji,jj) = & + & zmskg(ji ,jj ) == 0.0_wp .AND. & + & zmskg(ji+1,jj ) == 0.0_wp .AND. & + & zmskg(ji+1,jj+1) == 0.0_wp .AND. & + & zmskg(ji ,jj+1) == 0.0_wp + END DO + END DO + + !------------------------------------------------------------------------ + ! Master loop for grid search + !------------------------------------------------------------------------ + + DO jo = 1+joffset, kobs, jostride + + !--------------------------------------------------------------------- + ! Ensure that all observation longtiudes are between 0 and 360 + !--------------------------------------------------------------------- + + IF ( zplam(jo) < 0.0_wp ) zplam(jo) = zplam(jo) + 360.0_wp + IF ( zplam(jo) > 360.0_wp ) zplam(jo) = zplam(jo) - 360.0_wp + + !--------------------------------------------------------------------- + ! Find observations which are on within 1e-6 of a grid point + !--------------------------------------------------------------------- + + gridloop: DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + IF ( ABS( zphig(ji,jj) - zpphi(jo) ) < 1e-6 ) THEN + zlam = zlamg(ji,jj) + IF ( zlam < 0.0_wp ) zlam = zlam + 360.0_wp + IF ( zlam > 360.0_wp ) zlam = zlam - 360.0_wp + IF ( ABS( zlam - zplam(jo) ) < 1e-6 ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = kmyproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = kmyproc + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridloop + ENDIF + ENDIF + ENDIF + END DO + END DO gridloop + + !--------------------------------------------------------------------- + ! Ensure that all observation longtiudes are between -180 and 180 + !--------------------------------------------------------------------- + + IF ( zplam(jo) > 180 ) zplam(jo) = zplam(jo) - 360.0_wp + + !--------------------------------------------------------------------- + ! Do coordinate search using brute force. + ! - For land points kproc is set to number of the processor + 1000000 + ! and we continue the search. + ! - For ocean points kproc is set to the number of the processor + ! and we stop the search. + !--------------------------------------------------------------------- + + IF ( kproc(jo) == -1 ) THEN + + ! Normal case + gridpoints : DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + + IF ( ( zplam(jo) > zlamtmax(ji,jj) ) .OR. & + & ( zplam(jo) < zlamtmin(ji,jj) ) ) CYCLE + + IF ( ABS( zpphi(jo) ) < 85 ) THEN + IF ( ( zpphi(jo) > zphitmax(ji,jj) ) .OR. & + & ( zpphi(jo) < zphitmin(ji,jj) ) ) CYCLE + ENDIF + + IF ( linquad( zplam(jo), zpphi(jo), & + & zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = kmyproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = kmyproc + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridpoints + ENDIF + ENDIF + + END DO + END DO gridpoints + + ENDIF + + ! In case of failure retry for obs. longtiude + 360. + IF ( kproc(jo) == -1 ) THEN + gridpoints_greenwich : DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + + IF ( ( zplam(jo)+360.0_wp > zlamtmax(ji,jj) ) .OR. & + & ( zplam(jo)+360.0_wp < zlamtmin(ji,jj) ) ) CYCLE + + IF ( ABS( zpphi(jo) ) < 85 ) THEN + IF ( ( zpphi(jo) > zphitmax(ji,jj) ) .OR. & + & ( zpphi(jo) < zphitmin(ji,jj) ) ) CYCLE + ENDIF + + IF ( linquad( zplam(jo)+360.0_wp, zpphi(jo), & + & zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = kmyproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = kmyproc + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridpoints_greenwich + ENDIF + ENDIF + + END DO + END DO gridpoints_greenwich + + ENDIF + END DO + + !---------------------------------------------------------------------- + ! Synchronize kproc on all processors + !---------------------------------------------------------------------- + IF ( ln_grid_global ) THEN + CALL obs_mpp_max_integer( kproc, kobs ) + CALL obs_mpp_max_integer( kobsi, kobs ) + CALL obs_mpp_max_integer( kobsj, kobs ) + ELSE + CALL obs_mpp_find_obs_proc( kproc, kobs ) + ENDIF + + WHERE( kproc(:) >= 1000000 ) + kproc(:) = kproc(:) - 1000000 + END WHERE + + DEALLOCATE( & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax, & + & zphitmin, & + & zlamtmax, & + & zlamtmin, & + & llinvalidcell, & + & zlamtm, & + & zphitm, & + & zplam, & + & zpphi & + & ) + + END SUBROUTINE obs_grd_bruteforce + + SUBROUTINE obs_grd_lookup( kobs, plam, pphi, kobsi, kobsj, kproc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_grid_lookup *** + !! + !! ** Purpose : Search local gridpoints to find the grid box containing + !! the observations (much faster then obs_grd_bruteforce) + !! + !! ** Method : Call to linquad + !! + !! ** Action : Return kproc holding the observation and kiobsi,kobsj + !! valid on kproc=narea-1 processor only. + !! + !! History : + !! ! 2007-12 (D. Lea) new routine based on obs_grid_search + !!! updated with fixes from new version of obs_grid_search_bruteforce + !!! speeded up where points are not near a "difficult" region like an edge + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER :: kobs ! Size of the observation arrays + REAL(KIND=wp), DIMENSION(kobs), INTENT(IN) :: & + & plam, & ! Longitude of obsrvations + & pphi ! Latitude of observations + INTEGER, DIMENSION(kobs), INTENT(OUT) :: & + & kobsi, & ! I-index of observations + & kobsj, & ! J-index of observations + & kproc ! Processor number of observations + + !! * Local declarations + REAL(KIND=wp), DIMENSION(:), ALLOCATABLE :: & + & zplam + REAL(wp) :: zlammax + REAL(wp) :: zlam + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jo + INTEGER :: isx + INTEGER :: isy + INTEGER :: jimin + INTEGER :: jimax + INTEGER :: jjmin + INTEGER :: jjmax + INTEGER :: jojimin + INTEGER :: jojimax + INTEGER :: jojjmin + INTEGER :: jojjmax + INTEGER :: ipx1 + INTEGER :: ipy1 + INTEGER :: ip + INTEGER :: jp + INTEGER :: ipx + INTEGER :: ipy + INTEGER :: ipmx + INTEGER :: jlon + INTEGER :: jlat + INTEGER :: joffset + INTEGER :: jostride + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax,& + & zphitmin,& + & zlamtmax,& + & zlamtmin + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: & + & llinvalidcell + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zlamtm, & + & zphitm + LOGICAL :: llfourflag + INTEGER :: ifourflagcountt + INTEGER :: ifourflagcountf + INTEGER, DIMENSION(5) :: ifourflagcountr + + !----------------------------------------------------------------------- + ! Define grid for grid search + !----------------------------------------------------------------------- + IF (ln_grid_global) THEN + jlon = jpiglo + jlat = jpjglo + joffset = narea-1 + jostride = jpnij + ELSE + jlon = jpi + jlat = jpj + joffset = 0 + jostride = 1 + ENDIF + !----------------------------------------------------------------------- + ! Set up data for grid search + !----------------------------------------------------------------------- + ALLOCATE( & + & zlamg(jlon,jlat), & + & zphig(jlon,jlat), & + & zmskg(jlon,jlat), & + & zphitmax(jlon-1,jlat-1), & + & zphitmin(jlon-1,jlat-1), & + & zlamtmax(jlon-1,jlat-1), & + & zlamtmin(jlon-1,jlat-1), & + & llinvalidcell(jlon-1,jlat-1), & + & zlamtm(4,jlon-1,jlat-1), & + & zphitm(4,jlon-1,jlat-1) & + & ) + !----------------------------------------------------------------------- + ! Copy data to local arrays + !----------------------------------------------------------------------- + IF (ln_grid_global) THEN + zlamg(:,:) = -1.e+10 + zphig(:,:) = -1.e+10 + zmskg(:,:) = -1.e+10 + ! Add various grids here. + DO jj = 1, jpj + DO ji = 1, jpi + zlamg(mig(ji),mjg(jj)) = glamt(ji,jj) + zphig(mig(ji),mjg(jj)) = gphit(ji,jj) + zmskg(mig(ji),mjg(jj)) = tmask(ji,jj,1) + END DO + END DO + CALL mpp_global_max( zlamg ) + CALL mpp_global_max( zphig ) + CALL mpp_global_max( zmskg ) + ELSE + ! Add various grids here. + DO jj = 1, jlat + DO ji = 1, jlon + zlamg(ji,jj) = glamt(ji,jj) + zphig(ji,jj) = gphit(ji,jj) + zmskg(ji,jj) = tmask(ji,jj,1) + END DO + END DO + ENDIF + !----------------------------------------------------------------------- + ! Copy longitudes + !----------------------------------------------------------------------- + ALLOCATE( & + & zplam(kobs) & + & ) + DO jo = 1, kobs + zplam(jo) = plam(jo) + END DO + !----------------------------------------------------------------------- + ! Set default values for output + !----------------------------------------------------------------------- + kproc(:) = -1 + kobsi(:) = -1 + kobsj(:) = -1 + !----------------------------------------------------------------------- + ! Copy grid positions to temporary arrays and renormalize to 0 to 360. + !----------------------------------------------------------------------- + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + zlamtm(1,ji,jj) = zlamg(ji ,jj ) + zphitm(1,ji,jj) = zphig(ji ,jj ) + zlamtm(2,ji,jj) = zlamg(ji+1,jj ) + zphitm(2,ji,jj) = zphig(ji+1,jj ) + zlamtm(3,ji,jj) = zlamg(ji+1,jj+1) + zphitm(3,ji,jj) = zphig(ji+1,jj+1) + zlamtm(4,ji,jj) = zlamg(ji ,jj+1) + zphitm(4,ji,jj) = zphig(ji ,jj+1) + END DO + END DO + WHERE ( zlamtm(:,:,:) < 0.0_wp ) + zlamtm(:,:,:) = zlamtm(:,:,:) + 360.0_wp + END WHERE + WHERE ( zlamtm(:,:,:) > 360.0_wp ) + zlamtm(:,:,:) = zlamtm(:,:,:) - 360.0_wp + END WHERE + !----------------------------------------------------------------------- + ! Handle case of the wraparound; beware, not working with orca180 + !----------------------------------------------------------------------- + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + zlammax = MAXVAL( zlamtm(:,ji,jj) ) + WHERE (zlammax - zlamtm(:, ji, jj) > 180 ) & + & zlamtm(:,ji,jj) = zlamtm(:,ji,jj) + 360._wp + zphitmax(ji,jj) = MAXVAL(zphitm(:,ji,jj)) + zphitmin(ji,jj) = MINVAL(zphitm(:,ji,jj)) + zlamtmax(ji,jj) = MAXVAL(zlamtm(:,ji,jj)) + zlamtmin(ji,jj) = MINVAL(zlamtm(:,ji,jj)) + END DO + END DO + !----------------------------------------------------------------------- + ! Search for boxes with only land points mark them invalid + !----------------------------------------------------------------------- + llinvalidcell(:,:) = .FALSE. + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + llinvalidcell(ji,jj) = & + & zmskg(ji ,jj ) == 0.0_wp .AND. & + & zmskg(ji+1,jj ) == 0.0_wp .AND. & + & zmskg(ji+1,jj+1) == 0.0_wp .AND. & + & zmskg(ji ,jj+1) == 0.0_wp + END DO + END DO + + if(lwp) WRITE(numout,*) 'obs_grid_lookup do coordinate search using lookup table' + + !----------------------------------------------------------------------- + ! Do coordinate search using lookup table with local searches. + ! - For land points kproc is set to number of the processor + 1000000 + ! and we continue the search. + ! - For ocean points kproc is set to the number of the processor + ! and we stop the search. + !----------------------------------------------------------------------- + ifourflagcountt = 0 + ifourflagcountf = 0 + ifourflagcountr(:) = 0 + + !------------------------------------------------------------------------ + ! Master loop for grid search + !------------------------------------------------------------------------ + + gpkobs: DO jo = 1+joffset, kobs, jostride + ! Normal case + ! specify 4 points which surround the lat lon of interest + ! x i,j+1 x i+1, j+1 + ! + ! + ! * lon,lat + ! x i,j x i+1,j + + ! bottom corner point + ipx1 = INT( ( zplam(jo) - lonmin ) / dlon + 1.0 ) + ipy1 = INT( ( pphi (jo) - latmin ) / dlat + 1.0 ) + + ipx = ipx1 + 1 + ipy = ipy1 + 1 + + ! flag for searching around four points separately + ! default to false + llfourflag = .FALSE. + + ! check for point fully outside of region + IF ( (ipx1 > nlons) .OR. (ipy1 > nlats) .OR. & + & (ipx < 1) .OR. (ipy < 1) ) THEN + CYCLE + ENDIF + ! check wrap around + IF ( (ipx > nlons) .OR. (ipy > nlats) .OR. & + & (ipx1 < 1) .OR. (ipy1 < 1) ) THEN + llfourflag=.TRUE. + ifourflagcountr(1) = ifourflagcountr(1) + 1 + ENDIF + + IF (.NOT. llfourflag) THEN + IF (MAXVAL(ixpos(ipx1:ipx,ipy1:ipy)) == -1) CYCLE! cycle if no lookup points found + ENDIF + + jimin = 0 + jimax = 0 + jjmin = 0 + jjmax = 0 + + IF (.NOT. llfourflag) THEN + + ! calculate points range + ! define a square region encompassing the four corner points + ! do I need the -1 points? + + jojimin = MINVAL(ixpos(ipx1:ipx,ipy1:ipy)) - 1 + jojimax = MAXVAL(ixpos(ipx1:ipx,ipy1:ipy)) + 1 + jojjmin = MINVAL(iypos(ipx1:ipx,ipy1:ipy)) - 1 + jojjmax = MAXVAL(iypos(ipx1:ipx,ipy1:ipy)) + 1 + + jimin = jojimin - 1 + jimax = jojimax + 1 + jjmin = jojjmin - 1 + jjmax = jojjmax + 1 + + IF ( jojimin < 0 .OR. jojjmin < 0) THEN + llfourflag = .TRUE. + ifourflagcountr(2) = ifourflagcountr(2) + 1 + ENDIF + IF ( jojimax - jojimin > maxxdiff) THEN + llfourflag = .TRUE. + ifourflagcountr(3) = ifourflagcountr(3) + 1 + ENDIF + IF ( jojjmax - jojjmin > maxydiff) THEN + llfourflag = .TRUE. + ifourflagcountr(4) = ifourflagcountr(4) + 1 + ENDIF + + ENDIF + + ipmx = 0 + IF (llfourflag) ipmx = 1 + + IF (llfourflag) THEN + ifourflagcountt = ifourflagcountt + 1 + ELSE + ifourflagcountf = ifourflagcountf + 1 + ENDIF + + gridpointsn : DO ip = 0, ipmx + DO jp = 0, ipmx + + IF ( kproc(jo) /= -1 ) EXIT gridpointsn + + ipx = ipx1 + ip + ipy = ipy1 + jp + + IF (llfourflag) THEN + + ! deal with wrap around + IF ( ipx > nlons ) ipx = 1 + IF ( ipy > nlats ) ipy = 1 + IF ( ipx < 1 ) ipx = nlons + IF ( ipy < 1 ) ipy = nlats + + ! get i,j + isx = ixpos(ipx,ipy) + isy = iypos(ipx,ipy) + + ! estimate appropriate search region (use max/min values) + jimin = isx - maxxdiff - 1 + jimax = isx + maxxdiff + 1 + jjmin = isy - maxydiff - 1 + jjmax = isy + maxydiff + 1 + + ENDIF + + IF ( jimin < 1 ) jimin = 1 + IF ( jimax > jlon-1 ) jimax = jlon-1 + IF ( jjmin < 1 ) jjmin = 1 + IF ( jjmax > jlat-1 ) jjmax = jlat-1 + + !--------------------------------------------------------------- + ! Ensure that all observation longtiudes are between 0 and 360 + !--------------------------------------------------------------- + + IF ( zplam(jo) < 0.0_wp ) zplam(jo) = zplam(jo) + 360.0_wp + IF ( zplam(jo) > 360.0_wp ) zplam(jo) = zplam(jo) - 360.0_wp + + !--------------------------------------------------------------- + ! Find observations which are on within 1e-6 of a grid point + !--------------------------------------------------------------- + + gridloop: DO jj = jjmin, jjmax + DO ji = jimin, jimax + IF ( ABS( zphig(ji,jj) - pphi(jo) ) < 1e-6 ) THEN + zlam = zlamg(ji,jj) + IF ( zlam < 0.0_wp ) zlam = zlam + 360.0_wp + IF ( zlam > 360.0_wp ) zlam = zlam - 360.0_wp + IF ( ABS( zlam - zplam(jo) ) < 1e-6 ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = narea-1 + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = narea-1 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridloop + ENDIF + ENDIF + ENDIF + END DO + END DO gridloop + + !--------------------------------------------------------------- + ! Ensure that all observation longtiudes are between -180/180 + !--------------------------------------------------------------- + + IF ( zplam(jo) > 180 ) zplam(jo) = zplam(jo) - 360.0_wp + + IF ( kproc(jo) == -1 ) THEN + + ! Normal case + gridpoints : DO jj = jjmin, jjmax + DO ji = jimin, jimax + + + IF ( ( zplam(jo) > zlamtmax(ji,jj) ) .OR. & + & ( zplam(jo) < zlamtmin(ji,jj) ) ) CYCLE + + IF ( ABS( pphi(jo) ) < 85 ) THEN + IF ( ( pphi(jo) > zphitmax(ji,jj) ) .OR. & + & ( pphi(jo) < zphitmin(ji,jj) ) ) CYCLE + ENDIF + + IF ( linquad( zplam(jo), pphi(jo), & + & zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = narea-1 + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = narea-1 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridpoints + ENDIF + ENDIF + + END DO + END DO gridpoints + ENDIF + + ! In case of failure retry for obs. longtiude + 360. + IF ( kproc(jo) == -1 ) THEN + gridpoints_greenwich : DO jj = jjmin, jjmax + DO ji = jimin, jimax + + IF ( ( zplam(jo)+360.0_wp > zlamtmax(ji,jj) ) .OR. & + & ( zplam(jo)+360.0_wp < zlamtmin(ji,jj) ) ) CYCLE + + IF ( ABS( pphi(jo) ) < 85 ) THEN + IF ( ( pphi(jo) > zphitmax(ji,jj) ) .OR. & + & ( pphi(jo) < zphitmin(ji,jj) ) ) CYCLE + ENDIF + + IF ( linquad( zplam(jo)+360.0_wp, pphi(jo), & + & zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = narea-1 + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = narea-1 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridpoints_greenwich + ENDIF + ENDIF + + END DO + END DO gridpoints_greenwich + + ENDIF ! kproc + + END DO + END DO gridpointsn + END DO gpkobs ! kobs + + !---------------------------------------------------------------------- + ! Synchronize kproc on all processors + !---------------------------------------------------------------------- + IF ( ln_grid_global ) THEN + CALL obs_mpp_max_integer( kproc, kobs ) + CALL obs_mpp_max_integer( kobsi, kobs ) + CALL obs_mpp_max_integer( kobsj, kobs ) + ELSE + CALL obs_mpp_find_obs_proc( kproc, kobs ) + ENDIF + + WHERE( kproc(:) >= 1000000 ) + kproc(:) = kproc(:) - 1000000 + END WHERE + + DEALLOCATE( & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax, & + & zphitmin, & + & zlamtmax, & + & zlamtmin, & + & llinvalidcell, & + & zlamtm, & + & zphitm, & + & zplam & + & ) + + END SUBROUTINE obs_grd_lookup + + + SUBROUTINE obs_grid_setup + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_grid_setup *** + !! + !! ** Purpose : Setup a lookup table to reduce the searching required + !! for converting lat lons to grid point location + !! produces or reads in a preexisting file for use in + !! obs_grid_search_lookup_local + !! + !! ** Method : calls obs_grid_search_bruteforce_local with a array + !! of lats and lons + !! + !! History : + !! ! 2007-12 (D. Lea) new routine + !!---------------------------------------------------------------------- + + !! * Local declarations + CHARACTER(LEN=15), PARAMETER :: & + & cpname = 'obs_grid_setup' + CHARACTER(LEN=40) :: cfname + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jo + INTEGER :: idfile, idny, idnx, idxpos, idypos + INTEGER :: idlat, idlon, fileexist + INTEGER, DIMENSION(2) :: incdim + CHARACTER(LEN=20) :: datestr=" ",timestr=" " + REAL(wp) :: tmpx1, tmpx2, tmpy1, tmpy2 + REAL(wp) :: meanxdiff, meanydiff + REAL(wp) :: meanxdiff1, meanydiff1 + REAL(wp) :: meanxdiff2, meanydiff2 + INTEGER :: numx1, numx2, numy1, numy2, df + INTEGER :: jimin, jimax, jjmin, jjmax + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: & + & lonsi, & + & latsi + INTEGER, DIMENSION(:,:), ALLOCATABLE :: & + & ixposi, & + & iyposi, & + & iproci + INTEGER, PARAMETER :: histsize=90 + INTEGER, DIMENSION(histsize) :: & + & histx1, histx2, histy1, histy2 + REAL(wp), DIMENSION(histsize) :: & + & fhistx1, fhistx2, fhisty1, fhisty2 + REAL(wp) :: histtol + CHARACTER(LEN=26) :: clfmt ! writing format + INTEGER :: idg ! number of digits + + IF (ln_grid_search_lookup) THEN + + WRITE(numout,*) 'Calling obs_grid_setup' + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'Grid search resolution : ', rn_gridsearchres + + gsearch_nlons_def = NINT( 360.0_wp / rn_gridsearchres ) + gsearch_nlats_def = NINT( 180.0_wp / rn_gridsearchres ) + gsearch_lonmin_def = -180.0_wp + 0.5_wp * rn_gridsearchres + gsearch_latmin_def = -90.0_wp + 0.5_wp * rn_gridsearchres + gsearch_dlon_def = rn_gridsearchres + gsearch_dlat_def = rn_gridsearchres + + IF (lwp) THEN + WRITE(numout,*)'Grid search gsearch_nlons_def = ',gsearch_nlons_def + WRITE(numout,*)'Grid search gsearch_nlats_def = ',gsearch_nlats_def + WRITE(numout,*)'Grid search gsearch_lonmin_def = ',gsearch_lonmin_def + WRITE(numout,*)'Grid search gsearch_latmin_def = ',gsearch_latmin_def + WRITE(numout,*)'Grid search gsearch_dlon_def = ',gsearch_dlon_def + WRITE(numout,*)'Grid search gsearch_dlat_def = ',gsearch_dlat_def + ENDIF + + IF ( ln_grid_global ) THEN + WRITE(cfname, FMT="(A,'_',A)") TRIM(cn_gridsearchfile), 'global.nc' + ELSE + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + ! define the following format: "(a,a,ix.x,a,ix.x,a,ix.x,a)" + WRITE(clfmt, "('(a,a,i', i1, '.', i1',a,i', i1, '.', i1',a,i', i1, '.', i1',a)')") idg, idg, idg, idg, idg, idg + WRITE(cfname, clfmt ) TRIM(cn_gridsearchfile),'_', narea-1,'of', jpni,'by', jpnj,'.nc' + ENDIF + + fileexist=nf90_open( TRIM( cfname ), nf90_nowrite, & + & idfile ) + + IF ( fileexist == nf90_noerr ) THEN + + ! read data + ! initially assume size is as defined (to be fixed) + + WRITE(numout,*) 'Reading: ',cfname + + CALL chkerr( nf90_open( TRIM( cfname ), nf90_nowrite, idfile ), & + & cpname, 732 ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'maxxdiff', maxxdiff ), & + & cpname, 734 ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'maxydiff', maxydiff ), & + & cpname, 736 ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'dlon', dlon ), & + & cpname, 738 ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'dlat', dlat ), & + & cpname, 740 ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'lonmin', lonmin ), & + & cpname, 742 ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'latmin', latmin ), & + & cpname, 744 ) + + CALL chkerr( nf90_inq_dimid(idfile, 'nx' , idnx), & + & cpname, 747 ) + CALL chkerr( nf90_inquire_dimension( idfile, idnx, len = nlons ), & + & cpname, 749 ) + CALL chkerr( nf90_inq_dimid(idfile, 'ny' , idny), & + & cpname, 751 ) + CALL chkerr( nf90_inquire_dimension( idfile, idny, len = nlats ), & + & cpname, 753 ) + + ALLOCATE( & + & lons(nlons,nlats), & + & lats(nlons,nlats), & + & ixpos(nlons,nlats), & + & iypos(nlons,nlats), & + & iprocn(nlons,nlats) & + & ) + + CALL chkerr( nf90_inq_varid( idfile, 'XPOS', idxpos ), & + & cpname, 764 ) + CALL chkerr( nf90_get_var ( idfile, idxpos, ixpos), & + & cpname, 766 ) + CALL chkerr( nf90_inq_varid( idfile, 'YPOS', idypos ), & + & cpname, 768 ) + CALL chkerr( nf90_get_var ( idfile, idypos, iypos), & + & cpname, 770 ) + + CALL chkerr( nf90_close( idfile ), cpname, 772 ) + + ! setup arrays + + DO ji = 1, nlons + DO jj = 1, nlats + lons(ji,jj) = lonmin + (ji-1) * dlon + lats(ji,jj) = latmin + (jj-1) * dlat + END DO + END DO + + ! if we are not reading the file we need to create it + ! create new obs grid search lookup file + + ELSE + + ! call obs_grid_search + + IF (lwp) THEN + WRITE(numout,*) 'creating: ',cfname + WRITE(numout,*) 'calling obs_grid_search: ',nlons*nlats + ENDIF + + ! set parameters from default values + nlons = gsearch_nlons_def + nlats = gsearch_nlats_def + lonmin = gsearch_lonmin_def + latmin = gsearch_latmin_def + dlon = gsearch_dlon_def + dlat = gsearch_dlat_def + + ! setup arrays + + ALLOCATE( & + & lonsi(nlons,nlats), & + & latsi(nlons,nlats), & + & ixposi(nlons,nlats), & + & iyposi(nlons,nlats), & + & iproci(nlons,nlats) & + & ) + + DO ji = 1, nlons + DO jj = 1, nlats + lonsi(ji,jj) = lonmin + (ji-1) * dlon + latsi(ji,jj) = latmin + (jj-1) * dlat + END DO + END DO + + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, jpi, 1, jpj, & + & narea-1, jpnij, & + & glamt, gphit, tmask, & + & nlons*nlats, lonsi, latsi, & + & ixposi, iyposi, iproci ) + + ! minimise file size by removing regions with no data from xypos file + ! should be able to just use xpos (ypos will have the same areas of missing data) + + jimin=1 + jimax=nlons + jjmin=1 + jjmax=nlats + + minlon_xpos: DO ji= 1, nlons + IF (COUNT(ixposi(ji,:) >= 0) > 0) THEN + jimin=ji + EXIT minlon_xpos + ENDIF + END DO minlon_xpos + + maxlon_xpos: DO ji= nlons, 1, -1 + IF (COUNT(ixposi(ji,:) >= 0) > 0) THEN + jimax=ji + EXIT maxlon_xpos + ENDIF + END DO maxlon_xpos + + minlat_xpos: DO jj= 1, nlats + IF (COUNT(ixposi(:,jj) >= 0) > 0) THEN + jjmin=jj + EXIT minlat_xpos + ENDIF + END DO minlat_xpos + + maxlat_xpos: DO jj= nlats, 1, -1 + IF (COUNT(ixposi(:,jj) >= 0) > 0) THEN + jjmax=jj + EXIT maxlat_xpos + ENDIF + END DO maxlat_xpos + + lonmin = lonsi(jimin,jjmin) + latmin = latsi(jimin,jjmin) + nlons = jimax-jimin+1 + nlats = jjmax-jjmin+1 + + ! construct new arrays + + ALLOCATE( & + & lons(nlons,nlats), & + & lats(nlons,nlats), & + & ixpos(nlons,nlats), & + & iypos(nlons,nlats), & + & iprocn(nlons,nlats) & + & ) + + lons(:,:) = lonsi(jimin:jimax,jjmin:jjmax) + lats(:,:) = latsi(jimin:jimax,jjmin:jjmax) + ixpos(:,:) = ixposi(jimin:jimax,jjmin:jjmax) + iypos(:,:) = iyposi(jimin:jimax,jjmin:jjmax) + iprocn(:,:) = iproci(jimin:jimax,jjmin:jjmax) + + DEALLOCATE(lonsi,latsi,ixposi,iyposi,iproci) + + ! calculate (estimate) maxxdiff, maxydiff + ! this is to help define the search area for obs_grid_search_lookup + + maxxdiff = 1 + maxydiff = 1 + + tmpx1 = 0 + tmpx2 = 0 + tmpy1 = 0 + tmpy2 = 0 + + numx1 = 0 + numx2 = 0 + numy1 = 0 + numy2 = 0 + + ! calculate the mean absolute xdiff and ydiff + ! also calculate a histogram + ! note the reason why looking for xdiff and ydiff in both directions + ! is to allow for rotated grids + + DO ji = 1, nlons-1 + DO jj = 1, nlats-1 + IF ( ixpos(ji,jj) > 0 .AND. iypos(ji,jj) > 0 ) THEN + IF ( ixpos(ji+1,jj) > 0 ) THEN + df = ABS( ixpos(ji+1,jj) - ixpos(ji,jj) ) + tmpx1 = tmpx1+df + numx1 = numx1+1 + IF ( df < histsize ) histx1(df+1) = histx1(df+1) + 1 + ENDIF + IF ( ixpos(ji,jj+1) > 0 ) THEN + df = ABS( ixpos(ji,jj+1) - ixpos(ji,jj) ) + tmpx2 = tmpx2 + df + numx2 = numx2 + 1 + IF ( df < histsize ) histx2(df+1) = histx2(df+1) + 1 + ENDIF + IF (iypos(ji+1,jj) > 0) THEN + df = ABS( iypos(ji+1,jj) - iypos(ji,jj) ) + tmpy1 = tmpy1 + df + numy1 = numy1 + 1 + IF ( df < histsize ) histy1(df+1) = histy1(df+1) + 1 + ENDIF + IF ( iypos(ji,jj+1) > 0 ) THEN + df = ABS( iypos(ji,jj+1) - iypos(ji,jj) ) + tmpy2 = tmpy2 + df + numy2 = numy2 + 1 + IF ( df < histsize ) histy2(df+1) = histy2(df+1) + 1 + ENDIF + ENDIF + END DO + END DO + + IF (lwp) THEN + WRITE(numout,*) 'histograms' + WRITE(numout,*) '0 1 2 3 4 5 6 7 8 9 10 ...' + WRITE(numout,*) 'histx1' + WRITE(numout,*) histx1 + WRITE(numout,*) 'histx2' + WRITE(numout,*) histx2 + WRITE(numout,*) 'histy1' + WRITE(numout,*) histy1 + WRITE(numout,*) 'histy2' + WRITE(numout,*) histy2 + ENDIF + + meanxdiff1 = tmpx1 / numx1 + meanydiff1 = tmpy1 / numy1 + meanxdiff2 = tmpx2 / numx2 + meanydiff2 = tmpy2 / numy2 + + meanxdiff = MAXVAL((/ meanxdiff1, meanxdiff2 /)) + meanydiff = MAXVAL((/ meanydiff1, meanydiff2 /)) + + IF (lwp) THEN + WRITE(numout,*) tmpx1, tmpx2, tmpy1, tmpy2 + WRITE(numout,*) numx1, numx2, numy1, numy2 + WRITE(numout,*) 'meanxdiff: ',meanxdiff, meanxdiff1, meanxdiff2 + WRITE(numout,*) 'meanydiff: ',meanydiff, meanydiff1, meanydiff2 + ENDIF + + tmpx1 = 0 + tmpx2 = 0 + tmpy1 = 0 + tmpy2 = 0 + + numx1 = 0 + numx2 = 0 + numy1 = 0 + numy2 = 0 + + histx1(:) = 0 + histx2(:) = 0 + histy1(:) = 0 + histy2(:) = 0 + + limxdiff = meanxdiff * 4! limit the difference to avoid picking up wraparound + limydiff = meanydiff * 4 + + DO ji = 1, nlons-1 + DO jj = 1, nlats-1 + IF ( ixpos(ji,jj) > 0 .AND. iypos(ji,jj) > 0 ) THEN + + IF ( ixpos(ji+1,jj) > 0 ) THEN + df = ABS( ixpos(ji+1,jj)-ixpos(ji,jj) ) + tmpx1 = df + IF ( df < limxdiff ) numx1 = numx1+1 + IF ( df < histsize ) histx1(df+1) = histx1(df+1) + 1 + ENDIF + IF ( ixpos(ji,jj+1) > 0 ) THEN + df = ABS( ixpos(ji,jj+1) - ixpos(ji,jj) ) + tmpx2 = df + IF ( df < limxdiff ) numx2 = numx2 + 1 + IF ( df < histsize ) histx2(df+1) = histx2(df+1) + 1 + ENDIF + IF (iypos(ji+1,jj) > 0) THEN + df = ABS( iypos(ji+1,jj) - iypos(ji,jj) ) + tmpy1 = df + IF ( df < limydiff ) numy1 = numy1 + 1 + IF ( df < histsize ) histy1(df+1) = histy1(df+1) + 1 + ENDIF + IF (iypos(ji,jj+1) > 0) THEN + df = ABS( iypos(ji,jj+1) - iypos(ji,jj) ) + tmpy2 = df + IF ( df < limydiff ) numy2 = numy2+1 + IF ( df < histsize ) histy2(df+1) = histy2(df+1)+1 + ENDIF + + IF ( maxxdiff < tmpx1 .AND. tmpx1 < limxdiff ) & + & maxxdiff = tmpx1 + IF ( maxxdiff < tmpx2 .AND. tmpx2 < limxdiff ) & + & maxxdiff = tmpx2 + IF ( maxydiff < tmpy1 .AND. tmpy1 < limydiff ) & + & maxydiff = tmpy1 + IF ( maxydiff < tmpy2 .AND. tmpy2 < limydiff ) & + & maxydiff = tmpy2 + + ENDIF + END DO + END DO + + ! cumulative histograms + + DO ji = 1, histsize - 1 + histx1(ji+1) = histx1(ji+1) + histx1(ji) + histx2(ji+1) = histx2(ji+1) + histx2(ji) + histy1(ji+1) = histy1(ji+1) + histy1(ji) + histy2(ji+1) = histy2(ji+1) + histy2(ji) + END DO + + fhistx1(:) = histx1(:) * 1.0 / numx1 + fhistx2(:) = histx2(:) * 1.0 / numx2 + fhisty1(:) = histy1(:) * 1.0 / numy1 + fhisty2(:) = histy2(:) * 1.0 / numy2 + + ! output new histograms + + IF (lwp) THEN + WRITE(numout,*) 'cumulative histograms' + WRITE(numout,*) '0 1 2 3 4 5 6 7 8 9 10 ...' + WRITE(numout,*) 'fhistx1' + WRITE(numout,*) fhistx1 + WRITE(numout,*) 'fhistx2' + WRITE(numout,*) fhistx2 + WRITE(numout,*) 'fhisty1' + WRITE(numout,*) fhisty1 + WRITE(numout,*) 'fhisty2' + WRITE(numout,*) fhisty2 + ENDIF + + ! calculate maxxdiff and maxydiff based on cumulative histograms + ! where > 0.999 of points are + + ! maxval just converts 1x1 vector return from maxloc to a scalar + + histtol = 0.999 + tmpx1 = MAXVAL( MAXLOC( fhistx1(:), mask = ( fhistx1(:) <= histtol ) ) ) + tmpx2 = MAXVAL( MAXLOC( fhistx2(:), mask = ( fhistx2(:) <= histtol ) ) ) + tmpy1 = MAXVAL( MAXLOC( fhisty1(:), mask = ( fhisty1(:) <= histtol ) ) ) + tmpy2 = MAXVAL( MAXLOC( fhisty2(:), mask = ( fhisty2(:) <= histtol ) ) ) + + maxxdiff = MAXVAL( (/ tmpx1, tmpx2 /) ) + 1 + maxydiff = MAXVAL( (/ tmpy1, tmpy2 /) ) + 1 + + ! Write out data + + IF ( ( .NOT. ln_grid_global ) .OR. & + & ( ( ln_grid_global ) .AND. ( narea-1==0 ) ) ) THEN + + CALL chkerr( nf90_create (TRIM(cfname), nf90_clobber, idfile), & + & cpname, 1075 ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'title', & + & 'Mapping file from lon/lat to model grid point' ),& + & cpname,1078 ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'maxxdiff', & + & maxxdiff ), & + & cpname,1081 ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'maxydiff', & + & maxydiff ), & + & cpname,1084 ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'dlon', dlon ),& + & cpname,1086 ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'dlat', dlat ),& + & cpname,1088 ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'lonmin', & + & lonmin ), & + & cpname,1091 ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'latmin', & + & latmin ), & + & cpname,1094 ) + + CALL chkerr( nf90_def_dim(idfile, 'nx' , nlons, idnx), & + & cpname,1097 ) + CALL chkerr( nf90_def_dim(idfile, 'ny' , nlats, idny), & + & cpname,1099 ) + + incdim(1) = idnx + incdim(2) = idny + + CALL chkerr( nf90_def_var( idfile, 'LON', nf90_float, incdim, & + & idlon ), & + & cpname, 1106 ) + CALL chkerr( nf90_put_att( idfile, idlon, 'long_name', & + & 'longitude' ), & + & cpname, 1109 ) + + CALL chkerr( nf90_def_var( idfile, 'LAT', nf90_float, incdim, & + & idlat ), & + & cpname, 1113 ) + CALL chkerr( nf90_put_att( idfile, idlat, 'long_name', & + & 'latitude' ), & + & cpname, 1116 ) + + CALL chkerr( nf90_def_var( idfile, 'XPOS', nf90_int, incdim, & + & idxpos ), & + & cpname, 1120 ) + CALL chkerr( nf90_put_att( idfile, idxpos, 'long_name', & + & 'x position' ), & + & cpname, 1123 ) + CALL chkerr( nf90_put_att( idfile, idxpos, '_FillValue', -1 ), & + & cpname, 1125 ) + + CALL chkerr( nf90_def_var( idfile, 'YPOS', nf90_int, incdim, & + & idypos ), & + & cpname, 1129 ) + CALL chkerr( nf90_put_att( idfile, idypos, 'long_name', & + & 'y position' ), & + & cpname, 1132 ) + CALL chkerr( nf90_put_att( idfile, idypos, '_FillValue', -1 ), & + & cpname, 1134 ) + + CALL chkerr( nf90_enddef( idfile ), cpname, 1136 ) + + CALL chkerr( nf90_put_var( idfile, idlon, lons), & + & cpname, 1139 ) + CALL chkerr( nf90_put_var( idfile, idlat, lats), & + & cpname, 1141 ) + CALL chkerr( nf90_put_var( idfile, idxpos, ixpos), & + & cpname, 1143 ) + CALL chkerr( nf90_put_var( idfile, idypos, iypos), & + & cpname, 1145 ) + + CALL chkerr( nf90_close( idfile ), cpname, 1147 ) + + ! should also output max i, max j spacing for use in + ! obs_grid_search_lookup + + ENDIF + + ENDIF + + ENDIF + + END SUBROUTINE obs_grid_setup + + SUBROUTINE obs_grid_deallocate( ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_grid_setup *** + !! + !! ** Purpose : Deallocate arrays setup by obs_grid_setup + !! + !! History : + !! ! 2007-12 (D. Lea) new routine + !!----------------------------------------------------------------------- + + IF (ln_grid_search_lookup) THEN + DEALLOCATE( lons, lats, ixpos, iypos, iprocn ) + ENDIF + + END SUBROUTINE obs_grid_deallocate + +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_level_search.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE obs_level_search( kgrd, pgrddep, kobs, pobsdep, kobsk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_level_search *** + !! + !! ** Purpose : Search levels to find matching level to observed depth + !! + !! ** Method : Straightforward search + !! + !! ** Action : + !! + !! History : + !! ! 2001-11 (N. Daget, A. Weaver) + !! ! 2006-03 (A. Weaver) NEMOVAR migration. + !! ! 2006-05 (K. Mogensen) Moved to to separate routine. + !! ! 2006-10 (A. Weaver) Cleanup + !! ! 2008-10 (K. Mogensen) Remove assumptions on grid. + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kgrd ! Number of gridpoints + REAL(KIND=wp), DIMENSION(kgrd), INTENT(INOUT) :: & + & pgrddep ! Depths of gridpoints + INTEGER, INTENT(IN) :: & + & kobs ! Number of observations + REAL(KIND=wp), DIMENSION(kobs), INTENT(INOUT) :: & + & pobsdep ! Depths of observations + INTEGER ,DIMENSION(kobs), INTENT(OUT) :: & + & kobsk ! Level indices of observations + + !! * Local declarations + INTEGER :: ji + INTEGER :: jk + + !------------------------------------------------------------------------ + ! Search levels for each observations to find matching level + !------------------------------------------------------------------------ + DO ji = 1, kobs + kobsk(ji) = 1 + depk: DO jk = 2, kgrd + IF ( pgrddep(jk) >= pobsdep(ji) ) EXIT depk + END DO depk + kobsk(ji) = jk + END DO + + END SUBROUTINE obs_level_search + +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: linquad.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + LOGICAL FUNCTION linquad( px, py, pxv, pyv ) + !!---------------------------------------------------------------------- + !! *** FUNCTION linquad *** + !! + !! ** Purpose : Determine whether a point P(x,y) lies within or on the + !! boundary of a quadrangle (ABCD) of any shape on a plane. + !! + !! ** Method : Check if the vectorial products PA x PC, PB x PA, + !! PC x PD, and PD x PB are all negative. + !! + !! ** Action : + !! + !! History : + !! ! 2001-11 (N. Daget, A. Weaver) + !! ! 2006-08 (A. Weaver) NEMOVAR migration + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: px ! (lon) of the point P(x,y) + REAL(KIND=wp), INTENT(IN) :: py ! (lat) of the point P(x,y) + REAL(KIND=wp), DIMENSION(4), INTENT(IN) :: & + & pxv, & ! (lon, lat) of the surrounding cell + & pyv + + !! * Local declarations + REAL(KIND=wp) :: zst1 + REAL(KIND=wp) :: zst2 + REAL(KIND=wp) :: zst3 + REAL(KIND=wp) :: zst4 + + !----------------------------------------------------------------------- + ! Test to see if the point is within the cell + !----------------------------------------------------------------------- + linquad = .FALSE. + zst1 = ( px - pxv(1) ) * ( py - pyv(4) ) & + & - ( py - pyv(1) ) * ( px - pxv(4) ) + IF ( zst1 <= 0.0 ) THEN + zst2 = ( px - pxv(4) ) * ( py - pyv(3) ) & + & - ( py - pyv(4) ) * ( px - pxv(3) ) + IF ( zst2 <= 0.0 ) THEN + zst3 = ( px - pxv(3) ) * ( py - pyv(2) ) & + & - ( py - pyv(3) ) * ( px - pxv(2) ) + IF ( zst3 <= 0.0) THEN + zst4 = ( px - pxv(2) ) * ( py - pyv(1) ) & + & - ( py - pyv(2) ) * ( px - pxv(1) ) + IF ( zst4 <= 0.0 ) linquad = .TRUE. + ENDIF + ENDIF + ENDIF + + END FUNCTION linquad + +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: maxdist.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(wp) FUNCTION maxdist( pxv, pyv ) + !!---------------------------------------------------------------------- + !! *** FUNCTION maxdist *** + !! + !! ** Purpose : Compute the maximum distance between any points within + !! a cell + !! + !! ** Method : Call to grt_cir_dis + !! + !! ** Action : + !! + !! History : + !! ! 2006-08 (K. Mogensen) + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), DIMENSION(4), INTENT(IN) :: & + & pxv, & ! (lon, lat) of the surrounding cell + & pyv + + !! * Local declarations + REAL(KIND=wp), DIMENSION(4) :: & + & zxv, & + & zyv, & + & za, & + & zb, & + & zc + REAL(KIND=wp) :: zdist + + INTEGER :: ji + INTEGER :: jj + + !----------------------------------------------------------------------- + ! Convert data to radians + !----------------------------------------------------------------------- + DO ji = 1, 4 + zxv(ji) = pxv(ji) * rad + zyv(ji) = pyv(ji) * rad + END DO + + !----------------------------------------------------------------------- + ! Prepare input to grt_cir_dis + !----------------------------------------------------------------------- + DO ji = 1, 4 + za(ji) = SIN( zyv(ji) ) + zb(ji) = COS( zyv(ji) ) * COS( zxv(ji) ) + zc(ji) = COS( zyv(ji) ) * SIN( zxv(ji) ) + END DO + + !----------------------------------------------------------------------- + ! Get max distance between any points in the area + !----------------------------------------------------------------------- + maxdist = 0.0 + DO jj = 1, 4 + DO ji = jj+1, 4 + zdist = grt_cir_dis( za(jj), za(ji), zb(jj), & + & zb(ji), zc(jj), zc(ji)) + IF ( zdist > maxdist ) THEN + maxdist = zdist + ENDIF + END DO + END DO + + !----------------------------------------------------------------------- + ! Convert to degrees. + !----------------------------------------------------------------------- + maxdist = maxdist / rad + + END FUNCTION maxdist + +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: find_obs_proc.h90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE find_obs_proc(kldi,klei,kldj,klej,kmyproc,kobsp,kobsi,kobsj,kno) + !!---------------------------------------------------------------------- + !! *** ROUTINE find_obs_proc *** + !! + !! ** Purpose : From the array kobsp containing the results of the grid + !! grid search on each processor the processor return a + !! decision of which processors should hold the observation. + !! + !! ** Method : Use i and j and halo regions to decide which processor to + !! put ob in. Intended to avoid the mpp calls required by + !! obs_mpp_find_obs_proc + !! + !! History : + !!! 03-08 (D. Lea) Original code + !!----------------------------------------------------------------------- + + !! * Arguments + + INTEGER, INTENT(IN) :: kldi ! Start of inner domain in i + INTEGER, INTENT(IN) :: klei ! End of inner domain in i + INTEGER, INTENT(IN) :: kldj ! Start of inner domain in j + INTEGER, INTENT(IN) :: klej ! End of inner domain in j + + INTEGER, INTENT(IN) :: kmyproc + INTEGER, INTENT(IN) :: kno + + INTEGER, DIMENSION(kno), INTENT(IN) :: kobsi + INTEGER, DIMENSION(kno), INTENT(IN) :: kobsj + INTEGER, DIMENSION(kno), INTENT(INOUT) :: kobsp + + !! * local variables + INTEGER :: & + & ji + + ! first and last indoor i- and j-indexes kldi, klei, kldj, klej + ! exclude any obs in the bottom-left overlap region + ! also any obs outside to whole region (defined by jpi and jpj) + ! I am assuming that kobsp does not need to be the correct processor + ! number + + DO ji = 1, kno + IF (kobsi(ji) < kldi .OR. kobsj(ji) < kldj & + .OR. kobsi(ji) > klei .OR. kobsj(ji) > klej) THEN + IF (lwp .AND. kobsp(ji) /= -1) WRITE(numout,*) & + & 'kobs: ',kobsi(ji), kobsj(ji), kobsp(ji) + kobsp(ji)=1000000 + ENDIF + END DO + + ! Ensure that observations not in processor are masked + + WHERE(kobsp(:) /= kmyproc) kobsp(:)=1000000 + + END SUBROUTINE find_obs_proc + +END MODULE obs_grid diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_inter_h2d.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_inter_h2d.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ab6e9549444207c945324f7b83729b31149240b9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_inter_h2d.f90 @@ -0,0 +1,1429 @@ + + + + + + + + + + + + + +MODULE obs_inter_h2d + !!====================================================================== + !! *** MODULE obs_inter_h2d *** + !! Observation diagnostics: Perform the horizontal interpolation + !! from model grid to observation location + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_int_h2d : Horizontal interpolation to the observation point + !! obs_int_h2d_ds1 : Distance-weighted interpolation (n2dint=0) + !! obs_int_h2d_ds2 : Distance-weighted interpolation (small angle) (n2dint=1) + !! obs_int_h2d_bil : Bilinear interpolation (geographical grid) (n2dint=2) + !! obs_int_h2d_bir : Bilinear remapping interpolation (general grid) (n2dint=3) + !! obs_int_h2d_pol : Polynomial interpolation (n2dint=4) + !! bil_wgt : Compute weights for bilinear remapping + !! lu_invmat : Invert a matrix using LU decomposition + !! lu_decomp : LU decomposition + !! lu_backsb : LU decomposition - back substitution + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE phycst, ONLY : & ! Physical constants + & rad, & + & rpi + USE in_out_manager + USE obs_const, ONLY : & + & obfillflt ! Fillvalue + USE obs_utils ! Utility functions + USE lib_mpp,ONLY : & + & ctl_warn, ctl_stop + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE obs_int_h2d_ds1, & ! Distance-weighted interpolation + & obs_int_h2d_ds2, & ! Distance-weighted interpolation (small angle) + & obs_int_h2d_bil, & ! Bilinear interpolation (geographical grid) + & obs_int_h2d_bir, & ! Bilinear remapping interpolation (general grid) + & obs_int_h2d_pol, & ! Polynomial interpolation + & lu_invmat, & ! Invert a matrix using LU decomposition + & lu_decomp, & ! LU decomposition + & lu_backsb, & ! LU decomposition - back substitution + & bil_wgt ! Compute weights for bilinear remapping + PUBLIC obs_int_h2d, & ! Horizontal interpolation to the observation point + & obs_int_h2d_init ! Set up weights and vertical mask + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_inter_h2d.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obsinter_h2d.h90 10353 2018-11-21 16:04:47Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE obs_int_h2d_init( kpk, kpk2, k2dint, plam, pphi, & + & pglam, pgphi, pmask, pweig, pobsmask, & + & iminpoints ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d *** + !! + !! ** Purpose : Computes weights for horizontal interpolation to the + !! observation point. + !! + !! ** Method : Horizontal interpolation to the observation point using + !! model values at the corners of the surrounding grid + !! points. + !! + !! Interpolation Schemes : + !! + !! 1) k2dint = 0: Distance-weighted interpolation scheme 1 + !! + !! The interpolation weights are computed as a weighted + !! sum of the distance between the model grid points (A) + !! and the observation point (B). Distance (s) is computed + !! using the great-circle distance formula: + !! + !! s(AB) = arcos( sin( phiA ) x sin( phiB ) + !! + cos( phiA ) x cos( phiB ) + !! x cos( lamB - lamA ) ) + !! + !! 2) k2dint = 1: Distance-weighted interpolation scheme 2 + !! + !! As k2dint = 0 but with distance (ds) computed using + !! a small-angle approximation to the great-circle formula: + !! + !! ds(AB) = sqrt( ( phiB - phiA )^{2} + !! + ( ( lamB - lamA ) * cos( phiB ) )^{2} ) + !! + !! 3) k2dint = 2: Bilinear interpolation on a geographical grid + !! + !! The interpolation is split into two 1D interpolations in + !! the longitude and latitude directions, respectively. + !! + !! 4) k2dint = 3: General bilinear remapping interpolation + !! + !! An iterative scheme that involves first mapping a + !! quadrilateral cell into a cell with coordinates + !! (0,0), (1,0), (0,1) and (1,1). + !! + !! 5) k2dint = 4: Polynomial interpolation + !! + !! The interpolation weights are computed by fitting a + !! polynomial function of the form + !! + !! P(i) = a1(i) + a2(i) * phi + a3(i) * plam + !! + a4(i) * phi * plam + !! + !! through the model values at the four surrounding grid points. + !! + !! ** Action : + !! + !! References : Jones, P.: A users guide for SCRIP: A Spherical + !! Coordinate Remapping and Interpolation Package. + !! Version 1.4. Los Alomos. + !! + !! http://www.acl.lanl.gov/climate/software/SCRIP/SCRIPmain.html + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) NEMOVAR migration + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-08 (K. Mogensen) Split in two routines for easier adj. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk, & ! Parameter values for automatic arrays + & kpk2, & + & k2dint ! Interpolation scheme options + ! = 0 distance-weighted (great circle) + ! = 1 distance-weighted (small angle) + ! = 2 bilinear (geographical grid) + ! = 3 bilinear (quadrilateral grid) + ! = 4 polynomial (quadrilateral grid) + REAL(KIND=wp), INTENT(INOUT) :: & + & plam, & + & pphi ! Geographical (lat,lon) coordinates of + ! observation + REAL(KIND=wp), DIMENSION(2,2), INTENT(IN) :: & + & pglam, & ! Model variable lat + & pgphi ! Model variable lon + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(OUT) :: & + & pweig ! Weights for interpolation + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsmask ! Vertical mask for observations + INTEGER, INTENT(IN), OPTIONAL :: & + & iminpoints ! Reject point which is not surrounded + ! by at least iminpoints sea points + + !! * Local declarations + INTEGER :: & + & jk + INTEGER :: & + & ikmax, & + & iamb1, & + & iamb2 + REAL(KIND=wp) :: & + & zphimm, & + & zphimp, & + & zphipm, & + & zphipp, & + & zlammm, & + & zlammp, & + & zlampm, & + & zlampp, & + & zphimin, & + & zphimax, & + & zlammin, & + & zlammax + REAL(KIND=wp), DIMENSION(kpk2) :: & + & z2dmm, & + & z2dmp, & + & z2dpm, & + & z2dpp, & + & z2dmmt, & + & z2dmpt, & + & z2dpmt, & + & z2dppt, & + & zsum + LOGICAL :: & + & ll_ds1, & + & ll_skip, & + & ll_fail + + !------------------------------------------------------------------------ + ! Constants for the 360 degrees ambiguity + !------------------------------------------------------------------------ + iamb1 = 10 ! dlam < iamb1 * dphi + iamb2 = 3 ! Special treatment if iamb2 * lam < max(lam) + + !------------------------------------------------------------------------ + ! Initialize number of levels + !------------------------------------------------------------------------ + IF ( kpk2 == 1 ) THEN + ikmax = 1 + ELSEIF ( kpk2 == kpk) THEN + ikmax = kpk-1 + ENDIF + !------------------------------------------------------------------------ + ! Initialize the cell corners + !------------------------------------------------------------------------ + zphimm = pgphi(1,1) + zphimp = pgphi(1,2) + zphipm = pgphi(2,1) + zphipp = pgphi(2,2) + zlammm = pglam(1,1) + zlammp = pglam(1,2) + zlampm = pglam(2,1) + zlampp = pglam(2,2) + + !------------------------------------------------------------------------ + ! Treat the 360 degrees ambiguity + !------------------------------------------------------------------------ + DO WHILE ( ( zlammm < 0.0_wp ).OR.( zlammm > 360.0_wp ) & + & .OR.( zlampm < 0.0_wp ).OR.( zlampm > 360.0_wp ) & + & .OR.( zlampp < 0.0_wp ).OR.( zlampp > 360.0_wp ) & + & .OR.( zlammp < 0.0_wp ).OR.( zlammp > 360.0_wp ) ) + + IF ( zlammm < 0.0_wp ) zlammm = zlammm + 360.0_wp + IF ( zlammm > 360.0_wp ) zlammm = zlammm - 360.0_wp + IF ( zlammp < 0.0_wp ) zlammp = zlammp + 360.0_wp + IF ( zlammp > 360.0_wp ) zlammp = zlammp - 360.0_wp + IF ( zlampm < 0.0_wp ) zlampm = zlampm + 360.0_wp + IF ( zlampm > 360.0_wp ) zlampm = zlampm - 360.0_wp + IF ( zlampp < 0.0_wp ) zlampp = zlampp + 360.0_wp + IF ( zlampp > 360.0_wp ) zlampp = zlampp - 360.0_wp + + END DO + + DO WHILE ( ( plam < 0.0_wp ) .OR. ( plam > 360.0_wp ) ) + IF ( plam < 0.0_wp ) plam = plam + 360.0_wp + IF ( plam > 360.0_wp ) plam = plam - 360.0_wp + END DO + + !------------------------------------------------------------------------ + ! Special case for observation on grid points + !------------------------------------------------------------------------ + ll_skip = .FALSE. + IF ( ( ABS( zphimm - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlammm - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 1.0_wp + z2dpm(:) = 0.0_wp + z2dmp(:) = 0.0_wp + z2dpp(:) = 0.0_wp + ll_skip = .TRUE. + ENDIF + IF ( ( ABS( zphipm - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlampm - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 0.0_wp + z2dpm(:) = 1.0_wp + z2dmp(:) = 0.0_wp + z2dpp(:) = 0.0_wp + ll_skip = .TRUE. + ENDIF + IF ( ( ABS( zphimp - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlammp - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 0.0_wp + z2dpm(:) = 0.0_wp + z2dmp(:) = 1.0_wp + z2dpp(:) = 0.0_wp + ll_skip = .TRUE. + ENDIF + IF ( ( ABS( zphipp - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlampp - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 0.0_wp + z2dpm(:) = 0.0_wp + z2dmp(:) = 0.0_wp + z2dpp(:) = 1.0_wp + ll_skip = .TRUE. + ENDIF + + IF ( .NOT.ll_skip ) THEN + + zphimin = MIN( zphimm, zphipm, zphipp, zphimp ) + zphimax = MAX( zphimm, zphipm, zphipp, zphimp ) + zlammin = MIN( zlammm, zlampm, zlampp, zlammp ) + zlammax = MAX( zlammm, zlampm, zlampp, zlammp ) + + IF ( ( ( zlammax - zlammin ) / ( zphimax - zphimin ) ) > iamb1 ) THEN + IF ( iamb2 * zlammm < zlammax ) zlammm = zlammm + 360.0_wp + IF ( iamb2 * zlammp < zlammax ) zlammp = zlammp + 360.0_wp + IF ( iamb2 * zlampm < zlammax ) zlampm = zlampm + 360.0_wp + IF ( iamb2 * zlampp < zlammax ) zlampp = zlampp + 360.0_wp + ENDIF + + zlammin = MIN( zlammm, zlampm, zlampp, zlammp ) + IF ( zlammm > ( zlammin + 180.0_wp ) ) zlammm = zlammm - 360.0_wp + IF ( zlammp > ( zlammin + 180.0_wp ) ) zlammp = zlammp - 360.0_wp + IF ( zlampm > ( zlammin + 180.0_wp ) ) zlampm = zlampm - 360.0_wp + IF ( zlampp > ( zlammin + 180.0_wp ) ) zlampp = zlampp - 360.0_wp + + IF ( plam < zlammin ) plam = plam + 360.0_wp + z2dmm = 0.0_wp + z2dmp = 0.0_wp + z2dpm = 0.0_wp + z2dpp = 0.0_wp + SELECT CASE (k2dint) + + CASE(0) + CALL obs_int_h2d_ds1( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + CASE(1) + CALL obs_int_h2d_ds2( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + CASE(2) + CALL obs_int_h2d_bil( kpk2, ikmax, & + & pphi, plam, pmask, & + & zlammp, & + & zphipm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + CASE(3) + CALL obs_int_h2d_bir( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp, ll_fail ) + IF (ll_fail) THEN + IF(lwp) THEN + WRITE(numout,*)'Bilinear weight computation failed' + WRITE(numout,*)'Switching to great circle distance' + WRITE(numout,*) + ENDIF + CALL obs_int_h2d_ds1( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + ENDIF + CASE(4) + CALL obs_int_h2d_pol( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + END SELECT + + ENDIF + !------------------------------------------------------------------------ + ! Compute weights for interpolation to the observation point + !------------------------------------------------------------------------ + pobsmask(:) = 0.0_wp + pweig(:,:,:) = 0.0_wp + ! ll_ds1 is used for failed interpolations + ll_ds1 = .FALSE. + DO jk = 1, ikmax + IF (PRESENT(iminpoints)) THEN + IF (NINT(SUM(pmask(:,:,jk))) 0.0_wp ) .AND. & + & ( pmask(1,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dmp(jk) > 0.0_wp ) .AND. & + & ( pmask(1,2,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dpm(jk) > 0.0_wp ) .AND. & + & ( pmask(2,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dpp(jk) > 0.0_wp ) .AND. & + & ( pmask(2,2,jk) == 1.0_wp ) ) ) pobsmask(jk)=1.0_wp + ELSE + ! If the interpolation has failed due to the point + ! being on the intersect of two land points retry with + ! k2dint = 0 + IF ( ( pmask(1,1,jk) /= 0.0_wp ).OR. & + & ( pmask(1,2,jk) /= 0.0_wp ).OR. & + & ( pmask(2,1,jk) /= 0.0_wp ).OR. & + & ( pmask(2,2,jk) /= 0.0_wp ) ) THEN + ! If ll_ds1 is false compute k2dint = 0 weights + IF ( .NOT.ll_ds1 ) THEN + CALL obs_int_h2d_ds1( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmmt, z2dmpt, z2dpmt, z2dppt ) + ll_ds1 = .TRUE. + ENDIF + zsum(jk) = z2dmmt(jk) + z2dmpt(jk) + z2dpmt(jk) + z2dppt(jk) + IF ( zsum(jk) /= 0.0_wp ) THEN + pweig(1,1,jk) = z2dmmt(jk) + pweig(1,2,jk) = z2dmpt(jk) + pweig(2,1,jk) = z2dpmt(jk) + pweig(2,2,jk) = z2dppt(jk) + ! Set the vertical mask + IF ( ( ( z2dmmt(jk) > 0.0_wp ) .AND. & + & ( pmask(1,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dmpt(jk) > 0.0_wp ) .AND. & + & ( pmask(1,2,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dpmt(jk) > 0.0_wp) .AND. & + & ( pmask(2,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dppt(jk) > 0.0_wp ) .AND. & + & ( pmask(2,2,jk) == 1.0_wp ) ) ) & + & pobsmask(jk)=1.0_wp + ENDIF + ENDIF + ENDIF + END DO + + END SUBROUTINE obs_int_h2d_init + + SUBROUTINE obs_int_h2d( kpk, kpk2, & + & pweig, pmod, pobsk ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d *** + !! + !! ** Purpose : Horizontal interpolation to the observation point. + !! + !! ** Method : Horizontal interpolation to the observation point using + !! model values at the corners of the surrounding grid + !! points. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) NEMOVAR migration + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-08 (K. Mogensen) Split in two routines for easier adj. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk, & ! Parameter values for automatic arrays + & kpk2 + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pweig ! Interpolation weights + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmod ! Model variable to interpolate + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsk ! Model profile interpolated to obs (i,j) pt + + !! * Local declarations + INTEGER :: & + & jk + INTEGER :: & + & ikmax + REAL(KIND=wp) :: & + & zsum + !------------------------------------------------------------------------ + ! Initialize number of levels + !------------------------------------------------------------------------ + IF ( kpk2 == 1 ) THEN + ikmax = 1 + ELSEIF ( kpk2 == kpk) THEN + ikmax = kpk-1 + ENDIF + !------------------------------------------------------------------------ + ! Interpolate to the observation point + !------------------------------------------------------------------------ + pobsk(:) = obfillflt + DO jk = 1, ikmax + zsum = pweig(1,1,jk) + pweig(1,2,jk) + pweig(2,1,jk) + pweig(2,2,jk) + IF ( zsum /= 0.0_wp ) THEN + pobsk(jk) = ( pweig(1,1,jk) * pmod(1,1,jk) & + & + pweig(1,2,jk) * pmod(1,2,jk) & + & + pweig(2,1,jk) * pmod(2,1,jk) & + & + pweig(2,2,jk) * pmod(2,2,jk) & + & ) / zsum + ENDIF + END DO + + END SUBROUTINE obs_int_h2d + + SUBROUTINE obs_int_h2d_ds1( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_ds1 *** + !! + !! ** Purpose : Distance-weighted interpolation scheme (k2dint = 0) + !! + !! ** Method : The interpolation weights are computed as a weighted + !! sum of the distance between the model grid points (A) + !! and the observation point (B). + !! + !! Distance (s) is computed using the great-circle distance formula: + !! + !! s(AB) = arcos( sin( phiA ) x sin( phiB ) + !! + cos( phiA ) x cos( phiB ) x cos( lamB - lamA ) + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Modules used + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zphi2, & + & zlam2, & + & zcola, & + & za2, & + & zb2, & + & zc2, & + & zphimm2, & + & zphimp2, & + & zphipm2, & + & zphipp2, & + & zlammm2, & + & zlammp2, & + & zlampm2, & + & zlampp2, & + & za1mm, & + & za1mp, & + & za1pm, & + & za1pp, & + & zcomm, & + & zcomp, & + & zcopm, & + & zcopp, & + & zb1mm, & + & zb1mp, & + & zb1pm, & + & zb1pp, & + & zc1mm, & + & zc1mp, & + & zc1pm, & + & zc1pp, & + & zsopmpp, & + & zsommmp, & + & zsomm, & + & zsomp, & + & zsopm, & + & zsopp + + !------------------------------------------------------------------------ + ! Distance-weighted interpolation using the great circle formula + !------------------------------------------------------------------------ + zphi2 = pphi * rad + zlam2 = plam * rad + zcola = COS( zphi2 ) + za2 = SIN( zphi2 ) + zb2 = zcola * COS( zlam2 ) + zc2 = zcola * SIN( zlam2 ) + + zphimm2 = pphimm * rad + zphimp2 = pphimp * rad + zphipm2 = pphipm * rad + zphipp2 = pphipp * rad + + zlammm2 = plammm * rad + zlammp2 = plammp * rad + zlampm2 = plampm * rad + zlampp2 = plampp * rad + + za1mm = SIN( zphimm2 ) + za1mp = SIN( zphimp2 ) + za1pm = SIN( zphipm2 ) + za1pp = SIN( zphipp2 ) + + zcomm = COS( zphimm2 ) + zcomp = COS( zphimp2 ) + zcopm = COS( zphipm2 ) + zcopp = COS( zphipp2 ) + + zb1mm = zcomm * COS( zlammm2 ) + zb1mp = zcomp * COS( zlammp2 ) + zb1pm = zcopm * COS( zlampm2 ) + zb1pp = zcopp * COS( zlampp2 ) + + zc1mm = zcomm * SIN( zlammm2 ) + zc1mp = zcomp * SIN( zlammp2 ) + zc1pm = zcopm * SIN( zlampm2 ) + zc1pp = zcopp * SIN( zlampp2 ) + + ! Function for arcsin(sqrt(1-x^2) version of great-circle formula + zsomm = grt_cir_dis( za1mm, za2, zb1mm, zb2, zc1mm, zc2 ) + zsomp = grt_cir_dis( za1mp, za2, zb1mp, zb2, zc1mp, zc2 ) + zsopm = grt_cir_dis( za1pm, za2, zb1pm, zb2, zc1pm, zc2 ) + zsopp = grt_cir_dis( za1pp, za2, zb1pp, zb2, zc1pp, zc2 ) + + zsopmpp = zsopm * zsopp + zsommmp = zsomm * zsomp + DO jk = 1, kmax + p2dmm(jk) = zsomp * zsopmpp * pmask(1,1,jk) + p2dmp(jk) = zsomm * zsopmpp * pmask(1,2,jk) + p2dpm(jk) = zsopp * zsommmp * pmask(2,1,jk) + p2dpp(jk) = zsopm * zsommmp * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_ds1 + + SUBROUTINE obs_int_h2d_ds2( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_ds2 *** + !! + !! ** Purpose : Distance-weighted interpolation scheme (k2dint = 1) + !! + !! ** Method : As k2dint = 0 but with distance (ds) computed using a + !! small-angle approximation to the great-circle distance + !! formula: + !! + !! ds(AB) = sqrt( ( phiB - phiA )^{2} + !! + ( ( lamB - lamA ) * cos( phiB ) )^{2} ) + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !!----------------------------------------------------------------------- + !! * Modules used + !!----------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zcosp, & + & zdlmm, & + & zdlmp, & + & zdlpm, & + & zdlpp, & + & zdpmm, & + & zdpmp, & + & zdppm, & + & zdppp, & + & zsomm, & + & zsomp, & + & zsopm, & + & zsopp, & + & zsopmpp, & + & zsommmp + + !------------------------------------------------------------------------ + ! Distance-weighted interpolation with a small angle approximation + !------------------------------------------------------------------------ + zcosp = COS( pphi * rad ) + + zdlmm = plammm - plam + zdlmp = plammp - plam + zdlpm = plampm - plam + zdlpp = plampp - plam + + zdpmm = pphimm - pphi + zdpmp = pphimp - pphi + zdppm = pphipm - pphi + zdppp = pphipp - pphi + + zsomm = grt_cir_dis_saa( zdlmm, zdpmm, zcosp ) + zsomp = grt_cir_dis_saa( zdlmp, zdpmp, zcosp ) + zsopm = grt_cir_dis_saa( zdlpm, zdppm, zcosp ) + zsopp = grt_cir_dis_saa( zdlpp, zdppp, zcosp ) + + zsopmpp = zsopm * zsopp + zsommmp = zsomm * zsomp + + DO jk = 1, kmax + p2dmm(jk) = zsomp * zsopmpp * pmask(1,1,jk) + p2dmp(jk) = zsomm * zsopmpp * pmask(1,2,jk) + p2dpm(jk) = zsopp * zsommmp * pmask(2,1,jk) + p2dpp(jk) = zsopm * zsommmp * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_ds2 + + SUBROUTINE obs_int_h2d_bil( kpk2, kmax, & + & pphi, plam, pmask, & + & plammp, pphipm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_bil *** + !! + !! ** Purpose : Bilinear interpolation on a geographical grid (k2dint = 2) + !! + !! ** Method : The interpolation is split into two 1D interpolations in + !! the longitude and latitude directions, respectively. + !! + !! An iterative scheme that involves first mapping a quadrilateral + !! cell into a cell with coordinates (0,0), (1,0), (0,1) and (1,1). + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphipm, & ! Geographical location of surrounding + & pphipp, & ! model grid points + & plammp, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zdlmp, & + & zdppm, & + & zdlpp, & + & zdppp + + !---------------------------------------------------------------------- + ! Bilinear interpolation for geographical grid + !---------------------------------------------------------------------- + zdlmp = ABS(plam - plammp) + zdppm = ABS(pphi - pphipm) + zdlpp = ABS(plampp - plam) + zdppp = ABS(pphipp - pphi) + + DO jk = 1, kmax + p2dmm(jk) = zdlpp * zdppp * pmask(1,1,jk) + p2dmp(jk) = zdlpp * zdppm * pmask(1,2,jk) + p2dpm(jk) = zdlmp * zdppp * pmask(2,1,jk) + p2dpp(jk) = zdlmp * zdppm * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_bil + + SUBROUTINE obs_int_h2d_bir( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp, ldfail ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_bir *** + !! + !! ** Purpose : General bilinear remapping interpolation (k2dint = 3) + !! + !! ** Method : An iterative scheme that involves first mapping a + !! quadrilateral cell into a cell with coordinates + !! (0,0), (1,0), (0,1) and (1,1). + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + LOGICAL, INTENT(OUT) :: & + & ldfail + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zbiwmm, & + & zbiwmp, & + & zbiwpm, & + & zbiwpp + + !---------------------------------------------------------------------- + ! Bilinear remapping interpolation for general quadrilateral grid + !---------------------------------------------------------------------- + CALL bil_wgt( pphimm, pphimp, pphipm, pphipp, & + & plammm, plammp, plampm, plampp, & + & zbiwmm, zbiwmp, zbiwpm, zbiwpp, & + & pphi , plam, ldfail ) + + IF ( .NOT.ldfail ) THEN + DO jk = 1, kmax + p2dmm(jk) = zbiwmm * pmask(1,1,jk) + p2dmp(jk) = zbiwmp * pmask(1,2,jk) + p2dpm(jk) = zbiwpm * pmask(2,1,jk) + p2dpp(jk) = zbiwpp * pmask(2,2,jk) + END DO + ENDIF + + END SUBROUTINE obs_int_h2d_bir + + SUBROUTINE obs_int_h2d_pol( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_pol *** + !! + !! ** Purpose : Polynomial interpolation (k2dint = 4) + !! + !! ** Method : The interpolation weights are computed by fitting a + !! polynomial function of the form + !! + !! P(i) = a1(i) + a2(i) * phi + a3(i) * plam + a4(i) * phi * plam + !! + !! through the model values at four surrounding grid pts (i=1,4). + !! As k2dint = 0 but with distance (ds) computed using a small- + !! angle approximation to the great-circle distance formula: + !! + !! ds(AB) = sqrt( ( phiB - phiA )^{2} + !! + ( ( lamB - lamA ) * cos( phiB ) )^{2} ) + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zplp + REAL(KIND=wp), DIMENSION(4,4) :: & + & zmat, & + & zmati + + !------------------------------------------------------------------------ + ! Polynomial interpolation + !------------------------------------------------------------------------ + zmat(1,1) = 1.0_wp + zmat(1,2) = 1.0_wp + zmat(1,3) = 1.0_wp + zmat(1,4) = 1.0_wp + zmat(2,1) = plammm + zmat(2,2) = plammp + zmat(2,3) = plampm + zmat(2,4) = plampp + zmat(3,1) = pphimm + zmat(3,2) = pphimp + zmat(3,3) = pphipm + zmat(3,4) = pphipp + zmat(4,1) = plammm * pphimm + zmat(4,2) = plammp * pphimp + zmat(4,3) = plampm * pphipm + zmat(4,4) = plampp * pphipp + + CALL lu_invmat( zmat, 4, zmati ) + + zplp = plam * pphi + DO jk = 1, kmax + p2dmm(jk) = ABS( zmati(1,1) + zmati(1,2) * plam & + & + zmati(1,3) * pphi + zmati(1,4) * zplp ) & + & * pmask(1,1,jk) + p2dmp(jk) = ABS( zmati(2,1) + zmati(2,2) * plam & + & + zmati(2,3) * pphi + zmati(2,4) * zplp ) & + & * pmask(1,2,jk) + p2dpm(jk) = ABS( zmati(3,1) + zmati(3,2) * plam & + & + zmati(3,3) * pphi + zmati(3,4) * zplp ) & + & * pmask(2,1,jk) + p2dpp(jk) = ABS( zmati(4,1) + zmati(4,2) * plam & + & + zmati(4,3) * pphi + zmati(4,4) * zplp ) & + & * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_pol + + SUBROUTINE bil_wgt( pphimm, pphimp, pphipm, pphipp, & + & plammm, plammp, plampm, plampp, & + & pbiwmm, pbiwmp, pbiwpm, pbiwpp, & + & pphi , plam, ldfail ) + !!------------------------------------------------------------------- + !! + !! *** ROUTINE bil_wgt *** + !! + !! ** Purpose : Compute the weights for a bilinear remapping + !! interpolation scheme. + !! + !! ** Method : This scheme is appropriate for bilinear interpolation + !! on a general quadrilateral grid. + !! This scheme is also used in OASIS. + !! + !! This routine is a derivative of the SCRIP software. + !! Copyright 1997, 1998 the Regents of the University + !! of California. See SCRIP_Copyright.txt. + !! + !! ** Action : + !! + !! References : Jones, P.: A user's guide for SCRIP: A Spherical + !! Coordinate Remapping and Interpolation Package. + !! Version 1.4. Los Alamos. + !! + !! http://www.acl.lanl.gov/climate/software/SCRIP/SCRIPmain.html + !! + !! History + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), INTENT(OUT) :: & + & pbiwmm, & ! Interpolation weights + & pbiwmp, & + & pbiwpm, & + & pbiwpp + LOGICAL, INTENT(out) :: & + & ldfail + + !! * Local declarations + INTEGER :: & + & jiter + INTEGER :: & + & itermax + REAL(KIND=wp) :: & + & zphi, & ! Geographical location of observation + & zlam, & + & zphimm, & ! Geographical location of surrounding + & zphimp, & ! model grid points + & zphipm, & + & zphipp, & + & zlammm, & + & zlammp, & + & zlampm, & + & zlampp, & + & zdth1, & + & zdth2, & + & zdth3, & + & zdthp, & + & zdph1, & + & zdph2, & + & zdph3, & + & zdphp, & + & zmat1, & + & zmat2, & + & zmat3, & + & zmat4, & + & zdeli, & + & zdelj, & + & ziguess, & + & zjguess, & + & zeps, & + & zdeterm, & + & z2pi, & + & zhpi + + ! Initialization + + ! Conversion to radians + + zphi = pphi * rad + zlam = plam * rad + zphimm = pphimm * rad + zphimp = pphimp * rad + zphipm = pphipm * rad + zphipp = pphipp * rad + zlammm = plammm * rad + zlammp = plammp * rad + zlampm = plampm * rad + zlampp = plampp * rad + + ldfail = .FALSE. + + zdth1 = zphipm - zphimm + zdth2 = zphimp - zphimm + zdth3 = zphipp - zphipm - zdth2 + + zdph1 = zlampm - zlammm + zdph2 = zlammp - zlammm + zdph3 = zlampp - zlampm + + z2pi = 2.0_wp * rpi + + IF ( zdph1 > 3.0_wp * rpi ) zdph1 = zdph1 - z2pi + IF ( zdph2 > 3.0_wp * rpi ) zdph2 = zdph2 - z2pi + IF ( zdph3 > 3.0_wp * rpi ) zdph3 = zdph3 - z2pi + IF ( zdph1 < -3.0_wp * rpi ) zdph1 = zdph1 + z2pi + IF ( zdph2 < -3.0_wp * rpi ) zdph2 = zdph2 + z2pi + IF ( zdph3 < -3.0_wp * rpi ) zdph3 = zdph3 + z2pi + + zdph3 = zdph3 - zdph2 + + ziguess = 0.5_wp + zjguess = 0.5_wp + + itermax = 100 + + IF ( wp == sp ) THEN + zeps = 1.0e-6_wp ! Single precision + ELSE + zeps = 1.0e-10_wp ! Double precision + ENDIF + + !------------------------------------------------------------------------ + ! Iterate to determine (i,j) in new coordinate system + !------------------------------------------------------------------------ + jiter_loop: DO jiter = 1, itermax + + zdthp = zphi - zphimm - zdth1 * ziguess - zdth2 * zjguess & + & - zdth3 * ziguess * zjguess + zdphp = zlam - zlammm + + zhpi = 0.5_wp * rpi + IF ( zdphp > 3.0_wp * zhpi ) zdphp = zdphp - z2pi + IF ( zdphp < -3.0_wp * zhpi ) zdphp = zdphp + z2pi + + zdphp = zdphp - zdph1 * ziguess - zdph2 * zjguess & + & - zdph3 * ziguess * zjguess + + zmat1 = zdth1 + zdth3 * zjguess + zmat2 = zdth2 + zdth3 * ziguess + zmat3 = zdph1 + zdph3 * zjguess + zmat4 = zdph2 + zdph3 * ziguess + + ! Matrix determinant + zdeterm = zmat1 * zmat4 - zmat2 * zmat3 + + zdeli = ( zdthp * zmat4 - zmat2 * zdphp) / zdeterm + zdelj = ( zmat1 * zdphp - zdthp * zmat3) / zdeterm + + IF ( ABS( zdeli ) < zeps .AND. ABS( zdelj ) < zeps ) EXIT jiter_loop + + ziguess = ziguess + zdeli + zjguess = zjguess + zdelj + + ! DJL prevent ziguess and zjguess from going outside the range + ! 0 to 1 + ! prevents interpolated value going wrong + ! for example sea ice concentration gt 1 + + IF ( ziguess < 0 ) ziguess = 0.0_wp + IF ( zjguess < 0 ) zjguess = 0.0_wp + IF ( ziguess > 1 ) ziguess = 1.0_wp + IF ( zjguess > 1 ) zjguess = 1.0_wp + + END DO jiter_loop + + IF ( jiter <= itermax ) THEN + + ! Successfully found i,j, now compute the weights + + pbiwmm = ( 1.0_wp - ziguess ) * ( 1.0_wp - zjguess ) + pbiwmp = ( 1.0_wp - ziguess ) * zjguess + pbiwpm = ziguess * ( 1.0_wp - zjguess ) + pbiwpp = ziguess * zjguess + + ELSEIF ( jiter > itermax ) THEN + + IF(lwp) THEN + + WRITE(numout,*)'Obs lat/lon : ',pphi, plam + WRITE(numout,*)'Grid lats : ',pphimm, pphimp, pphipm, pphipp + WRITE(numout,*)'Grid lons : ',plammm, plammp, plampm, plampp + WRITE(numout,*)'Current i,j : ',ziguess, zjguess + WRITE(numout,*)'jiter = ',jiter + WRITE(numout,*)'zeps = ',zeps + WRITE(numout,*)'zdeli, zdelj = ',zdeli, zdelj + WRITE(numout,*)' Iterations for i,j exceed max iteration count!' + WRITE(numout,*) + + ldfail = .TRUE. + + ENDIF + + ENDIF + + END SUBROUTINE bil_wgt + + SUBROUTINE lu_invmat( pmatin, kdim, pmatou ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_invmat *** + !! + !! ** Purpose : Invert a matrix using LU decomposition. + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !! ! 06-11 (NEMOVAR task force) Fix declaration of zd. + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim ! Array dimension + REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(IN) :: & + & pmatin + REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(OUT) :: & + & pmatou + + !! * Local declarations + INTEGER :: & + & ji, & + & jj + INTEGER, DIMENSION(kdim) :: & + & indx + REAL(KIND=wp), DIMENSION(kdim,kdim) :: & + & zmat + REAL(KIND=wp) :: & + & zd + + ! Invert the matrix + DO jj = 1, kdim + DO ji = 1, kdim + pmatou(ji,jj) = 0.0_wp + zmat(ji,jj) = pmatin(ji,jj) + END DO + pmatou(jj,jj) = 1.0_wp + END DO + CALL lu_decomp( zmat, kdim, kdim, indx, zd ) + DO jj = 1, kdim + CALL lu_backsb( zmat, kdim, kdim, indx, pmatou(1,jj) ) + END DO + + END SUBROUTINE lu_invmat + + SUBROUTINE lu_decomp( pmatin, kdim1, kdim2, kindex, pflt ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_decomp *** + !! + !! ** Purpose : Compute the LU decomposition of a matrix + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim1, & ! Array dimensions + & kdim2 + INTEGER, DIMENSION(kdim1), INTENT(OUT) :: & + & kindex + REAL(KIND=wp), INTENT(OUT) :: & + & pflt + REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(INOUT) :: & + & pmatin + + !! * Local declarations + INTEGER, PARAMETER :: & + & jpmax = 100 + REAL(KIND=wp), PARAMETER :: & + & pptiny = 1.0e-20_wp + REAL(KIND=wp), DIMENSION(jpmax) :: & + & zvv + INTEGER :: & + & ji, & + & jj, & + & jk + INTEGER :: & + & imax + REAL(KIND=wp) :: & + & zsum, & + & zdum, & + & zaamax + + imax = -1 + ! Main computation + pflt = 1.0_wp + DO ji = 1, kdim1 + zaamax = 0.0_wp + DO jj = 1, kdim1 + IF ( ABS( pmatin(ji,jj) ) > zaamax ) zaamax = ABS( pmatin(ji,jj) ) + END DO + IF ( zaamax == 0.0_wp ) THEN + CALL ctl_stop( 'singular matrix' ) + ENDIF + zvv(ji) = 1.0_wp / zaamax + END DO + DO jj = 1, kdim1 + DO ji = 1, jj-1 + zsum = pmatin(ji,jj) + DO jk = 1, ji-1 + zsum = zsum - pmatin(ji,jk) * pmatin(jk,jj) + END DO + pmatin(ji,jj) = zsum + END DO + zaamax = 0.0_wp + DO ji = jj, kdim1 + zsum = pmatin(ji,jj) + DO jk = 1, jj-1 + zsum = zsum - pmatin(ji,jk) * pmatin(jk,jj) + END DO + pmatin(ji,jj) = zsum + zdum = zvv(ji) * ABS( zsum ) + IF ( zdum >= zaamax ) THEN + imax = ji + zaamax = zdum + ENDIF + END DO + IF ( jj /= imax ) THEN + DO jk = 1, kdim1 + zdum = pmatin(imax,jk) + pmatin(imax,jk) = pmatin(jj,jk) + pmatin(jj,jk) = zdum + END DO + pflt = -pflt + zvv(imax) = zvv(jj) + ENDIF + kindex(jj) = imax + IF ( pmatin(jj,jj) == 0.0_wp ) pmatin(jj,jj) = pptiny + IF ( jj /= kdim1 ) THEN + zdum = 1.0_wp / pmatin(jj,jj) + DO ji = jj+1, kdim1 + pmatin(ji,jj) = pmatin(ji,jj) * zdum + END DO + ENDIF + END DO + + END SUBROUTINE lu_decomp + + SUBROUTINE lu_backsb( pmat, kdim1, kdim2, kindex, pvect ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_backsb *** + !! + !! ** Purpose : Back substitution + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim1, & ! Array dimensions + & kdim2 + INTEGER, DIMENSION(kdim1), INTENT(IN) :: & + & kindex + REAL(KIND=wp), DIMENSION(kdim1), INTENT(INOUT) :: & + & pvect + REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(IN) :: & + & pmat + + !! * Local declarations + INTEGER :: & + & ji, & + & jii, & + & jj, & + & jll + REAL(KIND=wp) :: & + & zsum + + ! Main computation + jii = 0 + DO ji = 1, kdim1 + jll = kindex(ji) + zsum = pvect(jll) + pvect(jll) = pvect(ji) + IF ( jii /= 0 ) THEN + DO jj = jii, ji-1 + zsum = zsum - pmat(ji,jj) * pvect(jj) + END DO + ELSEIF ( zsum /= 0.0_wp ) THEN + jii = ji + ENDIF + pvect(ji) = zsum + END DO + DO ji = kdim1, 1, -1 + zsum = pvect(ji) + DO jj = ji+1, kdim1 + zsum = zsum - pmat(ji,jj) * pvect(jj) + END DO + pvect(ji) = zsum / pmat(ji,ji) + END DO + + END SUBROUTINE lu_backsb + +END MODULE obs_inter_h2d diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_inter_sup.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_inter_sup.f90 new file mode 100644 index 0000000000000000000000000000000000000000..79416f93ccc588577a33df55e5beffc0c8339863 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_inter_sup.f90 @@ -0,0 +1,398 @@ + + + + + + + + + + + + + +MODULE obs_inter_sup + !!===================================================================== + !! *** MODULE obs_inter_sup *** + !! Observation diagnostics: Support for interpolation + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_int_comm_3d : Get 3D interpolation stencil + !! obs_int_comm_2d : Get 2D interpolation stencil + !!--------------------------------------------------------------------- + !! * Modules used + USE par_kind ! Precision variables + USE dom_oce ! Domain variables + USE mpp_map ! Map of processor points + USE lib_mpp ! MPP stuff + USE obs_mpp ! MPP stuff for observations + USE obs_grid ! Grid tools + USE in_out_manager ! I/O stuff + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_int_comm_3d, & ! Get 3D interpolation stencil + & obs_int_comm_2d ! Get 2D interpolation stencil + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_inter_sup.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & + & pval, pgval, kproc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_int_comm_3d *** + !! + !! ** Purpose : Get 3D interpolation stencil + !! + !! ** Method : Either on-demand communication with + !! obs_int_comm_3d_global + !! or local memory with + !! obs_int_comm_3D_local + !! depending on ln_global_grid + !! + !! ** Action : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil + INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil + INTEGER, INTENT(IN) :: kobs ! Local number of observations + INTEGER, INTENT(IN) :: kpi ! Number of points in i direction + INTEGER, INTENT(IN) :: kpj ! Number of points in j direction + INTEGER, INTENT(IN) :: kpk ! Number of levels + INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kgrdi, & ! i,j indicies for each stencil + & kgrdj + INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kproc ! Precomputed processor for each i,j,iobs points + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& + & pval ! Local 3D array to extract data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point + !! * Local declarations + + IF (ln_grid_global) THEN + + IF (PRESENT(kproc)) THEN + + CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & + & kgrdj, pval, pgval, kproc=kproc ) + + ELSE + + CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & + & kgrdj, pval, pgval ) + + ENDIF + + ELSE + + CALL obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & + & pval, pgval ) + + ENDIF + + END SUBROUTINE obs_int_comm_3d + + SUBROUTINE obs_int_comm_2d( kptsi, kptsj, kobs, kpi, kpj, kgrdi, kgrdj, pval, pgval, & + & kproc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_int_comm_2d *** + !! + !! ** Purpose : Get 2D interpolation stencil + !! + !! ** Method : Call to obs_int_comm_3d + !! + !! ** Action : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! + !! * Arguments + INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil + INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil + INTEGER, INTENT(IN) :: kobs ! Local number of observations + INTEGER, INTENT(IN) :: kpi ! Number of model grid points in i direction + INTEGER, INTENT(IN) :: kpj ! Number of model grid points in j direction + INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kgrdi, & ! i,j indicies for each stencil + & kgrdj + INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kproc ! Precomputed processor for each i,j,iobs points + REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) ::& + & pval ! Local 3D array to extra data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point + !! * Local declarations + REAL(KIND=wp), DIMENSION(jpi,jpj,1) :: zval + REAL(KIND=wp), DIMENSION(kptsi,kptsj,1,kobs) ::& + & zgval + + ! Set up local "3D" buffer + + zval(:,:,1) = pval(:,:) + + ! Call the 3D version + + IF (PRESENT(kproc)) THEN + + CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & + & zgval, kproc=kproc ) + ELSE + + CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & + & zgval ) + + ENDIF + + ! Copy "3D" data back to 2D + + pgval(:,:,:) = zgval(:,:,1,:) + + END SUBROUTINE obs_int_comm_2d + + SUBROUTINE obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & + & pval, pgval, kproc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_int_comm_3d_global *** + !! + !! ** Purpose : Get 3D interpolation stencil (global version) + !! + !! ** Method : On-demand communication where each processor send its + !! list of (i,j) of points to all processors and receive + !! the corresponding values + !! + !! ** Action : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil + INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil + INTEGER, INTENT(IN) :: kobs ! Local number of observations + INTEGER, INTENT(IN) :: kpi ! Number of model points in i direction + INTEGER, INTENT(IN) :: kpj ! Number of model points in j direction + INTEGER, INTENT(IN) :: kpk ! Number of levels + INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kgrdi, & ! i,j indicies for each stencil + & kgrdj + INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kproc ! Precomputed processor for each i,j,iobs points + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& + & pval ! Local 3D array to extract data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point + !! * Local declarations + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & + & zsend, & + & zrecv + INTEGER, DIMENSION(:), ALLOCATABLE :: & + & igrdij_send, & + & igrdij_recv + INTEGER, DIMENSION(kptsi,kptsj,kobs) :: & + & iorder, & + & iproc + INTEGER :: nplocal(jpnij) + INTEGER :: npglobal(jpnij) + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jp + INTEGER :: jobs + INTEGER :: it + INTEGER :: itot + INTEGER :: ii + INTEGER :: ij + + ! Check valid points + + IF ( ( MAXVAL(kgrdi) > jpiglo ) .OR. ( MINVAL(kgrdi) < 1 ) .OR. & + & ( MAXVAL(kgrdj) > jpjglo ) .OR. ( MINVAL(kgrdj) < 1 ) ) THEN + + CALL ctl_stop( 'Error in obs_int_comm_3d_global', & + & 'Point outside global domain' ) + + ENDIF + + ! Count number of points on each processors + + nplocal(:) = 0 + IF (PRESENT(kproc)) THEN + iproc(:,:,:) = kproc(:,:,:) + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + nplocal(iproc(ji,jj,jobs)) = nplocal(iproc(ji,jj,jobs)) + 1 + END DO + END DO + END DO + ELSE + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + iproc(ji,jj,jobs) = mppmap(kgrdi(ji,jj,jobs),& + & kgrdj(ji,jj,jobs)) + nplocal(iproc(ji,jj,jobs)) = nplocal(iproc(ji,jj,jobs)) + 1 + END DO + END DO + END DO + ENDIF + + ! Send local number of points and receive points on current domain + + CALL mpp_alltoall_int( 1, nplocal, npglobal ) + + ! Allocate message parsing workspace + + itot = SUM(npglobal) + + ALLOCATE( & + & igrdij_send(kptsi*kptsj*kobs*2), & + & igrdij_recv(itot*2), & + & zsend(kpk,itot), & + & zrecv(kpk,kptsi*kptsj*kobs) & + & ) + + ! Pack buffers for list of points + + it = 0 + DO jp = 1, jpnij + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + IF ( iproc(ji,jj,jobs) == jp ) THEN + it = it + 1 + iorder(ji,jj,jobs) = it + igrdij_send(2*it-1) = kgrdi(ji,jj,jobs) + igrdij_send(2*it ) = kgrdj(ji,jj,jobs) + ENDIF + END DO + END DO + END DO + END DO + + ! Send and recieve buffers for list of points + + CALL mpp_alltoallv_int( igrdij_send, kptsi*kptsj*kobs*2, nplocal(:)*2, & + & igrdij_recv, itot*2, npglobal(:)*2 ) + + ! Pack interpolation data to be sent + + DO ji = 1, itot + ii = mi1(igrdij_recv(2*ji-1)) + ij = mj1(igrdij_recv(2*ji)) + DO jk = 1, kpk + zsend(jk,ji) = pval(ii,ij,jk) + END DO + END DO + + ! Re-adjust sizes + + nplocal(:) = kpk*nplocal(:) + npglobal(:) = kpk*npglobal(:) + + + ! Send and receive data for interpolation stencil + + CALL mpp_alltoallv_real( zsend, kpk*itot, npglobal, & + & zrecv, kpk*kptsi*kptsj*kobs, nplocal ) + + ! Copy the received data into output data structure + + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + it = iorder(ji,jj,jobs) + DO jk = 1, kpk + pgval(ji,jj,jk,jobs) = zrecv(jk,it) + END DO + END DO + END DO + END DO + + ! Deallocate message parsing workspace + + DEALLOCATE( & + & igrdij_send, & + & igrdij_recv, & + & zsend, & + & zrecv & + & ) + + END SUBROUTINE obs_int_comm_3d_global + + SUBROUTINE obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & + & pval, pgval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_int_comm_3d_global *** + !! + !! ** Purpose : Get 3D interpolation stencil (global version) + !! + !! ** Method : On-demand communication where each processor send its + !! list of (i,j) of points to all processors and receive + !! the corresponding values + !! + !! ** Action : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil + INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil + INTEGER, INTENT(IN) :: kobs ! Local number of observations + INTEGER, INTENT(IN) :: kpi ! Number of model points in i direction + INTEGER, INTENT(IN) :: kpj ! Number of model points in j direction + INTEGER, INTENT(IN) :: kpk ! Number of levels + INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kgrdi, & ! i,j indicies for each stencil + & kgrdj + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& + & pval ! Local 3D array to extract data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point + !! * Local declarations + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jobs + + ! Check valid points + + IF ( ( MAXVAL(kgrdi) > jpi ) .OR. ( MINVAL(kgrdi) < 1 ) .OR. & + & ( MAXVAL(kgrdj) > jpj ) .OR. ( MINVAL(kgrdj) < 1 ) ) THEN + + CALL ctl_stop( 'Error in obs_int_comm_3d_local', & + & 'Point outside local domain' ) + + ENDIF + + ! Copy local data + + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + DO jk = 1, kpk + pgval(ji,jj,jk,jobs) = & + & pval(kgrdi(ji,jj,jobs),kgrdj(ji,jj,jobs),jk) + END DO + END DO + END DO + END DO + + END SUBROUTINE obs_int_comm_3d_local + +END MODULE obs_inter_sup diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_inter_z1d.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_inter_z1d.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7a0f9cffa3ef9a0b9fbe35f64d123712a4f6a594 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_inter_z1d.f90 @@ -0,0 +1,240 @@ + + + + + + + + + + + + + +MODULE obs_inter_z1d + !!====================================================================== + !! *** MODULE obs_inter_z1d *** + !! Observation diagnostics: Perform the vertical interpolation + !! from model grid to observation location + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_int_z1d : Vertical interpolation to the observation point + !! obs_int_z1d_spl : Compute the vertical 2nd derivative of the + !! interpolating function for a cubic spline (n1dint=1) + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_int_z1d, & ! Vertical interpolation to the observation pt. + & obs_int_z1d_spl ! Compute the vertical 2nd derivative of the + ! interpolating function used with a cubic spline + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_inter_z1d.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obsinter_z1d.h90 13226 2020-07-02 14:24:31Z orioltp $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE obs_int_z1d( kpk, kkco, k1dint, kdep, & + & pobsdep, pobsk, pobs2k, & + & pobs, pdep, pobsmask ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_z1d *** + !! + !! ** Purpose : Vertical interpolation to the observation point. + !! + !! ** Method : If k1dint = 0 then use linear interpolation. + !! If k1dint = 1 then use cubic spline interpolation. + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 97-11 (A. Weaver, S. Ricci, N. Daget) + !! ! 06-03 (G. Smith) Conversion to F90 for use with NEMOVAR + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-01 (K. Mogensen) Use profile rather than single level + !!--------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kpk ! Number of vertical levels + INTEGER, INTENT(IN) :: k1dint ! 0 = linear; 1 = cubic spline interpolation + INTEGER, INTENT(IN) :: kdep ! Number of levels in profile + INTEGER, INTENT(IN), DIMENSION(kdep) :: & + & kkco ! Array indicies for interpolation + REAL(KIND=wp), INTENT(IN), DIMENSION(kdep) :: & + & pobsdep ! Depth of the observation + REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & + & pobsk, & ! Model profile at a given (lon,lat) + & pobs2k, & ! 2nd derivative of the interpolating function + & pdep, & ! Model depth array + & pobsmask ! Vertical mask + REAL(KIND=wp), INTENT(OUT), DIMENSION(kdep) :: & + & pobs ! Model equivalent at observation point + + !! * Local declarations + REAL(KIND=wp) :: z1dm ! Distance above and below obs to model grid points + REAL(KIND=wp) :: z1dp + REAL(KIND=wp) :: zsum ! Dummy variables for computation + REAL(KIND=wp) :: zsum2 + INTEGER :: jdep ! Observation depths loop variable + + !------------------------------------------------------------------------ + ! Loop over all observation depths + !------------------------------------------------------------------------ + + DO jdep = 1, kdep + + !--------------------------------------------------------------------- + ! Initialization + !--------------------------------------------------------------------- + z1dm = ( pdep(kkco(jdep)) - pobsdep(jdep) ) + z1dp = ( pobsdep(jdep) - pdep(kkco(jdep)-1) ) + + ! If kkco(jdep) is masked then set pobs(jdep) to the lowest value located above bathymetry + IF ( pobsmask(kkco(jdep)) == 0.0_wp ) THEN + pobs(jdep) = pobsk(kkco(jdep)-1) + ELSE + zsum = z1dm + z1dp + + IF ( k1dint == 0 ) THEN + + !----------------------------------------------------------------- + ! Linear interpolation + !----------------------------------------------------------------- + pobs(jdep) = ( z1dm * pobsk(kkco(jdep)-1) & + & + z1dp * pobsk(kkco(jdep) ) ) / zsum + + ELSEIF ( k1dint == 1 ) THEN + + !----------------------------------------------------------------- + ! Cubic spline interpolation + !----------------------------------------------------------------- + zsum2 = zsum * zsum + pobs(jdep) = ( z1dm * pobsk (kkco(jdep)-1) & + & + z1dp * pobsk (kkco(jdep) ) & + & + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) & + & + z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep) ) & + & ) / 6.0_wp & + & ) / zsum + + ENDIF + ENDIF + END DO + + END SUBROUTINE obs_int_z1d + + SUBROUTINE obs_int_z1d_spl( kpk, pobsk, pobs2k, & + & pdep, pobsmask ) + !!-------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_z1d_spl *** + !! + !! ** Purpose : Compute the local vector of vertical second-derivatives + !! of the interpolating function used with a cubic spline. + !! + !! ** Method : + !! + !! Top and bottom boundary conditions on the 2nd derivative are + !! set to zero. + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 01-11 (A. Weaver, S. Ricci, N. Daget) + !! ! 06-03 (G. Smith) Conversion to F90 for use with NEMOVAR + !! ! 06-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kpk ! Number of vertical levels + REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & + & pobsk, & ! Model profile at a given (lon,lat) + & pdep, & ! Model depth array + & pobsmask ! Vertical mask + REAL(KIND=wp), INTENT(OUT), DIMENSION(kpk) :: & + & pobs2k ! 2nd derivative of the interpolating function + + !! * Local declarations + INTEGER :: jk + REAL(KIND=wp) :: za + REAL(KIND=wp) :: zb + REAL(KIND=wp) :: zc + REAL(KIND=wp) :: zpa + REAL(KIND=wp) :: zkm + REAL(KIND=wp) :: zkp + REAL(KIND=wp) :: zk + REAL(KIND=wp), DIMENSION(kpk-1) :: & + & zs, & + & zp, & + & zu, & + & zv + + !----------------------------------------------------------------------- + ! Matrix initialisation + !----------------------------------------------------------------------- + zs(1) = 0.0_wp + zp(1) = 0.0_wp + zv(1) = -0.5_wp + DO jk = 2, kpk-1 + zs(jk) = ( pdep(jk ) - pdep(jk-1) ) & + & / ( pdep(jk+1) - pdep(jk-1) ) + zp(jk) = zs(jk) * zv(jk-1) + 2.0_wp + zv(jk) = ( zs(jk) - 1.0_wp ) / zp(jk) + END DO + + !----------------------------------------------------------------------- + ! Solution of the tridiagonal system + !----------------------------------------------------------------------- + + ! Top boundary condition + zu(1) = 0.0_wp + + DO jk = 2, kpk-1 + za = pdep(jk+1) - pdep(jk-1) + zb = pdep(jk+1) - pdep(jk ) + zc = pdep(jk ) - pdep(jk-1) + + zpa = 6.0_wp / ( zp(jk) * za ) + zkm = zpa / zc + zkp = zpa / zb + zk = - ( zkm + zkp ) + + zu(jk) = pobsk(jk+1) * zkp & + & + pobsk(jk ) * zk & + & + pobsk(jk-1) * zkm & + & + zu(jk-1) * ( -zs(jk) / zp(jk) ) + END DO + + !----------------------------------------------------------------------- + ! Second derivative + !----------------------------------------------------------------------- + pobs2k(kpk) = 0.0_wp + + ! Bottom boundary condition + DO jk = kpk-1, 1, -1 + pobs2k(jk) = zv(jk) * pobs2k(jk+1) + zu(jk) + IF ( pobsmask(jk+1) == 0.0_wp ) pobs2k(jk) = 0.0_wp + END DO + + END SUBROUTINE obs_int_z1d_spl + +END MODULE obs_inter_z1d diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_mpp.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_mpp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..bb4e08234a74c4763a23d86f7d5ee7386e1df024 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_mpp.f90 @@ -0,0 +1,403 @@ + + + + + + + + + + + + + +MODULE obs_mpp + !!====================================================================== + !! *** MODULE obs_mpp *** + !! Observation diagnostics: Various MPP support routines + !!====================================================================== + !! History : 2.0 ! 2006-03 (K. Mogensen) Original code + !! - ! 2006-05 (K. Mogensen) Reformatted + !! - ! 2008-01 (K. Mogensen) add mpp_global_max + !! 3.6 ! 2015-01 (J. Waters) obs_mpp_find_obs_proc + !! rewritten to avoid global arrays + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! obs_mpp_bcast_integer : Broadcast an integer array from a processor to all processors + !! obs_mpp_max_integer : Find maximum on all processors of each value in an integer on all processors + !! obs_mpp_find_obs_proc : Find processors which should hold the observations, avoiding global arrays + !! obs_mpp_sum_integers : Sum an integer array from all processors + !! obs_mpp_sum_integer : Sum an integer from all processors + !!---------------------------------------------------------------------- + USE mpp_map, ONLY : mppmap + USE in_out_manager + USE lib_mpp, ONLY : mpi_comm_oce ! MPP library + IMPLICIT NONE + PRIVATE + + PUBLIC obs_mpp_bcast_integer, & !: Broadcast an integer array from a proc to all procs + & obs_mpp_max_integer, & !: Find maximum across processors in an integer array + & obs_mpp_find_obs_proc, & !: Find processors which should hold the observations + & obs_mpp_sum_integers, & !: Sum an integer array from all processors + & obs_mpp_sum_integer, & !: Sum an integer from all processors + & mpp_alltoall_int, & + & mpp_alltoallv_int, & + & mpp_alltoallv_real, & + & mpp_global_max + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_mpp.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE obs_mpp_bcast_integer( kvals, kno, kroot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_mpp_bcast_integer *** + !! + !! ** Purpose : Send array kvals to all processors + !! + !! ** Method : MPI broadcast + !! + !! ** Action : This does only work for MPI. + !! MPI_COMM_OCE needs to be replace for OASIS4.! + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kno ! Number of elements in array + INTEGER , INTENT(in ) :: kroot ! Processor to send data + INTEGER, DIMENSION(kno), INTENT(inout) :: kvals ! Array to send on kroot, receive for non-kroot + ! + ! + INTEGER :: ierr + ! +INCLUDE 'mpif.h' + !!---------------------------------------------------------------------- + + ! Call the MPI library to broadcast data + CALL mpi_bcast( kvals, kno, mpi_integer, & + & kroot, mpi_comm_oce, ierr ) + ! + END SUBROUTINE obs_mpp_bcast_integer + + + SUBROUTINE obs_mpp_max_integer( kvals, kno ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_mpp_bcast_integer *** + !! + !! ** Purpose : Find maximum across processors in an integer array. + !! + !! ** Method : MPI all reduce. + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! MPI_COMM_OCE needs to be replace for OASIS4.! + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kno ! Number of elements in array + INTEGER, DIMENSION(kno), INTENT(inout) :: kvals ! Array to send on kroot, receive for non-kroot + ! + ! + INTEGER :: ierr + INTEGER, DIMENSION(kno) :: ivals + ! +INCLUDE 'mpif.h' + !!---------------------------------------------------------------------- + + ! Call the MPI library to find the maximum across processors + CALL mpi_allreduce( kvals, ivals, kno, mpi_integer, & + & mpi_max, mpi_comm_oce, ierr ) + kvals(:) = ivals(:) + END SUBROUTINE obs_mpp_max_integer + + + SUBROUTINE obs_mpp_find_obs_proc( kobsp,kno ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_mpp_find_obs_proc *** + !! + !! ** Purpose : From the array kobsp containing the results of the + !! grid search on each processor the processor return a + !! decision of which processors should hold the observation. + !! + !! ** Method : Synchronize the processor number for each obs using + !! obs_mpp_max_integer. If an observation exists on two + !! processors it will be allocated to the lower numbered + !! processor. + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kno + INTEGER, DIMENSION(kno), INTENT(inout) :: kobsp + ! + ! + ! + INTEGER :: ji, isum + INTEGER, DIMENSION(kno) :: iobsp + !! + !! + + iobsp(:)=kobsp(:) + + WHERE( iobsp(:) == -1 ) + iobsp(:) = 9999999 + END WHERE + + iobsp(:)=-1*iobsp(:) + + CALL obs_mpp_max_integer( iobsp, kno ) + + kobsp(:)=-1*iobsp(:) + + isum=0 + DO ji = 1, kno + IF ( kobsp(ji) == 9999999 ) THEN + isum=isum+1 + kobsp(ji)=-1 + ENDIF + ENDDO + + + IF ( isum > 0 ) THEN + IF (lwp) WRITE(numout,*) isum, ' observations failed the grid search.' + IF (lwp) WRITE(numout,*)'If ln_grid_search_lookup=.TRUE., try reducing grid_search_res' + ENDIF + + + END SUBROUTINE obs_mpp_find_obs_proc + + + SUBROUTINE obs_mpp_sum_integers( kvalsin, kvalsout, kno ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_mpp_sum_integers *** + !! + !! ** Purpose : Sum an integer array. + !! + !! ** Method : MPI all reduce. + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kno + INTEGER, DIMENSION(kno), INTENT(in ) :: kvalsin + INTEGER, DIMENSION(kno), INTENT( out) :: kvalsout + ! + ! + INTEGER :: ierr + ! +INCLUDE 'mpif.h' + !!---------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + ! Call the MPI library to find the sum across processors + !----------------------------------------------------------------------- + CALL mpi_allreduce( kvalsin, kvalsout, kno, mpi_integer, & + & mpi_sum, mpi_comm_oce, ierr ) + ! + END SUBROUTINE obs_mpp_sum_integers + + + SUBROUTINE obs_mpp_sum_integer( kvalin, kvalout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_mpp_sum_integers *** + !! + !! ** Purpose : Sum a single integer + !! + !! ** Method : MPI all reduce. + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kvalin + INTEGER, INTENT( out) :: kvalout + ! + ! + INTEGER :: ierr + ! +INCLUDE 'mpif.h' + !!---------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + ! Call the MPI library to find the sum across processors + !----------------------------------------------------------------------- + CALL mpi_allreduce( kvalin, kvalout, 1, mpi_integer, & + & mpi_sum, mpi_comm_oce, ierr ) + ! + END SUBROUTINE obs_mpp_sum_integer + + + SUBROUTINE mpp_global_max( pval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_global_or *** + !! + !! ** Purpose : Get the maximum value across processors for a global + !! real array + !! + !! ** Method : MPI allreduce + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + REAL(KIND=wp), DIMENSION(jpiglo,jpjglo), INTENT(inout) :: pval + ! + INTEGER :: ierr + ! + ! +INCLUDE 'mpif.h' + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: zcp + !!---------------------------------------------------------------------- + + ! Copy data for input to MPI + + ALLOCATE( & + & zcp(jpiglo,jpjglo) & + & ) + zcp(:,:) = pval(:,:) + + ! Call the MPI library to find the coast lines globally + + CALL mpi_allreduce( zcp, pval, jpiglo*jpjglo, mpi_double_precision, & + & mpi_max, mpi_comm_oce, ierr ) + + DEALLOCATE( & + & zcp & + & ) + + ! + END SUBROUTINE mpp_global_max + + + SUBROUTINE mpp_alltoall_int( kno, kvalsin, kvalsout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_allgatherv *** + !! + !! ** Purpose : all to all. + !! + !! ** Method : MPI alltoall + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kno + INTEGER, DIMENSION(kno*jpnij), INTENT(in ) :: kvalsin + INTEGER, DIMENSION(kno*jpnij), INTENT( out) :: kvalsout + !! + INTEGER :: ierr + ! + ! +INCLUDE 'mpif.h' + !----------------------------------------------------------------------- + ! Call the MPI library to do the all to all operation of the data + !----------------------------------------------------------------------- + CALL mpi_alltoall( kvalsin, kno, mpi_integer, & + & kvalsout, kno, mpi_integer, & + & mpi_comm_oce, ierr ) + ! + END SUBROUTINE mpp_alltoall_int + + + SUBROUTINE mpp_alltoallv_int( kvalsin, knoin , kinv , kvalsout, & + & knoout, koutv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_alltoallv_int *** + !! + !! ** Purpose : all to all (integer version). + !! + !! ** Method : MPI alltoall + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: knoin + INTEGER , INTENT(in) :: knoout + INTEGER, DIMENSION(jpnij), INTENT(IN) :: kinv, koutv + INTEGER, DIMENSION(knoin) , INTENT(in ) :: kvalsin + INTEGER, DIMENSION(knoout), INTENT( out) :: kvalsout + !! + INTEGER :: ierr + INTEGER :: jproc + ! + ! +INCLUDE 'mpif.h' + INTEGER, DIMENSION(jpnij) :: irdsp, isdsp + !----------------------------------------------------------------------- + ! Compute displacements + !----------------------------------------------------------------------- + irdsp(1) = 0 + isdsp(1) = 0 + DO jproc = 2, jpnij + isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1) + irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1) + END DO + !----------------------------------------------------------------------- + ! Call the MPI library to do the all to all operation of the data + !----------------------------------------------------------------------- + CALL mpi_alltoallv( kvalsin, kinv, isdsp, mpi_integer, & + & kvalsout, koutv, irdsp, mpi_integer, & + & mpi_comm_oce, ierr ) + ! + END SUBROUTINE mpp_alltoallv_int + + + SUBROUTINE mpp_alltoallv_real( pvalsin, knoin , kinv , pvalsout, & + & knoout, koutv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_alltoallv_real *** + !! + !! ** Purpose : all to all (integer version). + !! + !! ** Method : MPI alltoall + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: knoin + INTEGER , INTENT(in ) :: knoout + INTEGER , DIMENSION(jpnij) :: kinv, koutv + REAL(wp), DIMENSION(knoin) , INTENT(in ) :: pvalsin + REAL(wp), DIMENSION(knoout), INTENT( out) :: pvalsout + !! + INTEGER :: ierr + INTEGER :: jproc + ! + ! +INCLUDE 'mpif.h' + INTEGER, DIMENSION(jpnij) :: irdsp, isdsp + !!---------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + ! Compute displacements + !----------------------------------------------------------------------- + irdsp(1) = 0 + isdsp(1) = 0 + DO jproc = 2, jpnij + isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1) + irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1) + END DO + !----------------------------------------------------------------------- + ! Call the MPI library to do the all to all operation of the data + !----------------------------------------------------------------------- + CALL mpi_alltoallv( pvalsin, kinv, isdsp, mpi_double_precision, & + & pvalsout, koutv, irdsp, mpi_double_precision, & + & mpi_comm_oce, ierr ) + ! + END SUBROUTINE mpp_alltoallv_real + + !!====================================================================== +END MODULE obs_mpp diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_oper.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_oper.f90 new file mode 100644 index 0000000000000000000000000000000000000000..24d82e8d46ca8708252136a09573a77d437b00ea --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_oper.f90 @@ -0,0 +1,796 @@ + + + + + + + + + + + + + +MODULE obs_oper + !!====================================================================== + !! *** MODULE obs_oper *** + !! Observation diagnostics: Observation operators for various observation + !! types + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_prof_opt : Compute the model counterpart of profile data + !! obs_surf_opt : Compute the model counterpart of surface data + !!---------------------------------------------------------------------- + USE obs_inter_sup ! Interpolation support + USE obs_inter_h2d, ONLY : obs_int_h2d, obs_int_h2d_init ! Horizontal interpolation to the obs pt + USE obs_averg_h2d, ONLY : obs_avg_h2d, obs_avg_h2d_init, obs_max_fpsize ! Horizontal averaging to the obs footprint + USE obs_inter_z1d, ONLY : obs_int_z1d, obs_int_z1d_spl ! Vertical interpolation to the obs pt + USE obs_const , ONLY : obfillflt ! Obs fill value + USE dom_oce, ONLY : glamt, glamf, gphit, gphif ! lat/lon of ocean grid-points + USE lib_mpp, ONLY : ctl_warn, ctl_stop ! Warning and stopping routines + USE sbcdcy, ONLY : sbc_dcy, nday_qsr ! For calculation of where it is night-time + USE obs_grid, ONLY : obs_level_search + ! + USE par_kind , ONLY : wp ! Precision variables + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC obs_prof_opt !: Compute the model counterpart of profile obs + PUBLIC obs_surf_opt !: Compute the model counterpart of surface obs + + INTEGER, PARAMETER, PUBLIC :: imaxavtypes = 20 !: Max number of daily avgd obs types + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_oper.F90 14056 2020-12-03 14:08:29Z ayoung $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & + & kit000, kdaystp, kvar, & + & pvar, pgdept, pgdepw, & + & pmask, & + & plam, pphi, & + & k1dint, k2dint, kdailyavtypes ) + !!----------------------------------------------------------------------- + !! *** ROUTINE obs_pro_opt *** + !! + !! ** Purpose : Compute the model counterpart of profiles + !! data by interpolating from the model grid to the + !! observation point. + !! + !! ** Method : Linearly interpolate to each observation point using + !! the model values at the corners of the surrounding grid box. + !! + !! First, a vertical profile of horizontally interpolated model + !! now values is computed at the obs (lon, lat) point. + !! Several horizontal interpolation schemes are available: + !! - distance-weighted (great circle) (k2dint = 0) + !! - distance-weighted (small angle) (k2dint = 1) + !! - bilinear (geographical grid) (k2dint = 2) + !! - bilinear (quadrilateral grid) (k2dint = 3) + !! - polynomial (quadrilateral grid) (k2dint = 4) + !! + !! Next, the vertical profile is interpolated to the + !! data depth points. Two vertical interpolation schemes are + !! available: + !! - linear (k1dint = 0) + !! - Cubic spline (k1dint = 1) + !! + !! For the cubic spline the 2nd derivative of the interpolating + !! polynomial is computed before entering the vertical interpolation + !! routine. + !! + !! If the logical is switched on, the model equivalent is + !! a daily mean model temperature field. So, we first compute + !! the mean, then interpolate only at the end of the day. + !! + !! Note: in situ temperature observations must be converted + !! to potential temperature (the model variable) prior to + !! assimilation. + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, S. Ricci, N. Daget) + !! ! 06-03 (G. Smith) NEMOVAR migration + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-01 (K. Mogensen) Merge of temperature and salinity + !! ! 07-03 (K. Mogensen) General handling of profiles + !! ! 15-02 (M. Martin) Combined routine for all profile types + !! ! 17-02 (M. Martin) Include generalised vertical coordinate changes + !!----------------------------------------------------------------------- + USE obs_profiles_def ! Definition of storage space for profile obs. + + IMPLICIT NONE + + TYPE(obs_prof), INTENT(inout) :: prodatqc ! Subset of profile data passing QC + INTEGER , INTENT(in ) :: kt ! Time step + INTEGER , INTENT(in ) :: kpi, kpj, kpk ! Model grid parameters + INTEGER , INTENT(in ) :: kit000 ! Number of the first time step (kit000-1 = restart time) + INTEGER , INTENT(in ) :: k1dint ! Vertical interpolation type (see header) + INTEGER , INTENT(in ) :: k2dint ! Horizontal interpolation type (see header) + INTEGER , INTENT(in ) :: kdaystp ! Number of time steps per day + INTEGER , INTENT(in ) :: kvar ! Number of variables in prodatqc + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar ! Model field + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask ! Land-sea mask + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam ! Model longitude + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi ! Model latitudes + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pgdept, pgdepw ! depth of T and W levels + INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: kdailyavtypes ! Types for daily averages + + !! * Local declarations + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jobs + INTEGER :: inrc + INTEGER :: ipro + INTEGER :: idayend + INTEGER :: ista + INTEGER :: iend + INTEGER :: iobs + INTEGER :: iin, ijn, ikn, ik ! looping indices over interpolation nodes + INTEGER :: inum_obs + INTEGER, DIMENSION(imaxavtypes) :: & + & idailyavtypes + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdi, & + & igrdj + INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic + + REAL(KIND=wp) :: zlam + REAL(KIND=wp) :: zphi + REAL(KIND=wp) :: zdaystp + REAL(KIND=wp), DIMENSION(kpk) :: & + & zobsk, & + & zobs2k + REAL(KIND=wp), DIMENSION(2,2,1) :: & + & zweig1, & + & zweig + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & + & zmask, & + & zint, & + & zinm, & + & zgdept, & + & zgdepw + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zglam, & + & zgphi + REAL(KIND=wp), DIMENSION(1) :: zmsk + REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner + + LOGICAL :: ld_dailyav + + !------------------------------------------------------------------------ + ! Local initialization + !------------------------------------------------------------------------ + ! Record and data counters + inrc = kt - kit000 + 2 + ipro = prodatqc%npstp(inrc) + + ! Daily average types + ld_dailyav = .FALSE. + IF ( PRESENT(kdailyavtypes) ) THEN + idailyavtypes(:) = kdailyavtypes(:) + IF ( ANY (idailyavtypes(:) /= -1) ) ld_dailyav = .TRUE. + ELSE + idailyavtypes(:) = -1 + ENDIF + + ! Daily means are calculated for values over timesteps: + ! [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ... + idayend = MOD( kt - kit000 + 1, kdaystp ) + + IF ( ld_dailyav ) THEN + + ! Initialize daily mean for first timestep of the day + IF ( idayend == 1 .OR. kt == 0 ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + prodatqc%vdmean(ji,jj,jk,kvar) = 0.0 + END DO ; END DO ; END DO + ENDIF + + DO jk = 1, jpk ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + ! Increment field 1 for computing daily mean + prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & + & + pvar(ji,jj,jk) + END DO ; END DO ; END DO + + ! Compute the daily mean at the end of day + zdaystp = 1.0 / REAL( kdaystp ) + IF ( idayend == 0 ) THEN + IF (lwp) WRITE(numout,*) 'Calculating prodatqc%vdmean on time-step: ',kt + CALL FLUSH(numout) + DO jk = 1, jpk ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & + & * zdaystp + END DO ; END DO ; END DO + ENDIF + + ENDIF + + ! Get the data for interpolation + ALLOCATE( & + & igrdi(2,2,ipro), & + & igrdj(2,2,ipro), & + & zglam(2,2,ipro), & + & zgphi(2,2,ipro), & + & zmask(2,2,kpk,ipro), & + & zint(2,2,kpk,ipro), & + & zgdept(2,2,kpk,ipro), & + & zgdepw(2,2,kpk,ipro) & + & ) + + DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro + iobs = jobs - prodatqc%nprofup + igrdi(1,1,iobs) = prodatqc%mi(jobs,kvar)-1 + igrdj(1,1,iobs) = prodatqc%mj(jobs,kvar)-1 + igrdi(1,2,iobs) = prodatqc%mi(jobs,kvar)-1 + igrdj(1,2,iobs) = prodatqc%mj(jobs,kvar) + igrdi(2,1,iobs) = prodatqc%mi(jobs,kvar) + igrdj(2,1,iobs) = prodatqc%mj(jobs,kvar)-1 + igrdi(2,2,iobs) = prodatqc%mi(jobs,kvar) + igrdj(2,2,iobs) = prodatqc%mj(jobs,kvar) + END DO + + ! Initialise depth arrays + zgdept(:,:,:,:) = 0.0 + zgdepw(:,:,:,:) = 0.0 + + CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, plam, zglam ) + CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, pphi, zgphi ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pmask, zmask ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pvar, zint ) + + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdept, zgdept ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdepw, zgdepw ) + + ! At the end of the day also get interpolated means + IF ( ld_dailyav .AND. idayend == 0 ) THEN + + ALLOCATE( zinm(2,2,kpk,ipro) ) + + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, & + & prodatqc%vdmean(:,:,:,kvar), zinm ) + + ENDIF + + ! Return if no observations to process + ! Has to be done after comm commands to ensure processors + ! stay in sync + IF ( ipro == 0 ) RETURN + + DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro + + iobs = jobs - prodatqc%nprofup + + IF ( kt /= prodatqc%mstp(jobs) ) THEN + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' E R R O R : Observation', & + & ' time step is not consistent with the', & + & ' model time step' + WRITE(numout,*) ' =========' + WRITE(numout,*) + WRITE(numout,*) ' Record = ', jobs, & + & ' kt = ', kt, & + & ' mstp = ', prodatqc%mstp(jobs), & + & ' ntyp = ', prodatqc%ntyp(jobs) + ENDIF + CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' ) + ENDIF + + zlam = prodatqc%rlam(jobs) + zphi = prodatqc%rphi(jobs) + + ! Horizontal weights + ! Masked values are calculated later. + IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN + + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam(:,:,iobs), zgphi(:,:,iobs), & + & zmask(:,:,1,iobs), zweig1, zmsk ) + + ENDIF + + IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN + + zobsk(:) = obfillflt + + IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN + + IF ( idayend == 0 ) THEN + ! Daily averaged data + + ! vertically interpolate all 4 corners + ista = prodatqc%npvsta(jobs,kvar) + iend = prodatqc%npvend(jobs,kvar) + inum_obs = iend - ista + 1 + ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) + + DO iin=1,2 + DO ijn=1,2 + + IF ( k1dint == 1 ) THEN + CALL obs_int_z1d_spl( kpk, & + & zinm(iin,ijn,:,iobs), & + & zobs2k, zgdept(iin,ijn,:,iobs), & + & zmask(iin,ijn,:,iobs)) + ENDIF + + CALL obs_level_search(kpk, & + & zgdept(iin,ijn,:,iobs), & + & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & + & iv_indic) + + CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & + & prodatqc%var(kvar)%vdep(ista:iend), & + & zinm(iin,ijn,:,iobs), & + & zobs2k, interp_corner(iin,ijn,:), & + & zgdept(iin,ijn,:,iobs), & + & zmask(iin,ijn,:,iobs)) + + ENDDO + ENDDO + + ENDIF !idayend + + ELSE + + ! Point data + + ! vertically interpolate all 4 corners + ista = prodatqc%npvsta(jobs,kvar) + iend = prodatqc%npvend(jobs,kvar) + inum_obs = iend - ista + 1 + ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) + DO iin=1,2 + DO ijn=1,2 + + IF ( k1dint == 1 ) THEN + CALL obs_int_z1d_spl( kpk, & + & zint(iin,ijn,:,iobs),& + & zobs2k, zgdept(iin,ijn,:,iobs), & + & zmask(iin,ijn,:,iobs)) + + ENDIF + + CALL obs_level_search(kpk, & + & zgdept(iin,ijn,:,iobs),& + & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & + & iv_indic) + + CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & + & prodatqc%var(kvar)%vdep(ista:iend), & + & zint(iin,ijn,:,iobs), & + & zobs2k,interp_corner(iin,ijn,:), & + & zgdept(iin,ijn,:,iobs), & + & zmask(iin,ijn,:,iobs) ) + + ENDDO + ENDDO + + ENDIF + + !------------------------------------------------------------- + ! Compute the horizontal interpolation for every profile level + !------------------------------------------------------------- + + DO ikn=1,inum_obs + iend=ista+ikn-1 + + zweig(:,:,1) = 0._wp + + ! This code forces the horizontal weights to be + ! zero IF the observation is below the bottom of the + ! corners of the interpolation nodes, Or if it is in + ! the mask. This is important for observations near + ! steep bathymetry + DO iin=1,2 + DO ijn=1,2 + + depth_loop: DO ik=kpk,2,-1 + IF(zmask(iin,ijn,ik-1,iobs ) > 0.9 )THEN + + zweig(iin,ijn,1) = & + & zweig1(iin,ijn,1) * & + & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & + & - prodatqc%var(kvar)%vdep(iend)),0._wp) + + EXIT depth_loop + + ENDIF + + ENDDO depth_loop + + ENDDO + ENDDO + + CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & + & prodatqc%var(kvar)%vmod(iend:iend) ) + + ! Set QC flag for any observations found below the bottom + ! needed as the check here is more strict than that in obs_prep + IF (sum(zweig) == 0.0_wp) prodatqc%var(kvar)%nvqc(iend:iend)=4 + + ENDDO + + DEALLOCATE(interp_corner,iv_indic) + + ENDIF + + ENDDO + + ! Deallocate the data for interpolation + DEALLOCATE( & + & igrdi, & + & igrdj, & + & zglam, & + & zgphi, & + & zmask, & + & zint, & + & zgdept, & + & zgdepw & + & ) + + ! At the end of the day also get interpolated means + IF ( ld_dailyav .AND. idayend == 0 ) THEN + DEALLOCATE( zinm ) + ENDIF + + IF ( kvar == prodatqc%nvar ) THEN + prodatqc%nprofup = prodatqc%nprofup + ipro + ENDIF + + END SUBROUTINE obs_prof_opt + + SUBROUTINE obs_surf_opt( surfdataqc, kt, kpi, kpj, & + & kit000, kdaystp, psurf, psurfmask, & + & k2dint, ldnightav, plamscl, pphiscl, & + & lindegrees ) + + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_surf_opt *** + !! + !! ** Purpose : Compute the model counterpart of surface + !! data by interpolating from the model grid to the + !! observation point. + !! + !! ** Method : Linearly interpolate to each observation point using + !! the model values at the corners of the surrounding grid box. + !! + !! The new model value is first computed at the obs (lon, lat) point. + !! + !! Several horizontal interpolation schemes are available: + !! - distance-weighted (great circle) (k2dint = 0) + !! - distance-weighted (small angle) (k2dint = 1) + !! - bilinear (geographical grid) (k2dint = 2) + !! - bilinear (quadrilateral grid) (k2dint = 3) + !! - polynomial (quadrilateral grid) (k2dint = 4) + !! + !! Two horizontal averaging schemes are also available: + !! - weighted radial footprint (k2dint = 5) + !! - weighted rectangular footprint (k2dint = 6) + !! + !! + !! ** Action : + !! + !! History : + !! ! 07-03 (A. Weaver) + !! ! 15-02 (M. Martin) Combined routine for surface types + !! ! 17-03 (M. Martin) Added horizontal averaging options + !!----------------------------------------------------------------------- + USE obs_surf_def ! Definition of storage space for surface observations + + IMPLICIT NONE + + TYPE(obs_surf), INTENT(INOUT) :: & + & surfdataqc ! Subset of surface data passing QC + INTEGER, INTENT(IN) :: kt ! Time step + INTEGER, INTENT(IN) :: kpi ! Model grid parameters + INTEGER, INTENT(IN) :: kpj + INTEGER, INTENT(IN) :: kit000 ! Number of the first time step + ! (kit000-1 = restart time) + INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day + INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) + REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & + & psurf, & ! Model surface field + & psurfmask ! Land-sea mask + LOGICAL, INTENT(IN) :: ldnightav ! Logical for averaging night-time data + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & ! Diameter in metres of obs footprint in E/W, N/S directions + & pphiscl ! This is the full width (rather than half-width) + LOGICAL, INTENT(IN) :: & + & lindegrees ! T=> plamscl and pphiscl are specified in degrees, F=> in metres + + !! * Local declarations + INTEGER :: ji + INTEGER :: jj + INTEGER :: jobs + INTEGER :: inrc + INTEGER :: isurf + INTEGER :: iobs + INTEGER :: imaxifp, imaxjfp + INTEGER :: imodi, imodj + INTEGER :: idayend + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdi, & + & igrdj, & + & igrdip1, & + & igrdjp1 + INTEGER, DIMENSION(:,:), SAVE, ALLOCATABLE :: & + & icount_night, & + & imask_night + REAL(wp) :: zlam + REAL(wp) :: zphi + REAL(wp), DIMENSION(1) :: zext, zobsmask + REAL(wp) :: zdaystp + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zweig, & + & zmask, & + & zsurf, & + & zsurfm, & + & zsurftmp, & + & zglam, & + & zgphi, & + & zglamf, & + & zgphif + + REAL(wp), DIMENSION(:,:), SAVE, ALLOCATABLE :: & + & zintmp, & + & zouttmp, & + & zmeanday ! to compute model sst in region of 24h daylight (pole) + + !------------------------------------------------------------------------ + ! Local initialization + !------------------------------------------------------------------------ + ! Record and data counters + inrc = kt - kit000 + 2 + isurf = surfdataqc%nsstp(inrc) + + ! Work out the maximum footprint size for the + ! interpolation/averaging in model grid-points - has to be even. + + CALL obs_max_fpsize( k2dint, plamscl, pphiscl, lindegrees, psurfmask, imaxifp, imaxjfp ) + + + IF ( ldnightav ) THEN + + ! Initialize array for night mean + IF ( kt == 0 ) THEN + ALLOCATE ( icount_night(kpi,kpj) ) + ALLOCATE ( imask_night(kpi,kpj) ) + ALLOCATE ( zintmp(kpi,kpj) ) + ALLOCATE ( zouttmp(kpi,kpj) ) + ALLOCATE ( zmeanday(kpi,kpj) ) + nday_qsr = -1 ! initialisation flag for nbc_dcy + ENDIF + + ! Night-time means are calculated for night-time values over timesteps: + ! [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ..... + idayend = MOD( kt - kit000 + 1, kdaystp ) + + ! Initialize night-time mean for first timestep of the day + IF ( idayend == 1 .OR. kt == 0 ) THEN + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + surfdataqc%vdmean(ji,jj) = 0.0 + zmeanday(ji,jj) = 0.0 + icount_night(ji,jj) = 0 + END DO ; END DO + ENDIF + + zintmp(:,:) = 0.0 + zouttmp(:,:) = sbc_dcy( zintmp(:,:), .TRUE. ) + imask_night(:,:) = INT( zouttmp(:,:) ) + + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ! Increment the temperature field for computing night mean and counter + surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & + & + psurf(ji,jj) * REAL( imask_night(ji,jj) ) + zmeanday(ji,jj) = zmeanday(ji,jj) + psurf(ji,jj) + icount_night(ji,jj) = icount_night(ji,jj) + imask_night(ji,jj) + END DO ; END DO + + ! Compute the night-time mean at the end of the day + zdaystp = 1.0 / REAL( kdaystp ) + IF ( idayend == 0 ) THEN + IF (lwp) WRITE(numout,*) 'Calculating surfdataqc%vdmean on time-step: ',kt + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ! Test if "no night" point + IF ( icount_night(ji,jj) > 0 ) THEN + surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & + & / REAL( icount_night(ji,jj) ) + ELSE + !At locations where there is no night (e.g. poles), + ! calculate daily mean instead of night-time mean. + surfdataqc%vdmean(ji,jj) = zmeanday(ji,jj) * zdaystp + ENDIF + END DO ; END DO + ENDIF + + ENDIF + + ! Get the data for interpolation + + ALLOCATE( & + & zweig(imaxifp,imaxjfp,1), & + & igrdi(imaxifp,imaxjfp,isurf), & + & igrdj(imaxifp,imaxjfp,isurf), & + & zglam(imaxifp,imaxjfp,isurf), & + & zgphi(imaxifp,imaxjfp,isurf), & + & zmask(imaxifp,imaxjfp,isurf), & + & zsurf(imaxifp,imaxjfp,isurf), & + & zsurftmp(imaxifp,imaxjfp,isurf), & + & zglamf(imaxifp+1,imaxjfp+1,isurf), & + & zgphif(imaxifp+1,imaxjfp+1,isurf), & + & igrdip1(imaxifp+1,imaxjfp+1,isurf), & + & igrdjp1(imaxifp+1,imaxjfp+1,isurf) & + & ) + + DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf + iobs = jobs - surfdataqc%nsurfup + DO ji = 0, imaxifp + imodi = surfdataqc%mi(jobs) - int(imaxifp/2) + ji - 1 + ! + !Deal with wrap around in longitude + IF ( imodi < 1 ) imodi = imodi + jpiglo + IF ( imodi > jpiglo ) imodi = imodi - jpiglo + ! + DO jj = 0, imaxjfp + imodj = surfdataqc%mj(jobs) - int(imaxjfp/2) + jj - 1 + !If model values are out of the domain to the north/south then + !set them to be the edge of the domain + IF ( imodj < 1 ) imodj = 1 + IF ( imodj > jpjglo ) imodj = jpjglo + ! + igrdip1(ji+1,jj+1,iobs) = imodi + igrdjp1(ji+1,jj+1,iobs) = imodj + ! + IF ( ji >= 1 .AND. jj >= 1 ) THEN + igrdi(ji,jj,iobs) = imodi + igrdj(ji,jj,iobs) = imodj + ENDIF + ! + END DO + END DO + END DO + + CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & + & igrdi, igrdj, glamt, zglam ) + CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & + & igrdi, igrdj, gphit, zgphi ) + CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & + & igrdi, igrdj, psurfmask, zmask ) + CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & + & igrdi, igrdj, psurf, zsurf ) + CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & + & igrdip1, igrdjp1, glamf, zglamf ) + CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & + & igrdip1, igrdjp1, gphif, zgphif ) + + ! At the end of the day get interpolated means + IF ( idayend == 0 .AND. ldnightav ) THEN + + ALLOCATE( & + & zsurfm(imaxifp,imaxjfp,isurf) & + & ) + + CALL obs_int_comm_2d( imaxifp,imaxjfp, isurf, kpi, kpj, igrdi, igrdj, & + & surfdataqc%vdmean(:,:), zsurfm ) + + ENDIF + + ! Loop over observations + DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf + + iobs = jobs - surfdataqc%nsurfup + + IF ( kt /= surfdataqc%mstp(jobs) ) THEN + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' E R R O R : Observation', & + & ' time step is not consistent with the', & + & ' model time step' + WRITE(numout,*) ' =========' + WRITE(numout,*) + WRITE(numout,*) ' Record = ', jobs, & + & ' kt = ', kt, & + & ' mstp = ', surfdataqc%mstp(jobs), & + & ' ntyp = ', surfdataqc%ntyp(jobs) + ENDIF + CALL ctl_stop( 'obs_surf_opt', 'Inconsistent time' ) + + ENDIF + + zlam = surfdataqc%rlam(jobs) + zphi = surfdataqc%rphi(jobs) + + IF ( ldnightav .AND. idayend == 0 ) THEN + ! Night-time averaged data + zsurftmp(:,:,iobs) = zsurfm(:,:,iobs) + ELSE + zsurftmp(:,:,iobs) = zsurf(:,:,iobs) + ENDIF + + IF ( k2dint <= 4 ) THEN + + ! Get weights to interpolate the model value to the observation point + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam(:,:,iobs), zgphi(:,:,iobs), & + & zmask(:,:,iobs), zweig, zobsmask ) + + ! Interpolate the model value to the observation point + CALL obs_int_h2d( 1, 1, zweig, zsurftmp(:,:,iobs), zext ) + + ELSE + + ! Get weights to average the model SLA to the observation footprint + CALL obs_avg_h2d_init( 1, 1, imaxifp, imaxjfp, k2dint, zlam, zphi, & + & zglam(:,:,iobs), zgphi(:,:,iobs), & + & zglamf(:,:,iobs), zgphif(:,:,iobs), & + & zmask(:,:,iobs), plamscl, pphiscl, & + & lindegrees, zweig ) + + ! Average the model SST to the observation footprint + CALL obs_avg_h2d( 1, 1, imaxifp, imaxjfp, & + & zweig, zsurftmp(:,:,iobs), zext ) + + ENDIF + + IF ( TRIM(surfdataqc%cvars(1)) == 'SLA' .AND. surfdataqc%nextra == 2 ) THEN + ! ... Remove the MDT from the SSH at the observation point to get the SLA + surfdataqc%rext(jobs,1) = zext(1) + surfdataqc%rmod(jobs,1) = surfdataqc%rext(jobs,1) - surfdataqc%rext(jobs,2) + ELSE + surfdataqc%rmod(jobs,1) = zext(1) + ENDIF + + IF ( zext(1) == obfillflt ) THEN + ! If the observation value is a fill value, set QC flag to bad + surfdataqc%nqc(jobs) = 4 + ENDIF + + END DO + + ! Deallocate the data for interpolation + DEALLOCATE( & + & zweig, & + & igrdi, & + & igrdj, & + & zglam, & + & zgphi, & + & zmask, & + & zsurf, & + & zsurftmp, & + & zglamf, & + & zgphif, & + & igrdip1,& + & igrdjp1 & + & ) + + ! At the end of the day also deallocate night-time mean array + IF ( idayend == 0 .AND. ldnightav ) THEN + DEALLOCATE( & + & zsurfm & + & ) + ENDIF + ! + surfdataqc%nsurfup = surfdataqc%nsurfup + isurf + ! + END SUBROUTINE obs_surf_opt + + !!====================================================================== +END MODULE obs_oper diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_prep.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_prep.f90 new file mode 100644 index 0000000000000000000000000000000000000000..43196728636cbfe26cde29830907ed87fe75598b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_prep.f90 @@ -0,0 +1,1430 @@ + + + + + + + + + + + + + +MODULE obs_prep + !!===================================================================== + !! *** MODULE obs_prep *** + !! Observation diagnostics: Prepare observation arrays: screening, + !! sorting, coordinate search + !!===================================================================== + + !!--------------------------------------------------------------------- + !! obs_pre_prof : First level check and screening of profile observations + !! obs_pre_surf : First level check and screening of surface observations + !! obs_scr : Basic screening of the observations + !! obs_coo_tim : Compute number of time steps to the observation time + !! obs_sor : Sort the observation arrays + !!--------------------------------------------------------------------- + USE par_kind, ONLY : wp ! Precision variables + USE in_out_manager ! I/O manager + USE obs_profiles_def ! Definitions for storage arrays for profiles + USE obs_surf_def ! Definitions for storage arrays for surface data + USE obs_mpp, ONLY : & ! MPP support routines for observation diagnostics + & obs_mpp_sum_integer, & + & obs_mpp_sum_integers + USE obs_inter_sup ! Interpolation support + USE obs_oper ! Observation operators + USE lib_mpp, ONLY : ctl_warn, ctl_stop + USE bdy_oce, ONLY : & ! Boundary information + idx_bdy, nb_bdy, ln_bdy + + IMPLICIT NONE + PRIVATE + + PUBLIC obs_pre_prof ! First level check and screening of profile obs + PUBLIC obs_pre_surf ! First level check and screening of surface obs + PUBLIC calc_month_len ! Calculate the number of days in the months of a year + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_prep.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + +CONTAINS + + SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea, ld_bound_reject, & + kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_pre_sla *** + !! + !! ** Purpose : First level check and screening of surface observations + !! + !! ** Method : First level check and screening of surface observations + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 2007-03 (A. Weaver, K. Mogensen) Original + !! ! 2007-06 (K. Mogensen et al) Reject obs. near land. + !! ! 2015-02 (M. Martin) Combined routine for surface types. + !!---------------------------------------------------------------------- + !! * Modules used + USE par_oce ! Ocean parameters + USE dom_oce, ONLY : glamt, gphit, tmask ! Geographical information + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data + TYPE(obs_surf), INTENT(INOUT) :: surfdataqc ! Subset of surface data not failing screening + LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land + LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting obs near the boundary + INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value + !! * Local declarations + INTEGER :: iqc_cutoff = 255 ! cut off for QC value + INTEGER :: iyea0 ! Initial date + INTEGER :: imon0 ! - (year, month, day, hour, minute) + INTEGER :: iday0 + INTEGER :: ihou0 + INTEGER :: imin0 + INTEGER :: icycle ! Current assimilation cycle + ! Counters for observations that + INTEGER :: iotdobs ! - outside time domain + INTEGER :: iosdsobs ! - outside space domain + INTEGER :: ilansobs ! - within a model land cell + INTEGER :: inlasobs ! - close to land + INTEGER :: igrdobs ! - fail the grid search + INTEGER :: ibdysobs ! - close to open boundary + ! Global counters for observations that + INTEGER :: iotdobsmpp ! - outside time domain + INTEGER :: iosdsobsmpp ! - outside space domain + INTEGER :: ilansobsmpp ! - within a model land cell + INTEGER :: inlasobsmpp ! - close to land + INTEGER :: igrdobsmpp ! - fail the grid search + INTEGER :: ibdysobsmpp ! - close to open boundary + LOGICAL, DIMENSION(:), ALLOCATABLE :: & + & llvalid ! SLA data selection + INTEGER :: jobs ! Obs. loop variable + INTEGER :: jstp ! Time loop variable + INTEGER :: inrc ! Time index variable + !!---------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) 'obs_pre_surf : Preparing the surface observations...' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + + ! Initial date initialization (year, month, day, hour, minute) + iyea0 = ndate0 / 10000 + imon0 = ( ndate0 - iyea0 * 10000 ) / 100 + iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 + ihou0 = nn_time0 / 100 + imin0 = ( nn_time0 - ihou0 * 100 ) + + icycle = nn_no ! Assimilation cycle + + ! Diagnotics counters for various failures. + + iotdobs = 0 + igrdobs = 0 + iosdsobs = 0 + ilansobs = 0 + inlasobs = 0 + ibdysobs = 0 + + ! Set QC cutoff to optional value if provided + IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff + + ! ----------------------------------------------------------------------- + ! Find time coordinate for surface data + ! ----------------------------------------------------------------------- + + CALL obs_coo_tim( icycle, & + & iyea0, imon0, iday0, ihou0, imin0, & + & surfdata%nsurf, surfdata%nyea, surfdata%nmon, & + & surfdata%nday, surfdata%nhou, surfdata%nmin, & + & surfdata%nqc, surfdata%mstp, iotdobs ) + + CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) + + ! ----------------------------------------------------------------------- + ! Check for surface data failing the grid search + ! ----------------------------------------------------------------------- + + CALL obs_coo_grd( surfdata%nsurf, surfdata%mi, surfdata%mj, & + & surfdata%nqc, igrdobs ) + + CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) + + ! ----------------------------------------------------------------------- + ! Check for land points. + ! ----------------------------------------------------------------------- + + CALL obs_coo_spc_2d( surfdata%nsurf, & + & jpi, jpj, & + & surfdata%mi, surfdata%mj, & + & surfdata%rlam, surfdata%rphi, & + & glamt, gphit, & + & tmask(:,:,1), surfdata%nqc, & + & iosdsobs, ilansobs, & + & inlasobs, ld_nea, & + & ibdysobs, ld_bound_reject, & + & iqc_cutoff ) + + CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) + CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) + CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) + CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp ) + + ! ----------------------------------------------------------------------- + ! Copy useful data from the surfdata data structure to + ! the surfdataqc data structure + ! ----------------------------------------------------------------------- + + ! Allocate the selection arrays + + ALLOCATE( llvalid(surfdata%nsurf) ) + + ! We want all data which has qc flags <= iqc_cutoff + + llvalid(:) = ( surfdata%nqc(:) <= iqc_cutoff ) + + ! The actual copying + + CALL obs_surf_compress( surfdata, surfdataqc, .TRUE., numout, & + & lvalid=llvalid ) + + ! Dellocate the selection arrays + DEALLOCATE( llvalid ) + + ! ----------------------------------------------------------------------- + ! Print information about what observations are left after qc + ! ----------------------------------------------------------------------- + + ! Update the total observation counter array + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data outside time domain = ', & + & iotdobsmpp + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data that failed grid search = ', & + & igrdobsmpp + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data outside space domain = ', & + & iosdsobsmpp + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data at land points = ', & + & ilansobsmpp + IF (ld_nea) THEN + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (removed) = ', & + & inlasobsmpp + ELSE + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (kept) = ', & + & inlasobsmpp + ENDIF + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near open boundary (removed) = ', & + & ibdysobsmpp + WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data accepted = ', & + & surfdataqc%nsurfmpp + + WRITE(numout,*) + WRITE(numout,*) ' Number of observations per time step :' + WRITE(numout,*) + WRITE(numout,'(10X,A,10X,A)')'Time step',surfdataqc%cvars(1) + WRITE(numout,'(10X,A,5X,A)')'---------','-----------------' + CALL FLUSH(numout) + ENDIF + + DO jobs = 1, surfdataqc%nsurf + inrc = surfdataqc%mstp(jobs) + 2 - nit000 + surfdataqc%nsstp(inrc) = surfdataqc%nsstp(inrc) + 1 + END DO + + CALL obs_mpp_sum_integers( surfdataqc%nsstp, surfdataqc%nsstpmpp, & + & nitend - nit000 + 2 ) + + IF ( lwp ) THEN + DO jstp = nit000 - 1, nitend + inrc = jstp - nit000 + 2 + WRITE(numout,1999) jstp, surfdataqc%nsstpmpp(inrc) + CALL FLUSH(numout) + END DO + ENDIF + +1999 FORMAT(10X,I9,5X,I17) + + END SUBROUTINE obs_pre_surf + + + SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & + & kpi, kpj, kpk, & + & zmask, pglam, pgphi, & + & ld_nea, ld_bound_reject, Kmm, kdailyavtypes, kqc_cutoff ) + +!!---------------------------------------------------------------------- + !! *** ROUTINE obs_pre_prof *** + !! + !! ** Purpose : First level check and screening of profiles + !! + !! ** Method : First level check and screening of profiles + !! + !! History : + !! ! 2007-06 (K. Mogensen) original : T and S profile data + !! ! 2008-09 (M. Valdivieso) : TAO velocity data + !! ! 2009-01 (K. Mogensen) : New feedback stricture + !! ! 2015-02 (M. Martin) : Combined profile routine. + !! + !!---------------------------------------------------------------------- + !! * Modules used + USE par_oce ! Ocean parameters + USE dom_oce, ONLY : & ! Geographical information + & gdept_1d + + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data + TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening + LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & + & ld_var ! Observed variables switches + LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land + LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting observations near the boundary + INTEGER, INTENT(IN) :: kpi, kpj, kpk ! Local domain sizes + INTEGER, INTENT(IN) :: Kmm ! time-level index + INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & + & kdailyavtypes ! Types for daily averages + REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & + & zmask + REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & + & pglam, & + & pgphi + INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value + + !! * Local declarations + INTEGER :: iqc_cutoff = 255 ! cut off for QC value + INTEGER :: iyea0 ! Initial date + INTEGER :: imon0 ! - (year, month, day, hour, minute) + INTEGER :: iday0 + INTEGER :: ihou0 + INTEGER :: imin0 + INTEGER :: icycle ! Current assimilation cycle + ! Counters for observations that are + INTEGER :: iotdobs ! - outside time domain + INTEGER, DIMENSION(profdata%nvar) :: iosdvobs ! - outside space domain + INTEGER, DIMENSION(profdata%nvar) :: ilanvobs ! - within a model land cell + INTEGER, DIMENSION(profdata%nvar) :: inlavobs ! - close to land + INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs ! - boundary + INTEGER :: igrdobs ! - fail the grid search + INTEGER :: iuvchku ! - reject UVEL if VVEL rejected + INTEGER :: iuvchkv ! - reject VVEL if UVEL rejected + ! Global counters for observations that are + INTEGER :: iotdobsmpp ! - outside time domain + INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp ! - outside space domain + INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp ! - within a model land cell + INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp ! - close to land + INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp ! - boundary + INTEGER :: igrdobsmpp ! - fail the grid search + INTEGER :: iuvchkumpp ! - reject UVEL if VVEL rejected + INTEGER :: iuvchkvmpp ! - reject VVEL if UVEL rejected + TYPE(obs_prof_valid) :: llvalid ! Profile selection + TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & + & llvvalid ! var selection + INTEGER :: jvar ! Variable loop variable + INTEGER :: jobs ! Obs. loop variable + INTEGER :: jstp ! Time loop variable + INTEGER :: inrc ! Time index variable + CHARACTER(LEN=256) :: cout1 ! Diagnostic output line + CHARACTER(LEN=256) :: cout2 ! Diagnostic output line + !!---------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*)'obs_pre_prof: Preparing the profile data...' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + + ! Initial date initialization (year, month, day, hour, minute) + iyea0 = ndate0 / 10000 + imon0 = ( ndate0 - iyea0 * 10000 ) / 100 + iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 + ihou0 = nn_time0 / 100 + imin0 = ( nn_time0 - ihou0 * 100 ) + + icycle = nn_no ! Assimilation cycle + + ! Diagnostic counters for various failures. + + iotdobs = 0 + igrdobs = 0 + iosdvobs(:) = 0 + ilanvobs(:) = 0 + inlavobs(:) = 0 + ibdyvobs(:) = 0 + iuvchku = 0 + iuvchkv = 0 + + + ! Set QC cutoff to optional value if provided + IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff + + ! ----------------------------------------------------------------------- + ! Find time coordinate for profiles + ! ----------------------------------------------------------------------- + + IF ( PRESENT(kdailyavtypes) ) THEN + CALL obs_coo_tim_prof( icycle, & + & iyea0, imon0, iday0, ihou0, imin0, & + & profdata%nprof, profdata%nyea, profdata%nmon, & + & profdata%nday, profdata%nhou, profdata%nmin, & + & profdata%ntyp, profdata%nqc, profdata%mstp, & + & iotdobs, kdailyavtypes = kdailyavtypes, & + & kqc_cutoff = iqc_cutoff ) + ELSE + CALL obs_coo_tim_prof( icycle, & + & iyea0, imon0, iday0, ihou0, imin0, & + & profdata%nprof, profdata%nyea, profdata%nmon, & + & profdata%nday, profdata%nhou, profdata%nmin, & + & profdata%ntyp, profdata%nqc, profdata%mstp, & + & iotdobs, kqc_cutoff = iqc_cutoff ) + ENDIF + + CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) + + ! ----------------------------------------------------------------------- + ! Check for profiles failing the grid search + ! ----------------------------------------------------------------------- + + DO jvar = 1, profdata%nvar + CALL obs_coo_grd( profdata%nprof, profdata%mi(:,jvar), profdata%mj(:,jvar), & + & profdata%nqc, igrdobs ) + END DO + + CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) + + ! ----------------------------------------------------------------------- + ! Reject all observations for profiles with nqc > iqc_cutoff + ! ----------------------------------------------------------------------- + + CALL obs_pro_rej( profdata, kqc_cutoff = iqc_cutoff ) + + ! ----------------------------------------------------------------------- + ! Check for land points. This includes points below the model + ! bathymetry so this is done for every point in the profile + ! ----------------------------------------------------------------------- + + DO jvar = 1, profdata%nvar + CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(jvar), & + & profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & + & jpi, jpj, & + & jpk, & + & profdata%mi, profdata%mj, & + & profdata%var(jvar)%mvk, & + & profdata%rlam, profdata%rphi, & + & profdata%var(jvar)%vdep, & + & pglam(:,:,jvar), pgphi(:,:,jvar), & + & gdept_1d, zmask(:,:,:,jvar), & + & profdata%nqc, profdata%var(jvar)%nvqc, & + & iosdvobs(jvar), ilanvobs(jvar), & + & inlavobs(jvar), ld_nea, & + & ibdyvobs(jvar), ld_bound_reject, & + & iqc_cutoff, Kmm ) + + CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) + CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) + CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) + CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) + END DO + + ! ----------------------------------------------------------------------- + ! Reject u if v is rejected and vice versa + ! ----------------------------------------------------------------------- + + IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN + CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff ) + CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) + CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) + ENDIF + + ! ----------------------------------------------------------------------- + ! Copy useful data from the profdata data structure to + ! the prodatqc data structure + ! ----------------------------------------------------------------------- + + ! Allocate the selection arrays + + ALLOCATE( llvalid%luse(profdata%nprof) ) + DO jvar = 1,profdata%nvar + ALLOCATE( llvvalid(jvar)%luse(profdata%nvprot(jvar)) ) + END DO + + ! We want all data which has qc flags <= iqc_cutoff + + llvalid%luse(:) = ( profdata%nqc(:) <= iqc_cutoff ) + DO jvar = 1,profdata%nvar + llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= iqc_cutoff ) + END DO + + ! The actual copying + + CALL obs_prof_compress( profdata, prodatqc, .TRUE., numout, & + & lvalid=llvalid, lvvalid=llvvalid ) + + ! Dellocate the selection arrays + DEALLOCATE( llvalid%luse ) + DO jvar = 1,profdata%nvar + DEALLOCATE( llvvalid(jvar)%luse ) + END DO + + ! ----------------------------------------------------------------------- + ! Print information about what observations are left after qc + ! ----------------------------------------------------------------------- + + ! Update the total observation counter array + + IF(lwp) THEN + + WRITE(numout,*) + WRITE(numout,*) ' Profiles outside time domain = ', & + & iotdobsmpp + WRITE(numout,*) ' Remaining profiles that failed grid search = ', & + & igrdobsmpp + DO jvar = 1, profdata%nvar + WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain = ', & + & iosdvobsmpp(jvar) + WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points = ', & + & ilanvobsmpp(jvar) + IF (ld_nea) THEN + WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& + & inlavobsmpp(jvar) + ELSE + WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept) = ',& + & inlavobsmpp(jvar) + ENDIF + IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN + WRITE(numout,*) ' U observation rejected since V rejected = ', & + & iuvchku + ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN + WRITE(numout,*) ' V observation rejected since U rejected = ', & + & iuvchkv + ENDIF + WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& + & ibdyvobsmpp(jvar) + WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted = ', & + & prodatqc%nvprotmpp(jvar) + END DO + + WRITE(numout,*) + WRITE(numout,*) ' Number of observations per time step :' + WRITE(numout,*) + WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' + WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' + DO jvar = 1, prodatqc%nvar + WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) + WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' + END DO + WRITE(numout,*) cout1 + WRITE(numout,*) cout2 + ENDIF + + DO jobs = 1, prodatqc%nprof + inrc = prodatqc%mstp(jobs) + 2 - nit000 + prodatqc%npstp(inrc) = prodatqc%npstp(inrc) + 1 + DO jvar = 1, prodatqc%nvar + IF ( prodatqc%npvend(jobs,jvar) > 0 ) THEN + prodatqc%nvstp(inrc,jvar) = prodatqc%nvstp(inrc,jvar) + & + & ( prodatqc%npvend(jobs,jvar) - & + & prodatqc%npvsta(jobs,jvar) + 1 ) + ENDIF + END DO + END DO + + + CALL obs_mpp_sum_integers( prodatqc%npstp, prodatqc%npstpmpp, & + & nitend - nit000 + 2 ) + DO jvar = 1, prodatqc%nvar + CALL obs_mpp_sum_integers( prodatqc%nvstp(:,jvar), & + & prodatqc%nvstpmpp(:,jvar), & + & nitend - nit000 + 2 ) + END DO + + IF ( lwp ) THEN + DO jstp = nit000 - 1, nitend + inrc = jstp - nit000 + 2 + WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) + DO jvar = 1, prodatqc%nvar + WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) + END DO + WRITE(numout,*) cout1 + END DO + ENDIF + + END SUBROUTINE obs_pre_prof + + SUBROUTINE obs_coo_tim( kcycle, & + & kyea0, kmon0, kday0, khou0, kmin0, & + & kobsno, & + & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & + & kobsqc, kobsstp, kotdobs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_tim *** + !! + !! ** Purpose : Compute the number of time steps to the observation time. + !! + !! ** Method : For time coordinates ( yea_obs, mon_obs, day_obs, + !! hou_obs, min_obs ), this routine locates the time step + !! that is closest to this time. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 1997-07 (A. Weaver) Original + !! ! 2006-08 (A. Weaver) NEMOVAR migration + !! ! 2006-10 (A. Weaver) Cleanup + !! ! 2007-01 (K. Mogensen) Rewritten with loop + !! ! 2010-05 (D. Lea) Fix in leap year calculation for NEMO vn3.2 + !!---------------------------------------------------------------------- + !! * Modules used + USE dom_oce, ONLY : & ! Geographical information + & rn_Dt + USE phycst, ONLY : & ! Physical constants + & rday, & + & rmmss, & + & rhhmm + !! * Arguments + INTEGER, INTENT(IN) :: kcycle ! Current cycle + INTEGER, INTENT(IN) :: kyea0 ! Initial date coordinates + INTEGER, INTENT(IN) :: kmon0 + INTEGER, INTENT(IN) :: kday0 + INTEGER, INTENT(IN) :: khou0 + INTEGER, INTENT(IN) :: kmin0 + INTEGER, INTENT(IN) :: kobsno ! Number of observations + INTEGER, INTENT(INOUT) :: kotdobs ! Number of observations failing time check + INTEGER, DIMENSION(kobsno), INTENT(IN ) :: & + & kobsyea, & ! Observation time coordinates + & kobsmon, & + & kobsday, & + & kobshou, & + & kobsmin + INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & + & kobsqc ! Quality control flag + INTEGER, DIMENSION(kobsno), INTENT(OUT) :: & + & kobsstp ! Number of time steps up to the + ! observation time + + !! * Local declarations + INTEGER :: jyea + INTEGER :: jmon + INTEGER :: jday + INTEGER :: jobs + INTEGER :: iyeastr + INTEGER :: iyeaend + INTEGER :: imonstr + INTEGER :: imonend + INTEGER :: idaystr + INTEGER :: idayend + INTEGER :: iskip + INTEGER :: idaystp + REAL(KIND=wp) :: zminstp + REAL(KIND=wp) :: zhoustp + REAL(KIND=wp) :: zobsstp + INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year + + !----------------------------------------------------------------------- + ! Initialization + !----------------------------------------------------------------------- + + ! Intialize the number of time steps per day + idaystp = NINT( rday / rn_Dt ) + + !--------------------------------------------------------------------- + ! Locate the model time coordinates for interpolation + !--------------------------------------------------------------------- + + DO jobs = 1, kobsno + + ! Initialize the time step counter + kobsstp(jobs) = nit000 - 1 + + ! Flag if observation date is less than the initial date + + IF ( ( kobsyea(jobs) < kyea0 ) & + & .OR. ( ( kobsyea(jobs) == kyea0 ) & + & .AND. ( kobsmon(jobs) < kmon0 ) ) & + & .OR. ( ( kobsyea(jobs) == kyea0 ) & + & .AND. ( kobsmon(jobs) == kmon0 ) & + & .AND. ( kobsday(jobs) < kday0 ) ) & + & .OR. ( ( kobsyea(jobs) == kyea0 ) & + & .AND. ( kobsmon(jobs) == kmon0 ) & + & .AND. ( kobsday(jobs) == kday0 ) & + & .AND. ( kobshou(jobs) < khou0 ) ) & + & .OR. ( ( kobsyea(jobs) == kyea0 ) & + & .AND. ( kobsmon(jobs) == kmon0 ) & + & .AND. ( kobsday(jobs) == kday0 ) & + & .AND. ( kobshou(jobs) == khou0 ) & + & .AND. ( kobsmin(jobs) <= kmin0 ) ) ) THEN + kobsstp(jobs) = -1 + kobsqc(jobs) = IBSET(kobsqc(jobs),13) + kotdobs = kotdobs + 1 + CYCLE + ENDIF + + ! Compute the number of time steps to the observation day + iyeastr = kyea0 + iyeaend = kobsyea(jobs) + + !--------------------------------------------------------------------- + ! Year loop + !--------------------------------------------------------------------- + DO jyea = iyeastr, iyeaend + + CALL calc_month_len( jyea, imonth_len ) + + imonstr = 1 + IF ( jyea == kyea0 ) imonstr = kmon0 + imonend = 12 + IF ( jyea == kobsyea(jobs) ) imonend = kobsmon(jobs) + + ! Month loop + DO jmon = imonstr, imonend + + idaystr = 1 + IF ( ( jmon == kmon0 ) & + & .AND. ( jyea == kyea0 ) ) idaystr = kday0 + idayend = imonth_len(jmon) + IF ( ( jmon == kobsmon(jobs) ) & + & .AND. ( jyea == kobsyea(jobs) ) ) idayend = kobsday(jobs) - 1 + + ! Day loop + DO jday = idaystr, idayend + kobsstp(jobs) = kobsstp(jobs) + idaystp + END DO + + END DO + + END DO + + ! Add in the number of time steps to the observation minute + zminstp = rmmss / rn_Dt + zhoustp = rhhmm * zminstp + + zobsstp = REAL( kobsmin(jobs) - kmin0, KIND=wp ) * zminstp & + & + REAL( kobshou(jobs) - khou0, KIND=wp ) * zhoustp + kobsstp(jobs) = kobsstp(jobs) + NINT( zobsstp ) + + ! Flag if observation step outside the time window + IF ( ( kobsstp(jobs) < ( nit000 - 1 ) ) & + & .OR.( kobsstp(jobs) > nitend ) ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),13) + kotdobs = kotdobs + 1 + CYCLE + ENDIF + + END DO + + END SUBROUTINE obs_coo_tim + + SUBROUTINE calc_month_len( iyear, imonth_len ) + !!---------------------------------------------------------------------- + !! *** ROUTINE calc_month_len *** + !! + !! ** Purpose : Compute the number of days in a months given a year. + !! + !! ** Method : + !! + !! ** Action : + !! + !! History : + !! ! 10-05 (D. Lea) New routine based on day_init + !!---------------------------------------------------------------------- + + INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year + INTEGER :: iyear !: year + + ! length of the month of the current year (from nleapy, read in namelist) + IF ( nleapy < 2 ) THEN + imonth_len(:) = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) + IF ( nleapy == 1 ) THEN ! we are using calendar with leap years + IF ( MOD(iyear, 4) == 0 .AND. ( MOD(iyear, 400) == 0 .OR. MOD(iyear, 100) /= 0 ) ) THEN + imonth_len(2) = 29 + ENDIF + ENDIF + ELSE + imonth_len(:) = nleapy ! all months with nleapy days per year + ENDIF + + END SUBROUTINE calc_month_len + + SUBROUTINE obs_coo_tim_prof( kcycle, & + & kyea0, kmon0, kday0, khou0, kmin0, & + & kobsno, & + & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & + & ktyp, kobsqc, kobsstp, kotdobs, kdailyavtypes, & + & kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_tim *** + !! + !! ** Purpose : Compute the number of time steps to the observation time. + !! + !! ** Method : For time coordinates ( yea_obs, mon_obs, day_obs, + !! hou_obs, min_obs ), this routine locates the time step + !! that is closest to this time. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 1997-07 (A. Weaver) Original + !! ! 2006-08 (A. Weaver) NEMOVAR migration + !! ! 2006-10 (A. Weaver) Cleanup + !! ! 2007-01 (K. Mogensen) Rewritten with loop + !!---------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: kcycle ! Current cycle + INTEGER, INTENT(IN) :: kyea0 ! Initial date coordinates + INTEGER, INTENT(IN) :: kmon0 + INTEGER, INTENT(IN) :: kday0 + INTEGER, INTENT(IN) :: khou0 + INTEGER, INTENT(IN) :: kmin0 + INTEGER, INTENT(IN) :: kobsno ! Number of observations + INTEGER, INTENT(INOUT) :: kotdobs ! Number of observations failing time check + INTEGER, DIMENSION(kobsno), INTENT(IN ) :: & + & kobsyea, & ! Observation time coordinates + & kobsmon, & + & kobsday, & + & kobshou, & + & kobsmin, & + & ktyp ! Observation type. + INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & + & kobsqc ! Quality control flag + INTEGER, DIMENSION(kobsno), INTENT(OUT) :: & + & kobsstp ! Number of time steps up to the + ! observation time + INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & + & kdailyavtypes ! Types for daily averages + INTEGER, OPTIONAL, INTENT(IN) :: kqc_cutoff ! QC cutoff value + + !! * Local declarations + INTEGER :: jobs + INTEGER :: iqc_cutoff=255 + + !----------------------------------------------------------------------- + ! Call standard obs_coo_tim + !----------------------------------------------------------------------- + + CALL obs_coo_tim( kcycle, & + & kyea0, kmon0, kday0, khou0, kmin0, & + & kobsno, & + & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & + & kobsqc, kobsstp, kotdobs ) + + !------------------------------------------------------------------------ + ! Always reject daily averaged data (e.g. MRB data (820)) at initial time + !------------------------------------------------------------------------ + + IF ( PRESENT(kdailyavtypes) ) THEN + DO jobs = 1, kobsno + + IF ( kobsqc(jobs) <= iqc_cutoff ) THEN + + IF ( ( kobsstp(jobs) == (nit000 - 1) ).AND.& + & ( ANY (kdailyavtypes(:) == ktyp(jobs)) ) ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),13) + kotdobs = kotdobs + 1 + CYCLE + ENDIF + + ENDIF + END DO + ENDIF + + + END SUBROUTINE obs_coo_tim_prof + + SUBROUTINE obs_coo_grd( kobsno, kobsi, kobsj, kobsqc, kgrdobs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_grd *** + !! + !! ** Purpose : Verify that the grid search has not failed + !! + !! ** Method : The previously computed i,j indeces are checked + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 2007-01 (K. Mogensen) Original + !!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kobsno ! Number of observations + INTEGER, DIMENSION(kobsno), INTENT(IN ) :: & + & kobsi, & ! i,j indeces previously computed + & kobsj + INTEGER, INTENT(INOUT) :: kgrdobs ! Number of observations failing the check + INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & + & kobsqc ! Quality control flag + + !! * Local declarations + INTEGER :: jobs ! Loop variable + + ! Flag if the grid search failed + + DO jobs = 1, kobsno + IF ( ( kobsi(jobs) <= 0 ) .AND. ( kobsj(jobs) <= 0 ) ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),12) + kgrdobs = kgrdobs + 1 + ENDIF + END DO + + END SUBROUTINE obs_coo_grd + + SUBROUTINE obs_coo_spc_2d( kobsno, kpi, kpj, & + & kobsi, kobsj, pobslam, pobsphi, & + & plam, pphi, pmask, & + & kobsqc, kosdobs, klanobs, & + & knlaobs,ld_nea, & + & kbdyobs,ld_bound_reject, & + & kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_spc_2d *** + !! + !! ** Purpose : Check for points outside the domain and land points + !! + !! ** Method : Remove the observations that are outside the model space + !! and time domain or located within model land cells. + !! + !! ** Action : + !! + !! History : 2007-03 (A. Weaver, K. Mogensen) Original + !! ! 2007-06 (K. Mogensen et al) Reject obs. near land. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kobsno ! Total number of observations + INTEGER , INTENT(in ) :: kpi , kpj ! Number of grid points in (i,j) + INTEGER , INTENT(in ), DIMENSION(kobsno) :: kobsi , kobsj ! Observation (i,j) coordinates + REAL(wp), INTENT(in ), DIMENSION(kobsno) :: pobslam, pobsphi ! Observation (lon,lat) coordinates + REAL(wp), INTENT(in ), DIMENSION(kpi,kpj) :: plam , pphi ! Model (lon,lat) coordinates + REAL(wp), INTENT(in ), DIMENSION(kpi,kpj) :: pmask ! Land mask array + INTEGER , INTENT(inout), DIMENSION(kobsno) :: kobsqc ! Observation quality control + INTEGER , INTENT(inout) :: kosdobs ! Observations outside space domain + INTEGER , INTENT(inout) :: klanobs ! Observations within a model land cell + INTEGER , INTENT(inout) :: knlaobs ! Observations near land + INTEGER , INTENT(inout) :: kbdyobs ! Observations near boundary + LOGICAL , INTENT(in ) :: ld_nea ! Flag observations near land + LOGICAL , INTENT(in ) :: ld_bound_reject ! Flag observations near open boundary + INTEGER , INTENT(in ) :: kqc_cutoff ! Cutoff QC value + ! + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zgmsk ! Grid mask + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zbmsk ! Boundary mask + REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zglam, zgphi ! Model Lon/lat at grid points + INTEGER , DIMENSION(2,2,kobsno) :: igrdi, igrdj ! Grid i,j + LOGICAL :: lgridobs ! Is observation on a model grid point. + INTEGER :: iig, ijg ! i,j of observation on model grid point. + INTEGER :: jobs, ji, jj + !!---------------------------------------------------------------------- + + ! Get grid point indices + + DO jobs = 1, kobsno + + ! For invalid points use 2,2 + + IF ( kobsqc(jobs) >= kqc_cutoff ) THEN + + igrdi(1,1,jobs) = 1 + igrdj(1,1,jobs) = 1 + igrdi(1,2,jobs) = 1 + igrdj(1,2,jobs) = 2 + igrdi(2,1,jobs) = 2 + igrdj(2,1,jobs) = 1 + igrdi(2,2,jobs) = 2 + igrdj(2,2,jobs) = 2 + + ELSE + + igrdi(1,1,jobs) = kobsi(jobs)-1 + igrdj(1,1,jobs) = kobsj(jobs)-1 + igrdi(1,2,jobs) = kobsi(jobs)-1 + igrdj(1,2,jobs) = kobsj(jobs) + igrdi(2,1,jobs) = kobsi(jobs) + igrdj(2,1,jobs) = kobsj(jobs)-1 + igrdi(2,2,jobs) = kobsi(jobs) + igrdj(2,2,jobs) = kobsj(jobs) + + ENDIF + + END DO + + IF (ln_bdy) THEN + ! Create a mask grid points in boundary rim + IF (ld_bound_reject) THEN + zbdymask(:,:) = 1.0_wp + DO ji = 1, nb_bdy + DO jj = 1, idx_bdy(ji)%nblen(1) + zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp + ENDDO + ENDDO + + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) + ENDIF + ENDIF + + + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pmask, zgmsk ) + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, plam, zglam ) + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) + + DO jobs = 1, kobsno + + ! Skip bad observations + IF ( kobsqc(jobs) >= kqc_cutoff ) CYCLE + + ! Flag if the observation falls outside the model spatial domain + IF ( ( pobslam(jobs) < -180. ) & + & .OR. ( pobslam(jobs) > 180. ) & + & .OR. ( pobsphi(jobs) < -90. ) & + & .OR. ( pobsphi(jobs) > 90. ) ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),11) + kosdobs = kosdobs + 1 + CYCLE + ENDIF + + ! Flag if the observation falls with a model land cell + IF ( SUM( zgmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),10) + klanobs = klanobs + 1 + CYCLE + ENDIF + + ! Check if this observation is on a grid point + + lgridobs = .FALSE. + iig = -1 + ijg = -1 + DO jj = 1, 2 + DO ji = 1, 2 + IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & + & .AND. & + & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) & + & < 1.0e-6_wp ) ) THEN + lgridobs = .TRUE. + iig = ji + ijg = jj + ENDIF + END DO + END DO + + ! For observations on the grid reject them if their are at + ! a masked point + + IF (lgridobs) THEN + IF (zgmsk(iig,ijg,jobs) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),10) + klanobs = klanobs + 1 + CYCLE + ENDIF + ENDIF + + ! Flag if the observation falls is close to land + IF ( MINVAL( zgmsk(1:2,1:2,jobs) ) == 0.0_wp) THEN + knlaobs = knlaobs + 1 + IF (ld_nea) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),9) + CYCLE + ENDIF + ENDIF + + IF (ln_bdy) THEN + ! Flag if the observation falls close to the boundary rim + IF (ld_bound_reject) THEN + IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),8) + kbdyobs = kbdyobs + 1 + CYCLE + ENDIF + ! for observations on the grid... + IF (lgridobs) THEN + IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),8) + kbdyobs = kbdyobs + 1 + CYCLE + ENDIF + ENDIF + ENDIF + ENDIF + ! + END DO + ! + END SUBROUTINE obs_coo_spc_2d + + + SUBROUTINE obs_coo_spc_3d( kprofno, kobsno, kpstart, kpend, & + & kpi, kpj, kpk, & + & kobsi, kobsj, kobsk, & + & pobslam, pobsphi, pobsdep, & + & plam, pphi, pdep, pmask, & + & kpobsqc, kobsqc, kosdobs, & + & klanobs, knlaobs, ld_nea, & + & kbdyobs, ld_bound_reject, & + & kqc_cutoff, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_spc_3d *** + !! + !! ** Purpose : Check for points outside the domain and land points + !! Reset depth of observation above highest model level + !! to the value of highest model level + !! + !! ** Method : Remove the observations that are outside the model space + !! and time domain or located within model land cells. + !! + !! NB. T and S profile observations lying between the ocean + !! surface and the depth of the first model T point are + !! assigned a depth equal to that of the first model T pt. + !! + !! ** Action : + !! + !! History : + !! ! 2007-01 (K. Mogensen) Rewrite of parts of obs_scr + !! ! 2007-06 (K. Mogensen et al) Reject obs. near land. + !!---------------------------------------------------------------------- + !! * Modules used + USE dom_oce ! Geographical information + + !! * Arguments + INTEGER, INTENT(IN) :: kprofno ! Number of profiles + INTEGER, INTENT(IN) :: kobsno ! Total number of observations + INTEGER, INTENT(IN) :: kpi ! Number of grid points in (i,j,k) + INTEGER, INTENT(IN) :: kpj + INTEGER, INTENT(IN) :: kpk + INTEGER, DIMENSION(kprofno), INTENT(IN) :: & + & kpstart, & ! Start of individual profiles + & kpend ! End of individual profiles + INTEGER, DIMENSION(kprofno), INTENT(IN) :: & + & kobsi, & ! Observation (i,j) coordinates + & kobsj + INTEGER, DIMENSION(kobsno), INTENT(IN) :: & + & kobsk ! Observation k coordinate + REAL(KIND=wp), DIMENSION(kprofno), INTENT(IN) :: & + & pobslam, & ! Observation (lon,lat) coordinates + & pobsphi + REAL(KIND=wp), DIMENSION(kobsno), INTENT(INOUT) :: & + & pobsdep ! Observation depths + REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) :: & + & plam, pphi ! Model (lon,lat) coordinates + REAL(KIND=wp), DIMENSION(kpk), INTENT(IN) :: & + & pdep ! Model depth coordinates + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) :: & + & pmask ! Land mask array + INTEGER, DIMENSION(kprofno), INTENT(INOUT) :: & + & kpobsqc ! Profile quality control + INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & + & kobsqc ! Observation quality control + INTEGER, INTENT(INOUT) :: kosdobs ! Observations outside space domain + INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell + INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land + INTEGER, INTENT(INOUT) :: kbdyobs ! Observations near boundary + LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land + LOGICAL, INTENT(IN) :: ld_bound_reject ! Flag observations near open boundary + INTEGER, INTENT(IN) :: kqc_cutoff ! Cutoff QC value + INTEGER, INTENT(IN) :: Kmm ! time-level index + + !! * Local declarations + REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & + & zgmsk ! Grid mask + REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & + & zbmsk ! Boundary mask + REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask + REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & + & zgdepw + REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & + & zglam, & ! Model longitude at grid points + & zgphi ! Model latitude at grid points + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepw + INTEGER, DIMENSION(2,2,kprofno) :: & + & igrdi, & ! Grid i,j + & igrdj + LOGICAL :: lgridobs ! Is observation on a model grid point. + LOGICAL :: ll_next_to_land ! Is a profile next to land + INTEGER :: iig, ijg ! i,j of observation on model grid point. + INTEGER :: jobs, jobsp, jk, ji, jj + !!---------------------------------------------------------------------- + + ! Get grid point indices + + DO jobs = 1, kprofno + + ! For invalid points use 2,2 + + IF ( kpobsqc(jobs) >= kqc_cutoff ) THEN + + igrdi(1,1,jobs) = 1 + igrdj(1,1,jobs) = 1 + igrdi(1,2,jobs) = 1 + igrdj(1,2,jobs) = 2 + igrdi(2,1,jobs) = 2 + igrdj(2,1,jobs) = 1 + igrdi(2,2,jobs) = 2 + igrdj(2,2,jobs) = 2 + + ELSE + + igrdi(1,1,jobs) = kobsi(jobs)-1 + igrdj(1,1,jobs) = kobsj(jobs)-1 + igrdi(1,2,jobs) = kobsi(jobs)-1 + igrdj(1,2,jobs) = kobsj(jobs) + igrdi(2,1,jobs) = kobsi(jobs) + igrdj(2,1,jobs) = kobsj(jobs)-1 + igrdi(2,2,jobs) = kobsi(jobs) + igrdj(2,2,jobs) = kobsj(jobs) + + ENDIF + + END DO + + IF (ln_bdy) THEN + ! Create a mask grid points in boundary rim + IF (ld_bound_reject) THEN + zbdymask(:,:) = 1.0_wp + DO ji = 1, nb_bdy + DO jj = 1, idx_bdy(ji)%nblen(1) + zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp + ENDDO + ENDDO + ENDIF + + CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) + ENDIF + + CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, pmask, zgmsk ) + CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, plam, zglam ) + CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) + DO jk = 1, jpk + zdepw(:,:,jk) = (gdepw_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) + END DO + CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, zdepw(:,:,:), zgdepw ) + + DO jobs = 1, kprofno + + ! Skip bad profiles + IF ( kpobsqc(jobs) >= kqc_cutoff ) CYCLE + + ! Check if this observation is on a grid point + + lgridobs = .FALSE. + iig = -1 + ijg = -1 + DO jj = 1, 2 + DO ji = 1, 2 + IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & + & .AND. & + & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) < 1.0e-6_wp ) & + & ) THEN + lgridobs = .TRUE. + iig = ji + ijg = jj + ENDIF + END DO + END DO + + ! Check if next to land + IF ( ANY( zgmsk(1:2,1:2,1,jobs) == 0.0_wp ) ) THEN + ll_next_to_land=.TRUE. + ELSE + ll_next_to_land=.FALSE. + ENDIF + + ! Reject observations + + DO jobsp = kpstart(jobs), kpend(jobs) + + ! Flag if the observation falls outside the model spatial domain + IF ( ( pobslam(jobs) < -180. ) & + & .OR. ( pobslam(jobs) > 180. ) & + & .OR. ( pobsphi(jobs) < -90. ) & + & .OR. ( pobsphi(jobs) > 90. ) & + & .OR. ( pobsdep(jobsp) < 0.0 ) & + & .OR. ( pobsdep(jobsp) > gdepw_1d(kpk)) ) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobsp),11) + kosdobs = kosdobs + 1 + CYCLE + ENDIF + + ! To check if an observations falls within land: + + ! Flag if the observation is deeper than the bathymetry + ! Or if it is within the mask + IF ( ALL( zgdepw(1:2,1:2,kpk,jobs) < pobsdep(jobsp) ) & + & .OR. & + & ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & + & == 0.0_wp) ) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) + klanobs = klanobs + 1 + CYCLE + ENDIF + + ! Flag if the observation is close to land + IF ( ll_next_to_land ) THEN + knlaobs = knlaobs + 1 + IF (ld_nea) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) + ENDIF + ENDIF + + ! For observations on the grid reject them if their are at + ! a masked point + + IF (lgridobs) THEN + IF (zgmsk(iig,ijg,kobsk(jobsp)-1,jobs) == 0.0_wp ) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobs),10) + klanobs = klanobs + 1 + CYCLE + ENDIF + ENDIF + + ! Flag if the observation falls is close to land + IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == & + & 0.0_wp) THEN + IF (ld_nea) kobsqc(jobsp) = kobsqc(jobsp) + 14 + knlaobs = knlaobs + 1 + ENDIF + + ! Set observation depth equal to that of the first model depth + IF ( pobsdep(jobsp) <= pdep(1) ) THEN + pobsdep(jobsp) = pdep(1) + ENDIF + + IF (ln_bdy) THEN + ! Flag if the observation falls close to the boundary rim + IF (ld_bound_reject) THEN + IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobs),8) + kbdyobs = kbdyobs + 1 + CYCLE + ENDIF + ! for observations on the grid... + IF (lgridobs) THEN + IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobs),8) + kbdyobs = kbdyobs + 1 + CYCLE + ENDIF + ENDIF + ENDIF + ENDIF + ! + END DO + END DO + ! + END SUBROUTINE obs_coo_spc_3d + + + SUBROUTINE obs_pro_rej( profdata, kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_pro_rej *** + !! + !! ** Purpose : Reject all data within a rejected profile + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : 2007-10 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + TYPE(obs_prof), INTENT(inout) :: profdata ! Profile data + INTEGER , INTENT(in ) :: kqc_cutoff ! QC cutoff value + ! + INTEGER :: jprof + INTEGER :: jvar + INTEGER :: jobs + !!---------------------------------------------------------------------- + + ! Loop over profiles + + DO jprof = 1, profdata%nprof + + IF ( profdata%nqc(jprof) > kqc_cutoff ) THEN + + DO jvar = 1, profdata%nvar + + DO jobs = profdata%npvsta(jprof,jvar), & + & profdata%npvend(jprof,jvar) + + profdata%var(jvar)%nvqc(jobs) = & + & IBSET(profdata%var(jvar)%nvqc(jobs),14) + + END DO + + END DO + + ENDIF + + END DO + ! + END SUBROUTINE obs_pro_rej + + + SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_uv_rej *** + !! + !! ** Purpose : Reject u if v is rejected and vice versa + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : 2009-2 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + TYPE(obs_prof), INTENT(INOUT) :: profdata ! Profile data + INTEGER, INTENT(INOUT) :: knumu ! Number of u rejected + INTEGER, INTENT(INOUT) :: knumv ! Number of v rejected + INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value + ! + INTEGER :: jprof + INTEGER :: jvar + INTEGER :: jobs + !!---------------------------------------------------------------------- + + DO jprof = 1, profdata%nprof !== Loop over profiles ==! + ! + IF ( ( profdata%npvsta(jprof,1) /= profdata%npvsta(jprof,2) ) .OR. & + & ( profdata%npvend(jprof,1) /= profdata%npvend(jprof,2) ) ) THEN + ! + CALL ctl_stop('U,V profiles inconsistent in obs_uv_rej') + RETURN + ! + ENDIF + ! + DO jobs = profdata%npvsta(jprof,1), profdata%npvend(jprof,1) + ! + IF ( ( profdata%var(1)%nvqc(jobs) > kqc_cutoff ) .AND. & + & ( profdata%var(2)%nvqc(jobs) <= kqc_cutoff) ) THEN + profdata%var(2)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) + knumv = knumv + 1 + ENDIF + IF ( ( profdata%var(2)%nvqc(jobs) > kqc_cutoff ) .AND. & + & ( profdata%var(1)%nvqc(jobs) <= kqc_cutoff) ) THEN + profdata%var(1)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) + knumu = knumu + 1 + ENDIF + ! + END DO + ! + END DO + ! + END SUBROUTINE obs_uv_rej + + !!===================================================================== +END MODULE obs_prep diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_profiles.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_profiles.f90 new file mode 100644 index 0000000000000000000000000000000000000000..53735c526043ad89cc4254db03eac758eead03aa --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_profiles.f90 @@ -0,0 +1,52 @@ + + + + + + + + + + + + + +MODULE obs_profiles + !!===================================================================== + !! *** MODULE obs_profiles *** + !! Observation diagnostics: Storage space for profile observations + !! arrays and additional flags etc. + !!===================================================================== + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_profiles.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + + !! * Modules used + USE obs_profiles_def ! Definition of profile data types and tools + + IMPLICIT NONE + + SAVE + + !! * Routine accessibility + PRIVATE + + PUBLIC nprofsets, nprofvars, nprofextr, profdata, prodatqc + PUBLIC nvelosets, nvelovars, nveloextr, velodata, veldatqc + + !! * Shared Module variables + INTEGER :: nprofsets ! Total number of profile data sets + INTEGER :: nprofvars ! Total number of variables for profiles + INTEGER :: nprofextr ! Extra fields for each variable + TYPE(obs_prof), POINTER :: profdata(:) ! Initial profile data + TYPE(obs_prof), POINTER :: prodatqc(:) ! Profile data after quality control + + INTEGER :: nvelosets ! Total number of velocity profile data sets + INTEGER :: nvelovars ! Total number of variables for profiles + INTEGER :: nveloextr ! Extra fields for each variable + TYPE(obs_prof), POINTER :: velodata(:) ! Initial velocity profile data + TYPE(obs_prof), POINTER :: veldatqc(:) ! Velocity profile data after quality control +END MODULE obs_profiles diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_profiles_def.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_profiles_def.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b0b9463a36c090615f1e6b75cfb52d87135a706c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_profiles_def.f90 @@ -0,0 +1,940 @@ + + + + + + + + + + + + + +MODULE obs_profiles_def + !!===================================================================== + !! *** MODULE obs_profiles_def *** + !! Observation diagnostics: Storage handling for T,S profiles + !! arrays and additional flags etc. + !! This module only defines the data type and + !! operations on the data type. There is no + !! actual data in the module. + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_prof : F90 type containing the profile information + !! obs_prof_var : F90 type containing the variable definition + !! obs_prof_valid : F90 type containing the valid obs. definition + !! obs_prof_alloc : Allocates profile arrays + !! obs_prof_dealloc : Deallocates profile arrays + !! obs_prof_compress : Extract sub-information from a obs_prof type + !! to a new obs_prof type + !! obs_prof_decompress : Reinsert sub-information from a obs_prof type + !! into the original obs_prof type + !! obs_prof_staend : Set npvsta and npvend of a variable within an + !! obs_prof_var type + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE in_out_manager ! I/O manager + USE obs_mpp, ONLY : & ! MPP tools + obs_mpp_sum_integers + USE obs_fbm ! Obs feedback format + USE lib_mpp, ONLY : & + & ctl_warn, ctl_stop + + IMPLICIT NONE + + !! * Routine/type accessibility + PRIVATE + + PUBLIC & + & obs_prof, & + & obs_prof_var, & + & obs_prof_valid, & + & obs_prof_alloc, & + & obs_prof_alloc_var, & + & obs_prof_dealloc, & + & obs_prof_compress, & + & obs_prof_decompress,& + & obs_prof_staend + + !! * Type definition for valid observations + + TYPE obs_prof_valid + + LOGICAL, POINTER, DIMENSION(:) :: luse + + END TYPE obs_prof_valid + + !! * Type definition for each variable + + TYPE obs_prof_var + + ! Arrays with size equal to the number of observations + + INTEGER, POINTER, DIMENSION(:) :: & + & mvk, & !: k-th grid coord. for interpolating to profile data + & nvpidx,& !: Profile number + & nvlidx,& !: Level number in profile + & nvqc, & !: Variable QC flags + & idqc !: Depth QC flag + + REAL(KIND=wp), POINTER, DIMENSION(:) :: & + & vdep, & !: Depth coordinate of profile data + & vobs, & !: Profile data + & vmod !: Model counterpart of the profile data vector + + REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & + & vext !: Extra variables + + INTEGER, POINTER, DIMENSION(:) :: & + & nvind !: Source indices of temp. data in compressed data + + ! Arrays with size equal to idefnqcf times the number of observations + INTEGER, POINTER, DIMENSION(:,:) :: & + & idqcf, & !: Depth QC flags + & nvqcf !: Variable QC flags + + END TYPE obs_prof_var + + !! * Type definition for profile observation type + + TYPE obs_prof + + ! Bookkeeping + + INTEGER :: nvar !: Number of variables + INTEGER :: next !: Number of extra fields + INTEGER :: nprof !: Total number of profiles within window. + INTEGER :: nstp !: Number of time steps + INTEGER :: npi !: Number of 3D grid points + INTEGER :: npj + INTEGER :: npk + INTEGER :: nprofup !: Observation counter used in obs_oper + + ! Bookkeeping arrays with sizes equal to number of variables + + CHARACTER(len=8), POINTER, DIMENSION(:) :: & + & cvars !: Variable names + + INTEGER, POINTER, DIMENSION(:) :: & + & nvprot, & !: Local total number of profile T data + & nvprotmpp !: Global total number of profile T data + + ! Arrays with size equal to the number of profiles + + INTEGER, POINTER, DIMENSION(:) :: & + & npidx,& !: Profile number + & npfil,& !: Profile number in file + & nyea, & !: Year of profile + & nmon, & !: Month of profile + & nday, & !: Day of profile + & nhou, & !: Hour of profile + & nmin, & !: Minute of profile + & mstp, & !: Time step nearest to profile + & nqc, & !: Profile QC + & ntyp, & !: Type of profile product (WMO table 1770) + & ipqc, & !: Position QC + & itqc !: Time QC + + REAL(KIND=wp), POINTER, DIMENSION(:) :: & + & rlam, & !: Longitude coordinate of profile data + & rphi !: Latitude coordinate of profile data + + CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & + & cwmo !: Profile WMO indentifier + + ! Arrays with size equal to the number of profiles times + ! number of variables + + INTEGER, POINTER, DIMENSION(:,:) :: & + & npvsta, & !: Start of each variable profile in full arrays + & npvend, & !: End of each variable profile in full arrays + & mi, & !: i-th grid coord. for interpolating to profile T data + & mj, & !: j-th grid coord. for interpolating to profile T data + & ivqc !: QC flags for all levels for a variable + + ! Arrays with size equal to idefnqcf + ! the number of profiles times number of variables + INTEGER, POINTER, DIMENSION(:,:) :: & + & nqcf, & !: Observation QC flags + & ipqcf, & !: Position QC flags + & itqcf !: Time QC flags + + ! Arrays with size equal to idefnqcf + ! the number of profiles times number of variables + INTEGER, POINTER, DIMENSION(:,:,:) :: & + & ivqcf + + ! Arrays of variables + + TYPE(obs_prof_var), POINTER, DIMENSION(:) :: var + + ! Arrays with size equal to the number of time steps in the window + + INTEGER, POINTER, DIMENSION(:) :: & + & npstp, & !: Total number of profiles + & npstpmpp !: Total number of profiles + + ! Arrays with size equal to the number of time steps in the window times + ! number of variables + + INTEGER, POINTER, DIMENSION(:,:) :: & + & nvstp, & !: Local total num. of profile data each time step + & nvstpmpp !: Global total num. of profile data each time step + + ! Arrays with size equal to the number of grid points times number of + ! variables + + REAL(KIND=wp), POINTER, DIMENSION(:,:,:,:) :: & + & vdmean !: Daily averaged model field + + ! Arrays used to store source indices when + ! compressing obs_prof derived types + + ! Array with size nprof + + INTEGER, POINTER, DIMENSION(:) :: & + & npind !: Source indices of profile data in compressed data + + END TYPE obs_prof + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_profiles_def.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_prof_alloc( prof, kvar, kext, kprof, & + & ko3dt, kstp, kpi, kpj, kpk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_alloc *** + !! + !! ** Purpose : - Allocate data for profile arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-01 (K. Mogensen) Original code + !! ! 07-03 (K. Mogensen) Generalized profiles + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated + INTEGER, INTENT(IN) :: kprof ! Number of profiles + INTEGER, INTENT(IN) :: kvar ! Number of variables + INTEGER, INTENT(IN) :: kext ! Number of extra fields within each variable + INTEGER, INTENT(IN), DIMENSION(kvar) :: & + & ko3dt ! Number of observations per variables + INTEGER, INTENT(IN) :: kstp ! Number of time steps + INTEGER, INTENT(IN) :: kpi ! Number of 3D grid points + INTEGER, INTENT(IN) :: kpj + INTEGER, INTENT(IN) :: kpk + + !!* Local variables + INTEGER :: jvar + INTEGER :: ji + + ! Set bookkeeping variables + + prof%nvar = kvar + prof%next = kext + prof%nprof = kprof + + prof%nstp = kstp + prof%npi = kpi + prof%npj = kpj + prof%npk = kpk + + ! Allocate arrays of size number of variables + + ALLOCATE( & + & prof%cvars(kvar), & + & prof%nvprot(kvar), & + & prof%nvprotmpp(kvar) & + ) + + DO jvar = 1, kvar + prof%cvars (jvar) = "NotSet" + prof%nvprot (jvar) = ko3dt(jvar) + prof%nvprotmpp(jvar) = 0 + END DO + + ! Allocate arrays of size number of profiles + ! times number of variables + + ALLOCATE( & + & prof%npvsta(kprof,kvar), & + & prof%npvend(kprof,kvar), & + & prof%mi(kprof,kvar), & + & prof%mj(kprof,kvar), & + & prof%ivqc(kprof,kvar) & + ) + + ! Allocate arrays of size iqcfdef times number of profiles + ! times number of variables + + ALLOCATE( & + & prof%ivqcf(idefnqcf,kprof,kvar) & + & ) + + ! Allocate arrays of size number of profiles + + ALLOCATE( & + & prof%npidx(kprof), & + & prof%npfil(kprof), & + & prof%nyea(kprof), & + & prof%nmon(kprof), & + & prof%nday(kprof), & + & prof%nhou(kprof), & + & prof%nmin(kprof), & + & prof%mstp(kprof), & + & prof%nqc(kprof), & + & prof%ipqc(kprof), & + & prof%itqc(kprof), & + & prof%ntyp(kprof), & + & prof%rlam(kprof), & + & prof%rphi(kprof), & + & prof%cwmo(kprof), & + & prof%npind(kprof) & + & ) + + ! Allocate arrays of size idefnqcf times number of profiles + + ALLOCATE( & + & prof%nqcf(idefnqcf,kprof), & + & prof%ipqcf(idefnqcf,kprof), & + & prof%itqcf(idefnqcf,kprof) & + & ) + + ! Allocate obs_prof_var type + ALLOCATE( & + & prof%var(kvar) & + & ) + + ! For each variables allocate arrays of size number of observations + + DO jvar = 1, kvar + + IF ( ko3dt(jvar) >= 0 ) THEN + CALL obs_prof_alloc_var( prof, jvar, kext, ko3dt(jvar) ) + ENDIF + + END DO + + ! Allocate arrays of size number of time step size + + ALLOCATE( & + & prof%npstp(kstp), & + & prof%npstpmpp(kstp) & + & ) + + ! Allocate arrays of size number of time step size times + ! number of variables + + ALLOCATE( & + & prof%nvstp(kstp,kvar), & + & prof%nvstpmpp(kstp,kvar) & + & ) + + ! Allocate arrays of size number of grid points size times + ! number of variables + + ALLOCATE( & + & prof%vdmean(kpi,kpj,kpk,kvar) & + & ) + + ! Set defaults for compression indices + + DO ji = 1, kprof + prof%npind(ji) = ji + END DO + + DO jvar = 1, kvar + DO ji = 1, ko3dt(jvar) + prof%var(jvar)%nvind(ji) = ji + END DO + END DO + + ! Set defaults for number of observations per time step + + prof%npstp(:) = 0 + prof%npstpmpp(:) = 0 + prof%nvstp(:,:) = 0 + prof%nvstpmpp(:,:) = 0 + + ! Set the observation counter used in obs_oper + + prof%nprofup = 0 + + END SUBROUTINE obs_prof_alloc + + SUBROUTINE obs_prof_dealloc( prof ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_dealloc *** + !! + !! ** Purpose : - Deallocate data for profile arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-01 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: & + & prof ! Profile data to be deallocated + + !!* Local variables + INTEGER :: & + & jvar + + ! Deallocate arrays of size number of profiles + ! times number of variables + + DEALLOCATE( & + & prof%npvsta, & + & prof%npvend & + ) + + ! Dellocate arrays of size number of profiles size + + DEALLOCATE( & + & prof%mi, & + & prof%mj, & + & prof%ivqc, & + & prof%ivqcf, & + & prof%npidx, & + & prof%npfil, & + & prof%nyea, & + & prof%nmon, & + & prof%nday, & + & prof%nhou, & + & prof%nmin, & + & prof%mstp, & + & prof%nqc, & + & prof%ipqc, & + & prof%itqc, & + & prof%nqcf, & + & prof%ipqcf, & + & prof%itqcf, & + & prof%ntyp, & + & prof%rlam, & + & prof%rphi, & + & prof%cwmo, & + & prof%npind & + & ) + + ! For each variables allocate arrays of size number of observations + + DO jvar = 1, prof%nvar + + IF ( prof%nvprot(jvar) >= 0 ) THEN + + CALL obs_prof_dealloc_var( prof, jvar ) + + ENDIF + + END DO + + ! Dellocate obs_prof_var type + DEALLOCATE( & + & prof%var & + & ) + + ! Deallocate arrays of size number of time step size + + DEALLOCATE( & + & prof%npstp, & + & prof%npstpmpp & + & ) + + ! Deallocate arrays of size number of time step size times + ! number of variables + + DEALLOCATE( & + & prof%nvstp, & + & prof%nvstpmpp & + & ) + + ! Deallocate arrays of size number of grid points size times + ! number of variables + + DEALLOCATE( & + & prof%vdmean & + & ) + + ! Dellocate arrays of size number of variables + + DEALLOCATE( & + & prof%cvars, & + & prof%nvprot, & + & prof%nvprotmpp & + ) + + + END SUBROUTINE obs_prof_dealloc + + + SUBROUTINE obs_prof_alloc_var( prof, kvar, kext, kobs ) + + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_alloc_var *** + !! + !! ** Purpose : - Allocate data for variable data in profile arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-03 (K. Mogensen) Original code + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated + INTEGER, INTENT(IN) :: kvar ! Variable number + INTEGER, INTENT(IN) :: kext ! Number of extra fields within each variable + INTEGER, INTENT(IN) :: kobs ! Number of observations + + ALLOCATE( & + & prof%var(kvar)%mvk(kobs), & + & prof%var(kvar)%nvpidx(kobs), & + & prof%var(kvar)%nvlidx(kobs), & + & prof%var(kvar)%nvqc(kobs), & + & prof%var(kvar)%idqc(kobs), & + & prof%var(kvar)%vdep(kobs), & + & prof%var(kvar)%vobs(kobs), & + & prof%var(kvar)%vmod(kobs), & + & prof%var(kvar)%nvind(kobs) & + & ) + ALLOCATE( & + & prof%var(kvar)%idqcf(idefnqcf,kobs), & + & prof%var(kvar)%nvqcf(idefnqcf,kobs) & + & ) + IF (kext>0) THEN + ALLOCATE( & + & prof%var(kvar)%vext(kobs,kext) & + & ) + ENDIF + + END SUBROUTINE obs_prof_alloc_var + + SUBROUTINE obs_prof_dealloc_var( prof, kvar ) + + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_alloc_var *** + !! + !! ** Purpose : - Allocate data for variable data in profile arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-03 (K. Mogensen) Original code + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated + INTEGER, INTENT(IN) :: kvar ! Variable number + + DEALLOCATE( & + & prof%var(kvar)%mvk, & + & prof%var(kvar)%nvpidx, & + & prof%var(kvar)%nvlidx, & + & prof%var(kvar)%nvqc, & + & prof%var(kvar)%idqc, & + & prof%var(kvar)%vdep, & + & prof%var(kvar)%vobs, & + & prof%var(kvar)%vmod, & + & prof%var(kvar)%nvind, & + & prof%var(kvar)%idqcf, & + & prof%var(kvar)%nvqcf & + & ) + IF (prof%next>0) THEN + DEALLOCATE( & + & prof%var(kvar)%vext & + & ) + ENDIF + + END SUBROUTINE obs_prof_dealloc_var + + SUBROUTINE obs_prof_compress( prof, newprof, lallocate, & + & kumout, lvalid, lvvalid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_compress *** + !! + !! ** Purpose : - Extract sub-information from a obs_prof type + !! into a new obs_prof type + !! + !! ** Method : - The data is copied from prof to new prof. + !! In the case of lvalid and lvvalid both being + !! present only the selected data will be copied. + !! If lallocate is true the data in the newprof is + !! allocated either with the same number of elements + !! as prof or with only the subset of elements defined + !! by the optional selection in lvalid and lvvalid + !! + !! History : + !! ! 07-01 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof), INTENT(IN) :: prof ! Original profile + TYPE(obs_prof), INTENT(INOUT) :: newprof ! New profile with the copy of the data + LOGICAL, INTENT(IN) :: lallocate ! Allocate newprof data + INTEGER,INTENT(IN) :: kumout ! Fortran unit for messages + TYPE(obs_prof_valid), OPTIONAL, INTENT(in) :: & + & lvalid ! Valid profiles + TYPE(obs_prof_valid), OPTIONAL, INTENT(in), DIMENSION(prof%nvar) :: & + & lvvalid ! Valid data within the profiles + + !!* Local variables + INTEGER :: inprof + INTEGER, DIMENSION(prof%nvar) :: & + & invpro + INTEGER :: jvar + INTEGER :: jext + INTEGER :: ji + INTEGER :: jj + LOGICAL :: lfirst + TYPE(obs_prof_valid) :: & + & llvalid + TYPE(obs_prof_valid), DIMENSION(prof%nvar) :: & + & llvvalid + LOGICAL :: lallpresent + LOGICAL :: lnonepresent + + ! Check that either all or none of the masks are persent. + + lallpresent = .FALSE. + lnonepresent = .FALSE. + IF ( PRESENT(lvalid) .AND. PRESENT(lvvalid) ) THEN + lallpresent = .TRUE. + ELSEIF ( ( .NOT. PRESENT(lvalid) ) .AND. & + & ( .NOT. PRESENT(lvvalid) ) ) THEN + lnonepresent = .TRUE. + ELSE + CALL ctl_stop('Error in obs_prof_compress:', & + & 'Either all selection variables should be set', & + & 'or no selection variable should be set' ) + ENDIF + + ! Count how many elements there should be in the new data structure + + IF ( lallpresent ) THEN + inprof = 0 + invpro(:) = 0 + DO ji = 1, prof%nprof + IF ( lvalid%luse(ji) ) THEN + inprof=inprof+1 + DO jvar = 1, prof%nvar + DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar) + IF ( lvvalid(jvar)%luse(jj) ) & + & invpro(jvar) = invpro(jvar) +1 + END DO + END DO + ENDIF + END DO + ELSE + inprof = prof%nprof + invpro(:) = prof%nvprot(:) + ENDIF + + ! Optionally allocate data in the new data structure + + IF ( lallocate ) THEN + CALL obs_prof_alloc( newprof, prof%nvar, & + & prof%next, & + & inprof, invpro, & + & prof%nstp, prof%npi, & + & prof%npj, prof%npk ) + ENDIF + + ! Allocate temporary mask array to unify the code for both cases + + ALLOCATE( llvalid%luse(prof%nprof) ) + DO jvar = 1, prof%nvar + ALLOCATE( llvvalid(jvar)%luse(prof%nvprot(jvar)) ) + END DO + IF ( lallpresent ) THEN + llvalid%luse(:) = lvalid%luse(:) + DO jvar = 1, prof%nvar + llvvalid(jvar)%luse(:) = lvvalid(jvar)%luse(:) + END DO + ELSE + llvalid%luse(:) = .TRUE. + DO jvar = 1, prof%nvar + llvvalid(jvar)%luse(:) = .TRUE. + END DO + ENDIF + + ! Setup bookkeeping variables + + inprof = 0 + invpro(:) = 0 + + newprof%npvsta(:,:) = 0 + newprof%npvend(:,:) = -1 + + ! Loop over source profiles + + DO ji = 1, prof%nprof + + IF ( llvalid%luse(ji) ) THEN + + ! Copy the header information + + inprof = inprof + 1 + + newprof%mi(inprof,:) = prof%mi(ji,:) + newprof%mj(inprof,:) = prof%mj(ji,:) + newprof%npidx(inprof) = prof%npidx(ji) + newprof%npfil(inprof) = prof%npfil(ji) + newprof%nyea(inprof) = prof%nyea(ji) + newprof%nmon(inprof) = prof%nmon(ji) + newprof%nday(inprof) = prof%nday(ji) + newprof%nhou(inprof) = prof%nhou(ji) + newprof%nmin(inprof) = prof%nmin(ji) + newprof%mstp(inprof) = prof%mstp(ji) + newprof%nqc(inprof) = prof%nqc(ji) + newprof%ipqc(inprof) = prof%ipqc(ji) + newprof%itqc(inprof) = prof%itqc(ji) + newprof%ivqc(inprof,:)= prof%ivqc(ji,:) + newprof%ntyp(inprof) = prof%ntyp(ji) + newprof%rlam(inprof) = prof%rlam(ji) + newprof%rphi(inprof) = prof%rphi(ji) + newprof%cwmo(inprof) = prof%cwmo(ji) + + ! QC info + + newprof%nqcf(:,inprof) = prof%nqcf(:,ji) + newprof%ipqcf(:,inprof) = prof%ipqcf(:,ji) + newprof%itqcf(:,inprof) = prof%itqcf(:,ji) + newprof%ivqcf(:,inprof,:) = prof%ivqcf(:,ji,:) + + ! npind is the index of the original profile + + newprof%npind(inprof) = ji + + ! Copy the variable information + + DO jvar = 1, prof%nvar + + lfirst = .TRUE. + + DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar) + + IF ( llvvalid(jvar)%luse(jj) ) THEN + + invpro(jvar) = invpro(jvar) + 1 + + ! Book keeping information + + IF ( lfirst ) THEN + lfirst = .FALSE. + newprof%npvsta(inprof,jvar) = invpro(jvar) + ENDIF + newprof%npvend(inprof,jvar) = invpro(jvar) + + ! Variable data + + newprof%var(jvar)%mvk(invpro(jvar)) = & + & prof%var(jvar)%mvk(jj) + newprof%var(jvar)%nvpidx(invpro(jvar)) = & + & prof%var(jvar)%nvpidx(jj) + newprof%var(jvar)%nvlidx(invpro(jvar)) = & + & prof%var(jvar)%nvlidx(jj) + newprof%var(jvar)%nvqc(invpro(jvar)) = & + & prof%var(jvar)%nvqc(jj) + newprof%var(jvar)%idqc(invpro(jvar)) = & + & prof%var(jvar)%idqc(jj) + newprof%var(jvar)%idqcf(:,invpro(jvar))= & + & prof%var(jvar)%idqcf(:,jj) + newprof%var(jvar)%nvqcf(:,invpro(jvar))= & + & prof%var(jvar)%nvqcf(:,jj) + newprof%var(jvar)%vdep(invpro(jvar)) = & + & prof%var(jvar)%vdep(jj) + newprof%var(jvar)%vobs(invpro(jvar)) = & + & prof%var(jvar)%vobs(jj) + newprof%var(jvar)%vmod(invpro(jvar)) = & + & prof%var(jvar)%vmod(jj) + DO jext = 1, prof%next + newprof%var(jvar)%vext(invpro(jvar),jext) = & + & prof%var(jvar)%vext(jj,jext) + END DO + + ! nvind is the index of the original variable data + + newprof%var(jvar)%nvind(invpro(jvar)) = jj + + ENDIF + + END DO + + END DO + + ENDIF + + END DO + + ! Update MPP counters + + DO jvar = 1, prof%nvar + newprof%nvprot(jvar) = invpro(jvar) + END DO + CALL obs_mpp_sum_integers ( newprof%nvprot, newprof%nvprotmpp,& + & prof%nvar ) + + ! Set book keeping variables which do not depend on number of obs. + + newprof%nvar = prof%nvar + newprof%next = prof%next + newprof%nstp = prof%nstp + newprof%npi = prof%npi + newprof%npj = prof%npj + newprof%npk = prof%npk + newprof%cvars(:) = prof%cvars(:) + + ! Deallocate temporary data + + DO jvar = 1, prof%nvar + DEALLOCATE( llvvalid(jvar)%luse ) + END DO + + DEALLOCATE( llvalid%luse ) + + END SUBROUTINE obs_prof_compress + + SUBROUTINE obs_prof_decompress( prof, oldprof, ldeallocate, kumout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_decompress *** + !! + !! ** Purpose : - Copy back information to original profile type + !! + !! ** Method : - Reinsert updated information from a previous + !! copied/compressed profile type into the original + !! profile data and optionally deallocate the prof + !! data input + !! + !! History : + !! ! 07-01 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof),INTENT(INOUT) :: prof ! Updated profile data + TYPE(obs_prof),INTENT(INOUT) :: oldprof ! Original profile data + LOGICAL, INTENT(IN) :: ldeallocate ! Deallocate the updated data of insertion + INTEGER,INTENT(in) :: kumout ! Output unit + + !!* Local variables + INTEGER :: jvar + INTEGER :: jext + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jl + + DO ji = 1, prof%nprof + + ! Copy header information + + jk = prof%npind(ji) + + oldprof%mi(jk,:) = prof%mi(ji,:) + oldprof%mj(jk,:) = prof%mj(ji,:) + oldprof%npidx(jk) = prof%npidx(ji) + oldprof%npfil(jk) = prof%npfil(ji) + oldprof%nyea(jk) = prof%nyea(ji) + oldprof%nmon(jk) = prof%nmon(ji) + oldprof%nday(jk) = prof%nday(ji) + oldprof%nhou(jk) = prof%nhou(ji) + oldprof%nmin(jk) = prof%nmin(ji) + oldprof%mstp(jk) = prof%mstp(ji) + oldprof%nqc(jk) = prof%nqc(ji) + oldprof%ipqc(jk) = prof%ipqc(ji) + oldprof%itqc(jk) = prof%itqc(ji) + oldprof%ivqc(jk,:)= prof%ivqc(ji,:) + oldprof%ntyp(jk) = prof%ntyp(ji) + oldprof%rlam(jk) = prof%rlam(ji) + oldprof%rphi(jk) = prof%rphi(ji) + oldprof%cwmo(jk) = prof%cwmo(ji) + + ! QC info + + oldprof%nqcf(:,jk) = prof%nqcf(:,ji) + oldprof%ipqcf(:,jk) = prof%ipqcf(:,ji) + oldprof%itqcf(:,jk) = prof%itqcf(:,ji) + oldprof%ivqcf(:,jk,:) = prof%ivqcf(:,ji,:) + + ! Copy the variable information + + DO jvar = 1, prof%nvar + + DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar) + + jl = prof%var(jvar)%nvind(jj) + + oldprof%var(jvar)%mvk(jl) = prof%var(jvar)%mvk(jj) + oldprof%var(jvar)%nvpidx(jl) = prof%var(jvar)%nvpidx(jj) + oldprof%var(jvar)%nvlidx(jl) = prof%var(jvar)%nvlidx(jj) + oldprof%var(jvar)%nvqc(jl) = prof%var(jvar)%nvqc(jj) + oldprof%var(jvar)%idqc(jl) = prof%var(jvar)%idqc(jj) + oldprof%var(jvar)%vdep(jl) = prof%var(jvar)%vdep(jj) + oldprof%var(jvar)%vobs(jl) = prof%var(jvar)%vobs(jj) + oldprof%var(jvar)%vmod(jl) = prof%var(jvar)%vmod(jj) + oldprof%var(jvar)%idqcf(:,jl) = prof%var(jvar)%idqcf(:,jj) + oldprof%var(jvar)%nvqcf(:,jl) = prof%var(jvar)%nvqcf(:,jj) + DO jext = 1, prof%next + oldprof%var(jvar)%vext(jl,jext) = & + & prof%var(jvar)%vext(jj,jext) + END DO + + END DO + + END DO + + END DO + + ! Optionally deallocate the updated profile data + + IF ( ldeallocate ) CALL obs_prof_dealloc( prof ) + + END SUBROUTINE obs_prof_decompress + + SUBROUTINE obs_prof_staend( prof, kvarno ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_decompress *** + !! + !! ** Purpose : - Set npvsta and npvend of a variable within + !! an obs_prof_var type + !! + !! ** Method : - Find the start and stop of a profile by searching + !! through the data + !! + !! History : + !! ! 07-04 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof),INTENT(INOUT) :: prof ! Profile data + INTEGER,INTENT(IN) :: kvarno ! Variable number + + !!* Local variables + INTEGER :: ji + INTEGER :: iprofno + + !----------------------------------------------------------------------- + ! Compute start and end bookkeeping arrays + !----------------------------------------------------------------------- + + prof%npvsta(:,kvarno) = prof%nvprot(kvarno) + 1 + prof%npvend(:,kvarno) = -1 + DO ji = 1, prof%nvprot(kvarno) + iprofno = prof%var(kvarno)%nvpidx(ji) + prof%npvsta(iprofno,kvarno) = & + & MIN( ji, prof%npvsta(iprofno,kvarno) ) + prof%npvend(iprofno,kvarno) = & + & MAX( ji, prof%npvend(iprofno,kvarno) ) + END DO + + DO ji = 1, prof%nprof + IF ( prof%npvsta(ji,kvarno) == ( prof%nvprot(kvarno) + 1 ) ) & + & prof%npvsta(ji,kvarno) = 0 + END DO + + END SUBROUTINE obs_prof_staend + +END MODULE obs_profiles_def diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_read_altbias.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_read_altbias.f90 new file mode 100644 index 0000000000000000000000000000000000000000..822c9f730cfbec37ec36db6e2a36376f86a40f2a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_read_altbias.f90 @@ -0,0 +1,216 @@ + + + + + + + + + + + + + +MODULE obs_read_altbias + !!====================================================================== + !! *** MODULE obs_readaltbias *** + !! Observation diagnostics: Read the bias for SLA data + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_rea_altbias : Driver for reading altimeter bias + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp, & + & dp, & + & sp + USE par_oce, ONLY : & ! Domain parameters + & jpi, & + & jpj + USE in_out_manager, ONLY : & ! I/O manager + & lwp, & + & numout + USE obs_surf_def ! Surface observation definitions + USE dom_oce, ONLY : & ! Domain variables + & tmask, & + & tmask_i, & + & e1t, & + & e2t, & + & gphit + USE oce, ONLY : & ! Model variables + & ssh + USE obs_inter_h2d + USE obs_utils ! Various observation tools + USE obs_inter_sup + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_rea_altbias ! Read the altimeter bias + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_read_altbias.F90 15033 2021-06-21 10:24:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_rea_altbias( sladata, k2dint, bias_file ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_rea_altbias *** + !! + !! ** Purpose : Read from file the bias data + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! : 2008-02 (D. Lea) Initial version + !!---------------------------------------------------------------------- + !! * Modules used + USE iom + ! + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: & + & sladata ! SLA data + INTEGER, INTENT(IN) :: k2dint + CHARACTER(LEN=128) :: bias_file + + !! * Local declarations + + CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_rea_altbias' + + INTEGER :: jobs ! Obs loop variable + INTEGER :: jpialtbias ! Number of grid point in latitude for the bias + INTEGER :: jpjaltbias ! Number of grid point in longitude for the bias + INTEGER :: iico ! Grid point indicies + INTEGER :: ijco + INTEGER :: i_nx_id ! Index to read the NetCDF file + INTEGER :: i_ny_id ! + INTEGER :: i_file_id ! + INTEGER :: i_var_id + + REAL(wp), DIMENSION(1) :: & + & zext, & + & zobsmask + REAL(wp), DIMENSION(2,2,1) :: & + & zweig + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmask, & + & zbias, & + & zglam, & + & zgphi + REAL(wp), DIMENSION(jpi,jpj) :: z_altbias + REAL(wp) :: zlam + REAL(wp) :: zphi + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdi, & + & igrdj + INTEGER :: numaltbias + + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) ' obs_rea_altbias : ' + IF(lwp)WRITE(numout,*) ' ------------- ' + IF(lwp)WRITE(numout,*) ' Read altimeter bias' + + ! Open the file + + z_altbias(:,:)=0.0_wp + numaltbias=0 + + IF(lwp)WRITE(numout,*) 'Opening ',bias_file + + CALL iom_open( bias_file, numaltbias, ldstop=.FALSE. ) + + + IF (numaltbias .GT. 0) THEN + + ! Get the Alt bias data + + CALL iom_get( numaltbias, jpdom_global, 'altbias', z_altbias(:,:) ) + + ! Close the file + + CALL iom_close(numaltbias) + + ELSE + + IF(lwp)WRITE(numout,*) 'no file found' + + ENDIF + + ! Intepolate the bias already on the model grid at the observation point + + ALLOCATE( & + & igrdi(2,2,sladata%nsurf), & + & igrdj(2,2,sladata%nsurf), & + & zglam(2,2,sladata%nsurf), & + & zgphi(2,2,sladata%nsurf), & + & zmask(2,2,sladata%nsurf), & + & zbias(2,2,sladata%nsurf) & + & ) + + DO jobs = 1, sladata%nsurf + + igrdi(1,1,jobs) = sladata%mi(jobs)-1 + igrdj(1,1,jobs) = sladata%mj(jobs)-1 + igrdi(1,2,jobs) = sladata%mi(jobs)-1 + igrdj(1,2,jobs) = sladata%mj(jobs) + igrdi(2,1,jobs) = sladata%mi(jobs) + igrdj(2,1,jobs) = sladata%mj(jobs)-1 + igrdi(2,2,jobs) = sladata%mi(jobs) + igrdj(2,2,jobs) = sladata%mj(jobs) + + END DO + + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & + & igrdi, igrdj, glamt, zglam ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & + & igrdi, igrdj, gphit, zgphi ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & + & igrdi, igrdj, tmask(:,:,1), zmask ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & + & igrdi, igrdj, z_altbias, zbias ) + + DO jobs = 1, sladata%nsurf + + zlam = sladata%rlam(jobs) + zphi = sladata%rphi(jobs) + iico = sladata%mi(jobs) + ijco = sladata%mj(jobs) + + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam(:,:,jobs), zgphi(:,:,jobs), & + & zmask(:,:,jobs), zweig, zobsmask ) + + CALL obs_int_h2d( 1, 1, & + & zweig, zbias(:,:,jobs), zext ) + + ! adjust mdt with bias field + sladata%rext(jobs,2) = sladata%rext(jobs,2) - zext(1) + + END DO + + DEALLOCATE( & + & igrdi, & + & igrdj, & + & zglam, & + & zgphi, & + & zmask, & + & zbias & + & ) + + END SUBROUTINE obs_rea_altbias + + + +END MODULE obs_read_altbias diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_read_prof.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_read_prof.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e4a7eed10ca585a9b889d95fb58f992276d3fdec --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_read_prof.f90 @@ -0,0 +1,837 @@ + + + + + + + + + + + + + +MODULE obs_read_prof + !!====================================================================== + !! *** MODULE obs_read_prof *** + !! Observation diagnostics: Read the T and S profile observations + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_rea_pro_dri : Driver for reading profile obs + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind ! Precision variables + USE par_oce ! Ocean parameters + USE in_out_manager ! I/O manager + USE dom_oce ! Ocean space and time domain variables + USE obs_mpp ! MPP support routines for observation diagnostics + USE julian ! Julian date routines + USE obs_utils ! Observation operator utility functions + USE obs_prep ! Prepare observation arrays + USE obs_grid ! Grid search + USE obs_sort ! Sorting observation arrays + USE obs_profiles_def ! Profile definitions + USE obs_conv ! Various conversion routines + USE obs_types ! Observation type definitions + USE netcdf ! NetCDF library + USE obs_oper ! Observation operators + USE lib_mpp ! For ctl_warn/stop + USE obs_fbm ! Feedback routines + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_rea_prof ! Read the profile observations + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_read_prof.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, & + & kvars, kextr, kstp, ddobsini, ddobsend, & + & ldvar, ldignmis, ldsatt, & + & ldmod, cdvars, kdailyavtypes ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_rea_prof *** + !! + !! ** Purpose : Read from file the profile observations + !! + !! ** Method : Read feedback data in and transform to NEMO internal + !! profile data structure + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! : 2009-09 (K. Mogensen) : New merged version of old routines + !! ! : 2015-08 (M. Martin) : Merged profile and velocity routines + !!---------------------------------------------------------------------- + + !! * Arguments + TYPE(obs_prof), INTENT(OUT) :: & + & profdata ! Profile data to be read + INTEGER, INTENT(IN) :: knumfiles ! Number of files to read + CHARACTER(LEN=128), INTENT(IN) :: & + & cdfilenames(knumfiles) ! File names to read in + INTEGER, INTENT(IN) :: kvars ! Number of variables in profdata + INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var + INTEGER, INTENT(IN) :: kstp ! Ocean time-step index + LOGICAL, DIMENSION(kvars), INTENT(IN) :: ldvar ! Observed variables switches + LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files + LOGICAL, INTENT(IN) :: ldsatt ! Compute salinity at all temperature points + LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data + REAL(wp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS + REAL(wp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS + CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars + INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & + & kdailyavtypes ! Types of daily average observations + + !! * Local declarations + CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof' + CHARACTER(len=8) :: clrefdate + CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin + INTEGER :: jvar + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: ij + INTEGER :: iflag + INTEGER :: inobf + INTEGER :: i_file_id + INTEGER :: inowin + INTEGER :: iyea + INTEGER :: imon + INTEGER :: iday + INTEGER :: ihou + INTEGER :: imin + INTEGER :: isec + INTEGER :: iprof + INTEGER :: iproftot + INTEGER, DIMENSION(kvars) :: ivart0 + INTEGER, DIMENSION(kvars) :: ivart + INTEGER :: ip3dt + INTEGER :: ios + INTEGER :: ioserrcount + INTEGER, DIMENSION(kvars) :: ivartmpp + INTEGER :: ip3dtmpp + INTEGER :: itype + INTEGER, DIMENSION(knumfiles) :: & + & irefdate + INTEGER, DIMENSION(ntyp1770+1,kvars) :: & + & itypvar, & + & itypvarmpp + INTEGER, DIMENSION(:,:), ALLOCATABLE :: & + & iobsi, & + & iobsj, & + & iproc + INTEGER, DIMENSION(:), ALLOCATABLE :: & + & iindx, & + & ifileidx, & + & iprofidx + INTEGER, DIMENSION(imaxavtypes) :: & + & idailyavtypes + INTEGER, DIMENSION(kvars) :: & + & iv3dt + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zphi, & + & zlam + REAL(dp), DIMENSION(:), ALLOCATABLE :: & + & zdat + REAL(dp), DIMENSION(knumfiles) :: & + & djulini, & + & djulend + LOGICAL :: llvalprof + LOGICAL :: lldavtimset + LOGICAL :: llcycle + TYPE(obfbdata), POINTER, DIMENSION(:) :: & + & inpfiles + + ! Local initialization + iprof = 0 + ivart0(:) = 0 + ip3dt = 0 + + ! Daily average types + lldavtimset = .FALSE. + IF ( PRESENT(kdailyavtypes) ) THEN + idailyavtypes(:) = kdailyavtypes(:) + IF ( ANY (idailyavtypes(:) /= -1) ) lldavtimset = .TRUE. + ELSE + idailyavtypes(:) = -1 + ENDIF + + !----------------------------------------------------------------------- + ! Count the number of files needed and allocate the obfbdata type + !----------------------------------------------------------------------- + + inobf = knumfiles + + ALLOCATE( inpfiles(inobf) ) + + prof_files : DO jj = 1, inobf + + !--------------------------------------------------------------------- + ! Prints + !--------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' obs_rea_pro_dri : Reading from file = ', & + & TRIM( TRIM( cdfilenames(jj) ) ) + WRITE(numout,*) ' ~~~~~~~~~~~~~~~' + WRITE(numout,*) + ENDIF + + !--------------------------------------------------------------------- + ! Initialization: Open file and get dimensions only + !--------------------------------------------------------------------- + + iflag = nf90_open( TRIM( cdfilenames(jj) ), nf90_nowrite, & + & i_file_id ) + + IF ( iflag /= nf90_noerr ) THEN + + IF ( ldignmis ) THEN + inpfiles(jj)%nobs = 0 + CALL ctl_warn( 'File ' // TRIM( cdfilenames(jj) ) // & + & ' not found' ) + ELSE + CALL ctl_stop( 'File ' // TRIM( cdfilenames(jj) ) // & + & ' not found' ) + ENDIF + + ELSE + + !------------------------------------------------------------------ + ! Close the file since it is opened in read_obfbdata + !------------------------------------------------------------------ + + iflag = nf90_close( i_file_id ) + + !------------------------------------------------------------------ + ! Read the profile file into inpfiles + !------------------------------------------------------------------ + CALL init_obfbdata( inpfiles(jj) ) + CALL read_obfbdata( TRIM( cdfilenames(jj) ), inpfiles(jj), & + & ldgrid = .TRUE. ) + + IF ( inpfiles(jj)%nvar /= kvars ) THEN + CALL ctl_stop( 'Feedback format error: ', & + & ' unexpected number of vars in profile file' ) + ENDIF + + IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN + CALL ctl_stop( 'Model not in input data' ) + ENDIF + + IF ( jj == 1 ) THEN + ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) + DO ji = 1, inpfiles(jj)%nvar + clvarsin(ji) = inpfiles(jj)%cname(ji) + IF ( clvarsin(ji) /= cdvars(ji) ) THEN + CALL ctl_stop( 'Feedback file variables do not match', & + & ' expected variable names for this type' ) + ENDIF + END DO + ELSE + DO ji = 1, inpfiles(jj)%nvar + IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN + CALL ctl_stop( 'Feedback file variables not consistent', & + & ' with previous files for this type' ) + ENDIF + END DO + ENDIF + + !------------------------------------------------------------------ + ! Change longitude (-180,180) + !------------------------------------------------------------------ + + DO ji = 1, inpfiles(jj)%nobs + + IF ( inpfiles(jj)%plam(ji) < -180. ) & + & inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) + 360. + + IF ( inpfiles(jj)%plam(ji) > 180. ) & + & inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) - 360. + + END DO + + !------------------------------------------------------------------ + ! Calculate the date (change eventually) + !------------------------------------------------------------------ + clrefdate=inpfiles(jj)%cdjuldref(1:8) + READ(clrefdate,'(I8)') irefdate(jj) + + CALL ddatetoymdhms( ddobsini, iyea, imon, iday, ihou, imin, isec ) + CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulini(jj), & + & krefdate = irefdate(jj) ) + CALL ddatetoymdhms( ddobsend, iyea, imon, iday, ihou, imin, isec ) + CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulend(jj), & + & krefdate = irefdate(jj) ) + + ioserrcount=0 + IF ( lldavtimset ) THEN + + IF ( ANY ( idailyavtypes(:) /= -1 ) .AND. lwp) THEN + WRITE(numout,*)' Resetting time of daily averaged', & + & ' observations to the end of the day' + ENDIF + + DO ji = 1, inpfiles(jj)%nobs + READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 900 ) itype +900 IF ( ios /= 0 ) THEN + ! Set type to zero if there is a problem in the string conversion + itype = 0 + ENDIF + + IF ( ANY ( idailyavtypes(:) == itype ) ) THEN + ! for daily averaged data force the time + ! to be the last time-step of the day, but still within the day. + IF ( inpfiles(jj)%ptim(ji) >= 0. ) THEN + inpfiles(jj)%ptim(ji) = & + & INT(inpfiles(jj)%ptim(ji)) + 0.9999 + ELSE + inpfiles(jj)%ptim(ji) = & + & INT(inpfiles(jj)%ptim(ji)) - 0.0001 + ENDIF + ENDIF + + END DO + + ENDIF + + IF ( inpfiles(jj)%nobs > 0 ) THEN + inpfiles(jj)%iproc(:,:) = -1 + inpfiles(jj)%iobsi(:,:) = -1 + inpfiles(jj)%iobsj(:,:) = -1 + ENDIF + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + ENDIF + END DO + ALLOCATE( zlam(inowin) ) + ALLOCATE( zphi(inowin) ) + ALLOCATE( iobsi(inowin,kvars) ) + ALLOCATE( iobsj(inowin,kvars) ) + ALLOCATE( iproc(inowin,kvars) ) + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + zlam(inowin) = inpfiles(jj)%plam(ji) + zphi(inowin) = inpfiles(jj)%pphi(ji) + ENDIF + END DO + + ! Assume anything other than velocity is on T grid + IF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN + CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & + & iproc(:,1), 'U' ) + CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,2), iobsj(:,2), & + & iproc(:,2), 'V' ) + ELSE + CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & + & iproc(:,1), 'T' ) + IF ( kvars > 1 ) THEN + DO jvar = 2, kvars + iobsi(:,jvar) = iobsi(:,1) + iobsj(:,jvar) = iobsj(:,1) + iproc(:,jvar) = iproc(:,1) + END DO + ENDIF + ENDIF + + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + DO jvar = 1, kvars + inpfiles(jj)%iproc(ji,jvar) = iproc(inowin,jvar) + inpfiles(jj)%iobsi(ji,jvar) = iobsi(inowin,jvar) + inpfiles(jj)%iobsj(ji,jvar) = iobsj(inowin,jvar) + END DO + IF ( kvars > 1 ) THEN + DO jvar = 2, kvars + IF ( inpfiles(jj)%iproc(ji,jvar) /= & + & inpfiles(jj)%iproc(ji,1) ) THEN + CALL ctl_stop( 'Error in obs_read_prof:', & + & 'observation on different processors for different vars') + ENDIF + END DO + ENDIF + ENDIF + END DO + DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc ) + + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + IF ( narea == 1 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > narea-1 ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE + ENDIF + llvalprof = .FALSE. + DO jvar = 1, kvars + IF ( ldvar(jvar) ) THEN + DO ij = 1,inpfiles(jj)%nlev + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN + ivart0(jvar) = ivart0(jvar) + 1 + ENDIF + END DO + ENDIF + END DO + DO ij = 1,inpfiles(jj)%nlev + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + DO jvar = 1, kvars + IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar(jvar) ) ) THEN + ip3dt = ip3dt + 1 + llvalprof = .TRUE. + EXIT + ENDIF + END DO + END DO + + IF ( llvalprof ) iprof = iprof + 1 + + ENDIF + END DO + + ENDIF + + END DO prof_files + + !----------------------------------------------------------------------- + ! Get the time ordered indices of the input data + !----------------------------------------------------------------------- + + !--------------------------------------------------------------------- + ! Loop over input data files to count total number of profiles + !--------------------------------------------------------------------- + iproftot = 0 + DO jj = 1, inobf + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + iproftot = iproftot + 1 + ENDIF + END DO + END DO + + ALLOCATE( iindx(iproftot), ifileidx(iproftot), & + & iprofidx(iproftot), zdat(iproftot) ) + jk = 0 + DO jj = 1, inobf + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + jk = jk + 1 + ifileidx(jk) = jj + iprofidx(jk) = ji + zdat(jk) = inpfiles(jj)%ptim(ji) + ENDIF + END DO + END DO + CALL sort_dp_indx( iproftot, & + & zdat, & + & iindx ) + + iv3dt(:) = -1 + IF (ldsatt) THEN + iv3dt(:) = ip3dt + ELSE + iv3dt(:) = ivart0(:) + ENDIF + CALL obs_prof_alloc( profdata, kvars, kextr, iprof, iv3dt, & + & kstp, jpi, jpj, jpk ) + + ! * Read obs/positions, QC, all variable and assign to profdata + + profdata%nprof = 0 + profdata%nvprot(:) = 0 + profdata%cvars(:) = clvarsin(:) + iprof = 0 + + ip3dt = 0 + ivart(:) = 0 + itypvar (:,:) = 0 + itypvarmpp(:,:) = 0 + + ioserrcount = 0 + DO jk = 1, iproftot + + jj = ifileidx(iindx(jk)) + ji = iprofidx(iindx(jk)) + + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + + IF ( narea == 1 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > narea-1 ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE + ENDIF + + llvalprof = .FALSE. + + IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE + + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + + loop_prof : DO ij = 1, inpfiles(jj)%nlev + + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + + DO jvar = 1, kvars + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN + + llvalprof = .TRUE. + EXIT loop_prof + + ENDIF + END DO + + END DO loop_prof + + ! Set profile information + + IF ( llvalprof ) THEN + + iprof = iprof + 1 + + CALL jul2greg( isec, & + & imin, & + & ihou, & + & iday, & + & imon, & + & iyea, & + & inpfiles(jj)%ptim(ji), & + & irefdate(jj) ) + + + ! Profile time coordinates + profdata%nyea(iprof) = iyea + profdata%nmon(iprof) = imon + profdata%nday(iprof) = iday + profdata%nhou(iprof) = ihou + profdata%nmin(iprof) = imin + + ! Profile space coordinates + profdata%rlam(iprof) = inpfiles(jj)%plam(ji) + profdata%rphi(iprof) = inpfiles(jj)%pphi(ji) + + ! Coordinate search parameters + DO jvar = 1, kvars + profdata%mi (iprof,jvar) = inpfiles(jj)%iobsi(ji,jvar) + profdata%mj (iprof,jvar) = inpfiles(jj)%iobsj(ji,jvar) + END DO + + ! Profile WMO number + profdata%cwmo(iprof) = inpfiles(jj)%cdwmo(ji) + + ! Instrument type + READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 901 ) itype +901 IF ( ios /= 0 ) THEN + IF (ioserrcount == 0) CALL ctl_warn ( 'Problem converting an instrument type to integer. Setting type to zero' ) + ioserrcount = ioserrcount + 1 + itype = 0 + ENDIF + + profdata%ntyp(iprof) = itype + + ! QC stuff + + profdata%nqc(iprof) = inpfiles(jj)%ioqc(ji) + profdata%nqcf(:,iprof) = inpfiles(jj)%ioqcf(:,ji) + profdata%ipqc(iprof) = inpfiles(jj)%ipqc(ji) + profdata%ipqcf(:,iprof) = inpfiles(jj)%ipqcf(:,ji) + profdata%itqc(iprof) = inpfiles(jj)%itqc(ji) + profdata%itqcf(:,iprof) = inpfiles(jj)%itqcf(:,ji) + profdata%ivqc(iprof,:) = inpfiles(jj)%ivqc(ji,:) + profdata%ivqcf(:,iprof,:) = inpfiles(jj)%ivqcf(:,ji,:) + + ! Bookkeeping data to match profiles + profdata%npidx(iprof) = iprof + profdata%npfil(iprof) = iindx(jk) + + ! Observation QC flag (whole profile) + profdata%nqc(iprof) = 0 !TODO + + loop_p : DO ij = 1, inpfiles(jj)%nlev + + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + + IF (ldsatt) THEN + + DO jvar = 1, kvars + IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar(jvar) ) ) THEN + ip3dt = ip3dt + 1 + EXIT + ELSE IF ( jvar == kvars ) THEN + CYCLE loop_p + ENDIF + END DO + + ENDIF + + DO jvar = 1, kvars + + IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar(jvar) ) .OR. ldsatt ) THEN + + IF (ldsatt) THEN + + ivart(jvar) = ip3dt + + ELSE + + ivart(jvar) = ivart(jvar) + 1 + + ENDIF + + ! Depth of jvar observation + profdata%var(jvar)%vdep(ivart(jvar)) = & + & inpfiles(jj)%pdep(ij,ji) + + ! Depth of jvar observation QC + profdata%var(jvar)%idqc(ivart(jvar)) = & + & inpfiles(jj)%idqc(ij,ji) + + ! Depth of jvar observation QC flags + profdata%var(jvar)%idqcf(:,ivart(jvar)) = & + & inpfiles(jj)%idqcf(:,ij,ji) + + ! Profile index + profdata%var(jvar)%nvpidx(ivart(jvar)) = iprof + + ! Vertical index in original profile + profdata%var(jvar)%nvlidx(ivart(jvar)) = ij + + ! Profile jvar value + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN + profdata%var(jvar)%vobs(ivart(jvar)) = & + & inpfiles(jj)%pob(ij,ji,jvar) + IF ( ldmod ) THEN + profdata%var(jvar)%vmod(ivart(jvar)) = & + & inpfiles(jj)%padd(ij,ji,1,jvar) + ENDIF + ! Count number of profile var1 data as function of type + itypvar( profdata%ntyp(iprof) + 1, jvar ) = & + & itypvar( profdata%ntyp(iprof) + 1, jvar ) + 1 + ELSE + profdata%var(jvar)%vobs(ivart(jvar)) = fbrmdi + ENDIF + + ! Profile jvar qc + profdata%var(jvar)%nvqc(ivart(jvar)) = & + & inpfiles(jj)%ivlqc(ij,ji,jvar) + + ! Profile jvar qc flags + profdata%var(jvar)%nvqcf(:,ivart(jvar)) = & + & inpfiles(jj)%ivlqcf(:,ij,ji,jvar) + + ! Profile insitu T value + IF ( TRIM( inpfiles(jj)%cname(jvar) ) == 'POTM' ) THEN + profdata%var(jvar)%vext(ivart(jvar),1) = & + & inpfiles(jj)%pext(ij,ji,1) + ENDIF + + ENDIF + + END DO + + END DO loop_p + + ENDIF + + ENDIF + + END DO + + !----------------------------------------------------------------------- + ! Sum up over processors + !----------------------------------------------------------------------- + + DO jvar = 1, kvars + CALL obs_mpp_sum_integer ( ivart0(jvar), ivartmpp(jvar) ) + END DO + CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp ) + + DO jvar = 1, kvars + CALL obs_mpp_sum_integers( itypvar(:,jvar), itypvarmpp(:,jvar), ntyp1770 + 1 ) + END DO + + !----------------------------------------------------------------------- + ! Output number of observations. + !----------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,'(A)') ' Profile data' + WRITE(numout,'(1X,A)') '------------' + WRITE(numout,*) + DO jvar = 1, kvars + WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(jvar) ) + WRITE(numout,'(1X,A)') '------------------------' + DO ji = 0, ntyp1770 + IF ( itypvarmpp(ji+1,jvar) > 0 ) THEN + WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & + & cwmonam1770(ji)(1:52),' = ', & + & itypvarmpp(ji+1,jvar) + ENDIF + END DO + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,'(1X,A55,I8)') & + & 'Total profile data for variable '//TRIM( profdata%cvars(jvar) )// & + & ' = ', ivartmpp(jvar) + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,*) + END DO + ENDIF + + IF (ldsatt) THEN + profdata%nvprot(:) = ip3dt + profdata%nvprotmpp(:) = ip3dtmpp + ELSE + DO jvar = 1, kvars + profdata%nvprot(jvar) = ivart(jvar) + profdata%nvprotmpp(jvar) = ivartmpp(jvar) + END DO + ENDIF + profdata%nprof = iprof + + !----------------------------------------------------------------------- + ! Model level search + !----------------------------------------------------------------------- + DO jvar = 1, kvars + IF ( ldvar(jvar) ) THEN + CALL obs_level_search( jpk, gdept_1d, & + & profdata%nvprot(jvar), profdata%var(jvar)%vdep, & + & profdata%var(jvar)%mvk ) + ENDIF + END DO + + !----------------------------------------------------------------------- + ! Set model equivalent to 99999 + !----------------------------------------------------------------------- + IF ( .NOT. ldmod ) THEN + DO jvar = 1, kvars + profdata%var(jvar)%vmod(:) = fbrmdi + END DO + ENDIF + !----------------------------------------------------------------------- + ! Deallocate temporary data + !----------------------------------------------------------------------- + DEALLOCATE( ifileidx, iprofidx, zdat, clvarsin ) + + !----------------------------------------------------------------------- + ! Deallocate input data + !----------------------------------------------------------------------- + DO jj = 1, inobf + CALL dealloc_obfbdata( inpfiles(jj) ) + END DO + DEALLOCATE( inpfiles ) + + END SUBROUTINE obs_rea_prof + +END MODULE obs_read_prof diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_read_surf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_read_surf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..82af305f1a8a8fca2b1a408c4f0df1478757f719 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_read_surf.f90 @@ -0,0 +1,519 @@ + + + + + + + + + + + + + +MODULE obs_read_surf + !!====================================================================== + !! *** MODULE obs_read_surf *** + !! Observation diagnostics: Read the surface data from feedback files + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_rea_surf : Driver for reading surface data from feedback files + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind ! Precision variables + USE in_out_manager ! I/O manager + USE dom_oce ! Ocean space and time domain variables + USE obs_mpp ! MPP support routines for observation diagnostics + USE julian ! Julian date routines + USE obs_utils ! Observation operator utility functions + USE obs_grid ! Grid search + USE obs_sort ! Sorting observation arrays + USE obs_surf_def ! Surface observation definitions + USE obs_types ! Observation type definitions + USE obs_fbm ! Feedback routines + USE netcdf ! NetCDF library + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_rea_surf ! Read the surface observations from the point data + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_read_surf.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_rea_surf( surfdata, knumfiles, cdfilenames, & + & kvars, kextr, kstp, ddobsini, ddobsend, & + & ldignmis, ldmod, ldnightav, cdvars ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_rea_surf *** + !! + !! ** Purpose : Read from file the surface data + !! + !! ** Method : Read in the data from feedback format files and + !! put into the NEMO internal surface data structure + !! + !! ** Action : + !! + !! + !! History : + !! ! : 2009-01 (K. Mogensen) Initial version based on old versions + !! ! : 2015-02 (M. Martin) Unify the different surface data type reading. + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: & + & surfdata ! Surface data to be read + INTEGER, INTENT(IN) :: knumfiles ! Number of corio format files to read + CHARACTER(LEN=128), INTENT(IN) :: & + & cdfilenames(knumfiles) ! File names to read in + INTEGER, INTENT(IN) :: kvars ! Number of variables in surfdata + INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var + INTEGER, INTENT(IN) :: kstp ! Ocean time-step index + LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files + LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data + LOGICAL, INTENT(IN) :: ldnightav ! Observations represent a night-time average + REAL(wp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS + REAL(wp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS + CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars + + !! * Local declarations + CHARACTER(LEN=11), PARAMETER :: cpname='obs_rea_surf' + CHARACTER(len=8) :: clrefdate + CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: iflag + INTEGER :: inobf + INTEGER :: i_file_id + INTEGER :: inowin + INTEGER :: iyea + INTEGER :: imon + INTEGER :: iday + INTEGER :: ihou + INTEGER :: imin + INTEGER :: isec + INTEGER :: itype + INTEGER :: iobsmpp + INTEGER :: iobs + INTEGER :: iobstot + INTEGER :: ios + INTEGER :: ioserrcount + INTEGER, PARAMETER :: jpsurfmaxtype = 1024 + INTEGER, DIMENSION(knumfiles) :: irefdate + INTEGER, DIMENSION(jpsurfmaxtype+1) :: & + & ityp, & + & itypmpp + INTEGER, DIMENSION(:), ALLOCATABLE :: & + & iobsi, & + & iobsj, & + & iproc, & + & iindx, & + & ifileidx, & + & isurfidx + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zphi, & + & zlam + REAL(dp), DIMENSION(:), ALLOCATABLE :: & + & zdat + REAL(dp), DIMENSION(knumfiles) :: & + & djulini, & + & djulend + LOGICAL :: llvalprof + TYPE(obfbdata), POINTER, DIMENSION(:) :: & + & inpfiles + + ! Local initialization + iobs = 0 + + !----------------------------------------------------------------------- + ! Count the number of files needed and allocate the obfbdata type + !----------------------------------------------------------------------- + + inobf = knumfiles + + ALLOCATE( inpfiles(inobf) ) + + surf_files : DO jj = 1, inobf + + !--------------------------------------------------------------------- + ! Prints + !--------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' obs_rea_surf : Reading from file = ', & + & TRIM( TRIM( cdfilenames(jj) ) ) + WRITE(numout,*) ' ~~~~~~~~~~~' + WRITE(numout,*) + ENDIF + + !--------------------------------------------------------------------- + ! Initialization: Open file and get dimensions only + !--------------------------------------------------------------------- + + iflag = nf90_open( TRIM( TRIM( cdfilenames(jj) ) ), nf90_nowrite, & + & i_file_id ) + + IF ( iflag /= nf90_noerr ) THEN + + IF ( ldignmis ) THEN + inpfiles(jj)%nobs = 0 + CALL ctl_warn( 'File ' // TRIM( TRIM( cdfilenames(jj) ) ) // & + & ' not found' ) + ELSE + CALL ctl_stop( 'File ' // TRIM( TRIM( cdfilenames(jj) ) ) // & + & ' not found' ) + ENDIF + + ELSE + + !------------------------------------------------------------------ + ! Close the file since it is opened in read_obfbdata + !------------------------------------------------------------------ + + iflag = nf90_close( i_file_id ) + + !------------------------------------------------------------------ + ! Read the surface file into inpfiles + !------------------------------------------------------------------ + CALL init_obfbdata( inpfiles(jj) ) + CALL read_obfbdata( TRIM( cdfilenames(jj) ), inpfiles(jj), & + & ldgrid = .TRUE. ) + + IF ( inpfiles(jj)%nvar /= kvars ) THEN + CALL ctl_stop( 'Feedback format error: ', & + & ' unexpected number of vars in feedback file' ) + ENDIF + + IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN + CALL ctl_stop( 'Model not in input data' ) + RETURN + ENDIF + + IF ( jj == 1 ) THEN + ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) + DO ji = 1, inpfiles(jj)%nvar + clvarsin(ji) = inpfiles(jj)%cname(ji) + IF ( clvarsin(ji) /= cdvars(ji) ) THEN + CALL ctl_stop( 'Feedback file variables do not match', & + & ' expected variable names for this type' ) + ENDIF + END DO + ELSE + DO ji = 1, inpfiles(jj)%nvar + IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN + CALL ctl_stop( 'Feedback file variables not consistent', & + & ' with previous files for this type' ) + ENDIF + END DO + ENDIF + + IF (lwp) WRITE(numout,*)'Observation file contains ',inpfiles(jj)%nobs,' observations' + + !------------------------------------------------------------------ + ! Change longitude (-180,180) + !------------------------------------------------------------------ + + DO ji = 1, inpfiles(jj)%nobs + + IF ( inpfiles(jj)%plam(ji) < -180. ) & + & inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) + 360. + + IF ( inpfiles(jj)%plam(ji) > 180. ) & + & inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) - 360. + + END DO + + !------------------------------------------------------------------ + ! Calculate the date (change eventually) + !------------------------------------------------------------------ + clrefdate=inpfiles(jj)%cdjuldref(1:8) + READ(clrefdate,'(I8)') irefdate(jj) + + CALL ddatetoymdhms( ddobsini, iyea, imon, iday, ihou, imin, isec ) + CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulini(jj), & + & krefdate = irefdate(jj) ) + CALL ddatetoymdhms( ddobsend, iyea, imon, iday, ihou, imin, isec ) + CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulend(jj), & + & krefdate = irefdate(jj) ) + + IF ( ldnightav ) THEN + + IF ( lwp ) THEN + WRITE(numout,*)'Resetting time of night-time averaged observations', & + & ' to the end of the day' + ENDIF + + DO ji = 1, inpfiles(jj)%nobs + ! for night-time averaged data force the time + ! to be the last time-step of the day, but still within the day. + IF ( inpfiles(jj)%ptim(ji) >= 0. ) THEN + inpfiles(jj)%ptim(ji) = & + & INT(inpfiles(jj)%ptim(ji)) + 0.9999 + ELSE + inpfiles(jj)%ptim(ji) = & + & INT(inpfiles(jj)%ptim(ji)) - 0.0001 + ENDIF + END DO + ENDIF + + IF ( inpfiles(jj)%nobs > 0 ) THEN + inpfiles(jj)%iproc = -1 + inpfiles(jj)%iobsi = -1 + inpfiles(jj)%iobsj = -1 + ENDIF + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + ENDIF + END DO + ALLOCATE( zlam(inowin) ) + ALLOCATE( zphi(inowin) ) + ALLOCATE( iobsi(inowin) ) + ALLOCATE( iobsj(inowin) ) + ALLOCATE( iproc(inowin) ) + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + zlam(inowin) = inpfiles(jj)%plam(ji) + zphi(inowin) = inpfiles(jj)%pphi(ji) + ENDIF + END DO + + CALL obs_grid_search( inowin, zlam, zphi, iobsi, iobsj, iproc, 'T' ) + + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + inpfiles(jj)%iproc(ji,1) = iproc(inowin) + inpfiles(jj)%iobsi(ji,1) = iobsi(inowin) + inpfiles(jj)%iobsj(ji,1) = iobsj(inowin) + ENDIF + END DO + DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc ) + + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + IF ( narea == 1 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > narea-1 ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE + ENDIF + llvalprof = .FALSE. + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(1,ji,1),2) ) THEN + iobs = iobs + 1 + ENDIF + ENDIF + END DO + + ENDIF + + END DO surf_files + + !----------------------------------------------------------------------- + ! Get the time ordered indices of the input data + !----------------------------------------------------------------------- + + !--------------------------------------------------------------------- + ! Loop over input data files to count total number of profiles + !--------------------------------------------------------------------- + iobstot = 0 + DO jj = 1, inobf + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + iobstot = iobstot + 1 + ENDIF + END DO + END DO + + ALLOCATE( iindx(iobstot), ifileidx(iobstot), & + & isurfidx(iobstot), zdat(iobstot) ) + jk = 0 + DO jj = 1, inobf + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + jk = jk + 1 + ifileidx(jk) = jj + isurfidx(jk) = ji + zdat(jk) = inpfiles(jj)%ptim(ji) + ENDIF + END DO + END DO + CALL sort_dp_indx( iobstot, & + & zdat, & + & iindx ) + + CALL obs_surf_alloc( surfdata, iobs, kvars, kextr, kstp, jpi, jpj ) + + ! Read obs/positions, QC, all variable and assign to surfdata + + iobs = 0 + + surfdata%cvars(:) = clvarsin(:) + + ityp (:) = 0 + itypmpp(:) = 0 + + ioserrcount = 0 + + DO jk = 1, iobstot + + jj = ifileidx(iindx(jk)) + ji = isurfidx(iindx(jk)) + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + + IF ( narea == 1 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > narea-1 ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE + ENDIF + + ! Set observation information + + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(1,ji,1),2) ) THEN + + iobs = iobs + 1 + + CALL jul2greg( isec, & + & imin, & + & ihou, & + & iday, & + & imon, & + & iyea, & + & inpfiles(jj)%ptim(ji), & + & irefdate(jj) ) + + + ! Surface time coordinates + surfdata%nyea(iobs) = iyea + surfdata%nmon(iobs) = imon + surfdata%nday(iobs) = iday + surfdata%nhou(iobs) = ihou + surfdata%nmin(iobs) = imin + + ! Surface space coordinates + surfdata%rlam(iobs) = inpfiles(jj)%plam(ji) + surfdata%rphi(iobs) = inpfiles(jj)%pphi(ji) + + ! Coordinate search parameters + surfdata%mi (iobs) = inpfiles(jj)%iobsi(ji,1) + surfdata%mj (iobs) = inpfiles(jj)%iobsj(ji,1) + + ! WMO number + surfdata%cwmo(iobs) = inpfiles(jj)%cdwmo(ji) + + ! Instrument type + READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 901 ) itype +901 IF ( ios /= 0 ) THEN + IF (ioserrcount == 0) THEN + CALL ctl_warn ( 'Problem converting an instrument type ', & + & 'to integer. Setting type to zero' ) + ENDIF + ioserrcount = ioserrcount + 1 + itype = 0 + ENDIF + surfdata%ntyp(iobs) = itype + IF ( itype < jpsurfmaxtype + 1 ) THEN + ityp(itype+1) = ityp(itype+1) + 1 + ELSE + IF(lwp)WRITE(numout,*)'WARNING:Increase jpsurfmaxtype in ',& + & cpname + ENDIF + + ! Bookkeeping data to match observations + surfdata%nsidx(iobs) = iobs + surfdata%nsfil(iobs) = iindx(jk) + + ! QC flags + surfdata%nqc(iobs) = inpfiles(jj)%ivqc(ji,1) + + ! Observed value + surfdata%robs(iobs,1) = inpfiles(jj)%pob(1,ji,1) + + + ! Model and MDT is set to fbrmdi unless read from file + IF ( ldmod ) THEN + surfdata%rmod(iobs,1) = inpfiles(jj)%padd(1,ji,1,1) + IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) THEN + surfdata%rext(iobs,1) = inpfiles(jj)%padd(1,ji,2,1) + surfdata%rext(iobs,2) = inpfiles(jj)%pext(1,ji,1) + ENDIF + ELSE + surfdata%rmod(iobs,1) = fbrmdi + IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) surfdata%rext(iobs,:) = fbrmdi + ENDIF + ENDIF + ENDIF + + END DO + + !----------------------------------------------------------------------- + ! Sum up over processors + !----------------------------------------------------------------------- + + CALL obs_mpp_sum_integer( iobs, iobsmpp ) + CALL obs_mpp_sum_integers( ityp, itypmpp, jpsurfmaxtype + 1 ) + + !----------------------------------------------------------------------- + ! Output number of observations. + !----------------------------------------------------------------------- + IF (lwp) THEN + + WRITE(numout,*) + WRITE(numout,'(1X,A)')TRIM( surfdata%cvars(1) )//' data' + WRITE(numout,'(1X,A)')'--------------' + DO jj = 1,8 + IF ( itypmpp(jj) > 0 ) THEN + WRITE(numout,'(1X,A4,I4,A3,I10)')'Type ', jj,' = ',itypmpp(jj) + ENDIF + END DO + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,'(1X,A,I8)') & + & 'Total data for variable '//TRIM( surfdata%cvars(1) )// & + & ' = ', iobsmpp + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,*) + + ENDIF + + !----------------------------------------------------------------------- + ! Deallocate temporary data + !----------------------------------------------------------------------- + DEALLOCATE( ifileidx, isurfidx, zdat, clvarsin ) + + !----------------------------------------------------------------------- + ! Deallocate input data + !----------------------------------------------------------------------- + DO jj = 1, inobf + IF ( inpfiles(jj)%lalloc ) THEN + CALL dealloc_obfbdata( inpfiles(jj) ) + ENDIF + END DO + DEALLOCATE( inpfiles ) + + END SUBROUTINE obs_rea_surf + +END MODULE obs_read_surf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_readmdt.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_readmdt.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f117be2e00d49378a85c061bfb3df87803e1c79d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_readmdt.f90 @@ -0,0 +1,276 @@ + + + + + + + + + + + + + +MODULE obs_readmdt + !!====================================================================== + !! *** MODULE obs_readmdt *** + !! Observation diagnostics: Read the MDT for SLA data (skeleton for now) + !!====================================================================== + !! History : ! 2007-03 (K. Mogensen) Initial skeleton version + !! ! 2007-04 (E. Remy) migration and improvement from OPAVAR + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! obs_rea_mdt : Driver for reading MDT + !! obs_offset_mdt : Remove the offset between the model MDT and the used one + !!---------------------------------------------------------------------- + USE par_kind ! Precision variables + USE par_oce ! Domain parameters + USE in_out_manager ! I/O manager + USE obs_surf_def ! Surface observation definitions + USE obs_inter_sup ! Interpolation support routines + USE obs_inter_h2d ! 2D interpolation + USE obs_utils ! Various observation tools + USE iom_nf90 ! IOM NetCDF + USE netcdf ! NetCDF library + USE lib_mpp ! MPP library + USE dom_oce, ONLY : & ! Domain variables + & tmask, tmask_i, e1e2t, gphit, glamt + USE obs_const, ONLY : obfillflt ! Fillvalue + USE oce , ONLY : ssh ! Model variables + + IMPLICIT NONE + PRIVATE + + PUBLIC obs_rea_mdt ! called by dia_obs_init + PUBLIC obs_offset_mdt ! called by obs_rea_mdt + + INTEGER , PUBLIC :: nn_msshc = 1 ! MDT correction scheme + REAL(wp), PUBLIC :: rn_mdtcorr = 1.61_wp ! User specified MDT correction + REAL(wp), PUBLIC :: rn_mdtcutoff = 65.0_wp ! MDT cutoff for computed correction + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_readmdt.F90 13295 2020-07-10 18:24:21Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE obs_rea_mdt( sladata, k2dint, Kmm ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_rea_mdt *** + !! + !! ** Purpose : Read from file the MDT data (skeleton) + !! + !! ** Method : + !! + !! ** Action : + !!---------------------------------------------------------------------- + USE iom + ! + TYPE(obs_surf), INTENT(inout) :: sladata ! SLA data + INTEGER , INTENT(in) :: k2dint ! ? + INTEGER , INTENT(in) :: Kmm ! ? + ! + CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_rea_mdt' + CHARACTER(LEN=20), PARAMETER :: mdtname = 'slaReferenceLevel.nc' + + INTEGER :: jobs ! Obs loop variable + INTEGER :: jpimdt, jpjmdt ! Number of grid point in lat/lon for the MDT + INTEGER :: iico, ijco ! Grid point indicies + INTEGER :: i_nx_id, i_ny_id, i_file_id, i_var_id, i_stat + INTEGER :: nummdt + ! + REAL(wp), DIMENSION(1) :: zext, zobsmask + REAL(wp), DIMENSION(2,2,1) :: zweig + ! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmask, zmdtl, zglam, zgphi + INTEGER , DIMENSION(:,:,:), ALLOCATABLE :: igrdi, igrdj + ! + REAL(wp), DIMENSION(jpi,jpj) :: z_mdt, mdtmask + + REAL(wp) :: zlam, zphi, zfill, zinfill ! local scalar + !!---------------------------------------------------------------------- + + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) ' obs_rea_mdt : Read MDT for referencing altimeter anomalies' + IF(lwp)WRITE(numout,*) ' ------------- ' + CALL FLUSH(numout) + + CALL iom_open( mdtname, nummdt ) ! Open the file + ! ! Get the MDT data + CALL iom_get ( nummdt, jpdom_global, 'sossheig', z_mdt(:,:) ) + CALL iom_close(nummdt) ! Close the file + + ! Read in the fill value + zinfill = 0.0 + i_stat = nf90_open( mdtname, nf90_nowrite, nummdt ) + i_stat = nf90_inq_varid( nummdt, 'sossheig', i_var_id ) + i_stat = nf90_get_att( nummdt, i_var_id, "_FillValue",zinfill) + zfill = zinfill + i_stat = nf90_close( nummdt ) + + ! setup mask based on tmask and MDT mask + ! set mask to 0 where the MDT is set to fillvalue + WHERE(z_mdt(:,:) /= zfill) ; mdtmask(:,:) = tmask(:,:,1) + ELSE WHERE ; mdtmask(:,:) = 0 + END WHERE + + ! Remove the offset between the MDT used with the sla and the model MDT + IF( nn_msshc == 1 .OR. nn_msshc == 2 ) & + & CALL obs_offset_mdt( jpi, jpj, z_mdt, zfill, Kmm ) + + ! Intepolate the MDT already on the model grid at the observation point + + ALLOCATE( & + & igrdi(2,2,sladata%nsurf), & + & igrdj(2,2,sladata%nsurf), & + & zglam(2,2,sladata%nsurf), & + & zgphi(2,2,sladata%nsurf), & + & zmask(2,2,sladata%nsurf), & + & zmdtl(2,2,sladata%nsurf) & + & ) + + DO jobs = 1, sladata%nsurf + + igrdi(1,1,jobs) = sladata%mi(jobs)-1 + igrdj(1,1,jobs) = sladata%mj(jobs)-1 + igrdi(1,2,jobs) = sladata%mi(jobs)-1 + igrdj(1,2,jobs) = sladata%mj(jobs) + igrdi(2,1,jobs) = sladata%mi(jobs) + igrdj(2,1,jobs) = sladata%mj(jobs)-1 + igrdi(2,2,jobs) = sladata%mi(jobs) + igrdj(2,2,jobs) = sladata%mj(jobs) + + END DO + + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, glamt , zglam ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, gphit , zgphi ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, mdtmask, zmask ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, z_mdt , zmdtl ) + + DO jobs = 1, sladata%nsurf + + zlam = sladata%rlam(jobs) + zphi = sladata%rphi(jobs) + + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam(:,:,jobs), zgphi(:,:,jobs), & + & zmask(:,:,jobs), zweig, zobsmask ) + + CALL obs_int_h2d( 1, 1, zweig, zmdtl(:,:,jobs), zext ) + + sladata%rext(jobs,2) = zext(1) + +! mark any masked data with a QC flag + IF( zobsmask(1) == 0 ) sladata%nqc(jobs) = IBSET(sladata%nqc(jobs),15) + + END DO + + DEALLOCATE( & + & igrdi, & + & igrdj, & + & zglam, & + & zgphi, & + & zmask, & + & zmdtl & + & ) + + IF(lwp)WRITE(numout,*) ' ------------- ' + ! + END SUBROUTINE obs_rea_mdt + + + SUBROUTINE obs_offset_mdt( kpi, kpj, mdt, zfill, Kmm ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_offset_mdt *** + !! + !! ** Purpose : Compute a correction term for the MDT on the model grid + !! !!!!! IF it is on the model grid + !! + !! ** Method : Compute the mean difference between the model and the + !! used MDT and remove the offset. + !! + !! ** Action : + !!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kpi, kpj + INTEGER, INTENT(IN) :: Kmm + REAL(wp), DIMENSION(kpi,kpj), INTENT(INOUT) :: mdt ! MDT used on the model grid + REAL(wp) , INTENT(IN ) :: zfill + ! + INTEGER :: ji, jj + REAL(wp) :: zdxdy, zarea, zeta1, zeta2, zcorr_mdt, zcorr_bcketa, zcorr ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zpromsk + CHARACTER(LEN=14), PARAMETER :: cpname = 'obs_offset_mdt' + !!---------------------------------------------------------------------- + + ! Initialize the local mask, for domain projection + ! Also exclude mdt points which are set to missing data + + DO ji = 1, jpi + DO jj = 1, jpj + zpromsk(ji,jj) = tmask_i(ji,jj) + IF ( ( gphit(ji,jj) .GT. rn_mdtcutoff ) & + &.OR.( gphit(ji,jj) .LT. -rn_mdtcutoff ) & + &.OR.( mdt(ji,jj) .EQ. zfill ) ) & + & zpromsk(ji,jj) = 0.0 + END DO + END DO + + ! Compute MSSH mean over [0,360] x [-rn_mdtcutoff,rn_mdtcutoff] + + zarea = 0.0 + zeta1 = 0.0 + zeta2 = 0.0 + + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zdxdy = e1e2t(ji,jj) * zpromsk(ji,jj) + zarea = zarea + zdxdy + zeta1 = zeta1 + mdt(ji,jj) * zdxdy + zeta2 = zeta2 + ssh(ji,jj,Kmm) * zdxdy + END DO ; END DO + + CALL mpp_sum( 'obs_readmdt', zeta1 ) + CALL mpp_sum( 'obs_readmdt', zeta2 ) + CALL mpp_sum( 'obs_readmdt', zarea ) + + zcorr_mdt = zeta1 / zarea + zcorr_bcketa = zeta2 / zarea + + ! Define correction term + + zcorr = zcorr_mdt - zcorr_bcketa + + ! Correct spatial mean of the MSSH + + IF( nn_msshc == 1 ) mdt(:,:) = mdt(:,:) - zcorr + + ! User defined value : 1.6 m for the Rio MDT compared to ORCA2 MDT + + IF( nn_msshc == 2 ) mdt(:,:) = mdt(:,:) - rn_mdtcorr + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' obs_readmdt : rn_mdtcutoff = ', rn_mdtcutoff + WRITE(numout,*) ' ----------- zcorr_mdt = ', zcorr_mdt + WRITE(numout,*) ' zcorr_bcketa = ', zcorr_bcketa + WRITE(numout,*) ' zcorr = ', zcorr + WRITE(numout,*) ' nn_msshc = ', nn_msshc + ENDIF + + IF ( nn_msshc == 0 ) WRITE(numout,*) ' MSSH correction is not applied' + IF ( nn_msshc == 1 ) WRITE(numout,*) ' MSSH correction is applied' + IF ( nn_msshc == 2 ) WRITE(numout,*) ' User defined MSSH correction' + + ! + END SUBROUTINE obs_offset_mdt + + !!====================================================================== +END MODULE obs_readmdt diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_rot_vel.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_rot_vel.f90 new file mode 100644 index 0000000000000000000000000000000000000000..52792a1a67fe080371d06d76b7d030f8b2d1602a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_rot_vel.f90 @@ -0,0 +1,241 @@ + + + + + + + + + + + + + +MODULE obs_rot_vel + !!====================================================================== + !! *** MODULE obs_rot_vel *** + !! Observation diagnostics: Read the velocity profile observations + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_rotvel : Rotate velocity data into N-S,E-W directorions + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind ! Precision variables + USE par_oce ! Ocean parameters + USE in_out_manager ! I/O manager + USE dom_oce ! Ocean space and time domain variables + USE obs_grid ! Grid search + USE obs_utils ! For error handling + USE obs_profiles_def ! Profile definitions + USE obs_inter_h2d ! Horizontal interpolation + USE obs_inter_sup ! MPP support routines for interpolation + USE geo2ocean ! Rotation of vectors + USE obs_fbm ! Feedback definitions + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_rotvel ! Rotate the observations + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_rot_vel.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_rotvel( profdata, k2dint, pu, pv ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_rea_pro_dri *** + !! + !! ** Purpose : Rotate velocity data into N-S,E-W directorions + !! + !! ** Method : Interpolation of geo2ocean coefficients on U,V grid + !! to observation point followed by a similar computations + !! as in geo2ocean. + !! + !! ** Action : Review if there is a better way to do this. + !! + !! References : + !! + !! History : + !! ! : 2009-02 (K. Mogensen) : New routine + !!---------------------------------------------------------------------- + !! * Modules used + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: profdata ! Profile data to be read + INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation methed + REAL(wp), DIMENSION(:) :: & + & pu, & + & pv + !! * Local declarations + REAL(wp), DIMENSION(2,2,1) :: zweig + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmasku, & + & zmaskv, & + & zcoslu, & + & zsinlu, & + & zcoslv, & + & zsinlv, & + & zglamu, & + & zgphiu, & + & zglamv, & + & zgphiv + REAL(wp), DIMENSION(1) :: & + & zsinu, & + & zcosu, & + & zsinv, & + & zcosv + REAL(wp) :: zsin + REAL(wp) :: zcos + REAL(wp), DIMENSION(1) :: zobsmask + REAL(wp), DIMENSION(jpi,jpj) :: zsingu,zcosgu,zsingv,zcosgv + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdiu, & + & igrdju, & + & igrdiv, & + & igrdjv + INTEGER :: ji + INTEGER :: jk + + + !----------------------------------------------------------------------- + ! Allocate data for message parsing and interpolation + !----------------------------------------------------------------------- + + ALLOCATE( & + & igrdiu(2,2,profdata%nprof), & + & igrdju(2,2,profdata%nprof), & + & zglamu(2,2,profdata%nprof), & + & zgphiu(2,2,profdata%nprof), & + & zmasku(2,2,profdata%nprof), & + & zcoslu(2,2,profdata%nprof), & + & zsinlu(2,2,profdata%nprof), & + & igrdiv(2,2,profdata%nprof), & + & igrdjv(2,2,profdata%nprof), & + & zglamv(2,2,profdata%nprof), & + & zgphiv(2,2,profdata%nprof), & + & zmaskv(2,2,profdata%nprof), & + & zcoslv(2,2,profdata%nprof), & + & zsinlv(2,2,profdata%nprof) & + & ) + + !----------------------------------------------------------------------- + ! Receive the angles on the U and V grids. + !----------------------------------------------------------------------- + + CALL obs_rot( zsingu, zcosgu, zsingv, zcosgv ) + + DO ji = 1, profdata%nprof + igrdiu(1,1,ji) = profdata%mi(ji,1)-1 + igrdju(1,1,ji) = profdata%mj(ji,1)-1 + igrdiu(1,2,ji) = profdata%mi(ji,1)-1 + igrdju(1,2,ji) = profdata%mj(ji,1) + igrdiu(2,1,ji) = profdata%mi(ji,1) + igrdju(2,1,ji) = profdata%mj(ji,1)-1 + igrdiu(2,2,ji) = profdata%mi(ji,1) + igrdju(2,2,ji) = profdata%mj(ji,1) + igrdiv(1,1,ji) = profdata%mi(ji,2)-1 + igrdjv(1,1,ji) = profdata%mj(ji,2)-1 + igrdiv(1,2,ji) = profdata%mi(ji,2)-1 + igrdjv(1,2,ji) = profdata%mj(ji,2) + igrdiv(2,1,ji) = profdata%mi(ji,2) + igrdjv(2,1,ji) = profdata%mj(ji,2)-1 + igrdiv(2,2,ji) = profdata%mi(ji,2) + igrdjv(2,2,ji) = profdata%mj(ji,2) + END DO + + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & + & glamu, zglamu ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & + & gphiu, zgphiu ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & + & umask(:,:,1), zmasku ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & + & zsingu, zsinlu ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & + & zcosgu, zcoslu ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & + & glamv, zglamv ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & + & gphiv, zgphiv ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & + & vmask(:,:,1), zmaskv ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & + & zsingv, zsinlv ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & + & zcosgv, zcoslv ) + + DO ji = 1, profdata%nprof + + CALL obs_int_h2d_init( 1, 1, k2dint, & + & profdata%rlam(ji), profdata%rphi(ji), & + & zglamu(:,:,ji), zgphiu(:,:,ji), & + & zmasku(:,:,ji), zweig, zobsmask ) + + CALL obs_int_h2d( 1, 1, zweig, zsinlu(:,:,ji), zsinu ) + + CALL obs_int_h2d( 1, 1, zweig, zcoslu(:,:,ji), zcosu ) + + CALL obs_int_h2d_init( 1, 1, k2dint, & + & profdata%rlam(ji), profdata%rphi(ji), & + & zglamv(:,:,ji), zgphiv(:,:,ji), & + & zmaskv(:,:,ji), zweig, zobsmask ) + + CALL obs_int_h2d( 1, 1, zweig, zsinlv(:,:,ji), zsinv ) + + CALL obs_int_h2d( 1, 1, zweig, zcoslv(:,:,ji), zcosv ) + + ! Assume that the angle at observation point is the + ! mean of u and v cosines/sines + + zcos = 0.5_wp * ( zcosu(1) + zcosv(1) ) + zsin = 0.5_wp * ( zsinu(1) + zsinv(1) ) + + IF ( ( profdata%npvsta(ji,1) /= profdata%npvsta(ji,2) ) .OR. & + & ( profdata%npvend(ji,1) /= profdata%npvend(ji,2) ) ) THEN + CALL fatal_error( 'Different number of U and V observations '// & + 'in a profile in obs_rotvel', 190 ) + ENDIF + + DO jk = profdata%npvsta(ji,1), profdata%npvend(ji,1) + IF ( ( profdata%var(1)%vmod(jk) /= fbrmdi ) .AND. & + & ( profdata%var(2)%vmod(jk) /= fbrmdi ) ) THEN + pu(jk) = profdata%var(1)%vmod(jk) * zcos - & + & profdata%var(2)%vmod(jk) * zsin + pv(jk) = profdata%var(2)%vmod(jk) * zcos + & + & profdata%var(1)%vmod(jk) * zsin + ELSE + pu(jk) = fbrmdi + pv(jk) = fbrmdi + ENDIF + + END DO + + END DO + + DEALLOCATE( & + & igrdiu, & + & igrdju, & + & zglamu, & + & zgphiu, & + & zmasku, & + & zcoslu, & + & zsinlu, & + & igrdiv, & + & igrdjv, & + & zglamv, & + & zgphiv, & + & zmaskv, & + & zcoslv, & + & zsinlv & + & ) + + END SUBROUTINE obs_rotvel + +END MODULE obs_rot_vel diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_sort.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_sort.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4d183a5fdc215f563f31368ade49234402af3ff5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_sort.f90 @@ -0,0 +1,159 @@ + + + + + + + + + + + + + +MODULE obs_sort + !!===================================================================== + !! *** MODULE obs_sort *** + !! Observation diagnostics: Various tools for sorting etc. + !!===================================================================== + + !!---------------------------------------------------------------------- + !! sort_dp_indx : Get indicies for ascending order for a double prec. array + !! index_sort : Get indicies for ascending order for a double prec. array + !!--------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & dp + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE index_sort ! Get indicies for ascending order for a double prec. array + + PUBLIC sort_dp_indx ! Get indicies for ascending order for a double prec. array + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_sort.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE sort_dp_indx( kvals, pvals, kindx ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sort_dp_indx *** + !! + !! ** Purpose : Get indicies for ascending order for a double precision array + !! + !! ** Method : Call index_sort routine + !! + !! ** Action : + !! + !! History : + !! ! 06-05 (K. Mogensen) Original code + !! ! 06-10 (A. Weaver) Cleaning + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kvals ! Number of elements to be sorted + REAL(KIND=dp), DIMENSION(kvals), INTENT(IN) :: & + & pvals ! Array to be sorted + INTEGER, DIMENSION(kvals), INTENT(OUT) :: & + & kindx ! Indices for ordering of array + + !! * Local declarations + + !----------------------------------------------------------------------- + ! Call qsort routine + !----------------------------------------------------------------------- + IF (kvals>=1) THEN + + CALL index_sort( pvals, kindx, kvals ) + + ENDIF + + END SUBROUTINE sort_dp_indx + + SUBROUTINE index_sort( pval, kindx, kvals ) + !!---------------------------------------------------------------------- + !! *** ROUTINE index_sort *** + !! + !! ** Purpose : Get indicies for ascending order for a double precision array + !! + !! ** Method : Heapsort + !! + !! ** Action : + !! + !! References : http://en.wikipedia.org/wiki/Heapsort + !! + !! History : + !! ! 06-05 (K. Mogensen) Original code + !! ! 06-10 (A. Weaver) Cleaning + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kvals ! Number of values + REAL(KIND=dp), DIMENSION(kvals), INTENT(IN) :: & + & pval ! Array to be sorted + INTEGER, DIMENSION(kvals), INTENT(INOUT) :: & + & kindx ! Indicies for ordering + + !! * Local declarations + INTEGER :: ji + INTEGER :: jj + INTEGER :: jt + INTEGER :: jn + INTEGER :: jparent + INTEGER :: jchild + + DO ji = 1, kvals + kindx(ji) = ji + END DO + + ji = kvals/2 + 1 + jn = kvals + + main_loop : DO + + IF ( ji > 1 ) THEN + ji = ji-1 + jt = kindx(ji) + ELSE + jt = kindx(jn) + kindx(jn) = kindx(1) + jn = jn-1 + IF ( jn <= 1 ) THEN + kindx(1) = jt + EXIT main_loop + ENDIF + ENDIF + + jparent = ji + jchild = 2 * ji + + inner_loop : DO + + IF ( jchild > jn ) EXIT inner_loop + IF ( jchild < jn ) THEN + IF ( pval(kindx(jchild)) < pval(kindx(jchild+1)) ) THEN + jchild = jchild+1 + ENDIF + ENDIF + IF ( pval(jt) < pval(kindx(jchild))) THEN + kindx(jparent) = kindx(jchild) + jparent = jchild + jchild = jchild*2 + ELSE + jchild = jn + 1 + ENDIF + + END DO inner_loop + + kindx(jparent) = jt + + END DO main_loop + + END SUBROUTINE index_sort + +END MODULE obs_sort diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_sstbias.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_sstbias.f90 new file mode 100644 index 0000000000000000000000000000000000000000..571adcc88eb4682d6f31cac2a6d99d6dd1838ac3 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_sstbias.f90 @@ -0,0 +1,255 @@ + + + + + + + + + + + + + +MODULE obs_sstbias + !!====================================================================== + !! *** MODULE obs_sstbias *** + !! Observation diagnostics: Read the bias for SST data + !!====================================================================== + !!---------------------------------------------------------------------- + !! obs_app_sstbias : Driver for reading and applying the SST bias + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp, & + & dp, & + & sp + USE par_oce, ONLY : & ! Domain parameters + & jpi, & + & jpj + USE in_out_manager, ONLY : & ! I/O manager + & lwp, & + & numout + USE obs_surf_def ! Surface observation definitions + USE dom_oce, ONLY : & ! Domain variables + & tmask, & + & tmask_i, & + & e1t, & + & e2t, & + & gphit, & + & glamt + USE oce, ONLY : & ! Model variables + & ssh + USE obs_inter_h2d + USE obs_utils ! Various observation tools + USE obs_inter_sup + IMPLICIT NONE + !! * Routine accessibility + PRIVATE + PUBLIC obs_app_sstbias ! Read the altimeter bias +CONTAINS + SUBROUTINE obs_app_sstbias( sstdata, k2dint, knumtypes, & + cl_bias_files ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_app_sstbias *** + !! + !! ** Purpose : Read SST bias data from files and apply correction to + !! observations + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! : 2014-08 (J. While) Bias correction code for SST obs, + !! ! based on obs_rea_altbias + !!---------------------------------------------------------------------- + !! * Modules used + USE iom + USE netcdf + !! * Arguments + + TYPE(obs_surf), INTENT(INOUT) :: sstdata ! SST data + INTEGER, INTENT(IN) :: k2dint + INTEGER, INTENT(IN) :: knumtypes !number of bias types to read in + CHARACTER(LEN=128), DIMENSION(knumtypes), INTENT(IN) :: & + cl_bias_files !List of files to read + !! * Local declarations + INTEGER :: jobs ! Obs loop variable + INTEGER :: jpisstbias ! Number of grid point in latitude for the bias + INTEGER :: jpjsstbias ! Number of grid point in longitude for the bias + INTEGER :: iico ! Grid point indices + INTEGER :: ijco + INTEGER :: jt + INTEGER :: i_nx_id ! Index to read the NetCDF file + INTEGER :: i_ny_id ! + INTEGER :: i_file_id ! + INTEGER :: i_var_id + INTEGER, DIMENSION(knumtypes) :: & + & ibiastypes ! Array of the bias types in each file + REAL(wp), DIMENSION(jpi,jpj,knumtypes) :: & + & z_sstbias ! Array to store the SST bias values + REAL(wp), DIMENSION(jpi,jpj) :: & + & z_sstbias_2d ! Array to store the SST bias values + REAL(wp), DIMENSION(1) :: & + & zext, & + & zobsmask + REAL(wp), DIMENSION(2,2,1) :: & + & zweig + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmask, & + & zglam, & + & zgphi + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmask_tmp, & + & zglam_tmp, & + & zgphi_tmp + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zbias + REAL(wp) :: zlam + REAL(wp) :: zphi + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdi, & + & igrdj + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdi_tmp, & + & igrdj_tmp + INTEGER :: numsstbias + INTEGER(KIND=NF90_INT) :: ifile_source + + INTEGER :: incfile + INTEGER :: jtype + INTEGER :: iret + INTEGER :: inumtype + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) 'obs_rea_sstbias : ' + IF(lwp)WRITE(numout,*) '----------------- ' + IF(lwp)WRITE(numout,*) 'Read SST bias ' + ! Open and read the files + z_sstbias(:,:,:)=0.0_wp + DO jtype = 1, knumtypes + + numsstbias=0 + IF(lwp)WRITE(numout,*) 'Opening ',cl_bias_files(jtype) + CALL iom_open( cl_bias_files(jtype), numsstbias, ldstop=.FALSE. ) + IF (numsstbias > 0) THEN + + !Read the bias type from the file + !No IOM get attribute command at time of writing, + !so have to use NETCDF + !routines directly - should be upgraded in the future + iret=NF90_OPEN(TRIM(cl_bias_files(jtype)), NF90_NOWRITE, incfile) + iret=NF90_GET_ATT( incfile, NF90_GLOBAL, "SST_source", & + ifile_source ) + ibiastypes(jtype) = ifile_source + iret=NF90_CLOSE(incfile) + + IF ( iret /= 0 ) CALL ctl_stop( & + 'obs_rea_sstbias : Cannot read bias type from file '// & + cl_bias_files(jtype) ) + ! Get the SST bias data + CALL iom_get( numsstbias, jpdom_global, 'tn', z_sstbias_2d(:,:), 1 ) + z_sstbias(:,:,jtype) = z_sstbias_2d(:,:) + ! Close the file + CALL iom_close(numsstbias) + ELSE + CALL ctl_stop('obs_read_sstbias: File '// & + TRIM( cl_bias_files(jtype) )//' Not found') + ENDIF + END DO + + ! Interpolate the bias already on the model grid at the observation point + ALLOCATE( & + & igrdi(2,2,sstdata%nsurf), & + & igrdj(2,2,sstdata%nsurf), & + & zglam(2,2,sstdata%nsurf), & + & zgphi(2,2,sstdata%nsurf), & + & zmask(2,2,sstdata%nsurf) ) + + DO jobs = 1, sstdata%nsurf + igrdi(1,1,jobs) = sstdata%mi(jobs)-1 + igrdj(1,1,jobs) = sstdata%mj(jobs)-1 + igrdi(1,2,jobs) = sstdata%mi(jobs)-1 + igrdj(1,2,jobs) = sstdata%mj(jobs) + igrdi(2,1,jobs) = sstdata%mi(jobs) + igrdj(2,1,jobs) = sstdata%mj(jobs)-1 + igrdi(2,2,jobs) = sstdata%mi(jobs) + igrdj(2,2,jobs) = sstdata%mj(jobs) + END DO + CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, & + & igrdi, igrdj, glamt, zglam ) + CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, & + & igrdi, igrdj, gphit, zgphi ) + CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, & + & igrdi, igrdj, tmask(:,:,1), zmask ) + DO jtype = 1, knumtypes + + !Find the number observations of type and allocate tempory arrays + inumtype = COUNT( sstdata%ntyp(:) == ibiastypes(jtype) ) + ALLOCATE( & + & igrdi_tmp(2,2,inumtype), & + & igrdj_tmp(2,2,inumtype), & + & zglam_tmp(2,2,inumtype), & + & zgphi_tmp(2,2,inumtype), & + & zmask_tmp(2,2,inumtype), & + & zbias( 2,2,inumtype ) ) + jt=1 + DO jobs = 1, sstdata%nsurf + IF ( sstdata%ntyp(jobs) == ibiastypes(jtype) ) THEN + igrdi_tmp(:,:,jt) = igrdi(:,:,jobs) + igrdj_tmp(:,:,jt) = igrdj(:,:,jobs) + zglam_tmp(:,:,jt) = zglam(:,:,jobs) + zgphi_tmp(:,:,jt) = zgphi(:,:,jobs) + zmask_tmp(:,:,jt) = zmask(:,:,jobs) + jt = jt +1 + ENDIF + END DO + + CALL obs_int_comm_2d( 2, 2, inumtype, jpi, jpj, & + & igrdi_tmp(:,:,:), igrdj_tmp(:,:,:), & + & z_sstbias(:,:,jtype), zbias(:,:,:) ) + jt=1 + DO jobs = 1, sstdata%nsurf + IF ( sstdata%ntyp(jobs) == ibiastypes(jtype) ) THEN + zlam = sstdata%rlam(jobs) + zphi = sstdata%rphi(jobs) + iico = sstdata%mi(jobs) + ijco = sstdata%mj(jobs) + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam_tmp(:,:,jt), & + & zgphi_tmp(:,:,jt), & + & zmask_tmp(:,:,jt), zweig, zobsmask ) + CALL obs_int_h2d( 1, 1, zweig, zbias(:,:,jt), zext ) + ! adjust sst with bias field + sstdata%robs(jobs,1) = sstdata%robs(jobs,1) - zext(1) + jt=jt+1 + ENDIF + END DO + + !Deallocate arrays + DEALLOCATE( & + & igrdi_tmp, & + & igrdj_tmp, & + & zglam_tmp, & + & zgphi_tmp, & + & zmask_tmp, & + & zbias ) + END DO + DEALLOCATE( & + & igrdi, & + & igrdj, & + & zglam, & + & zgphi, & + & zmask ) + + IF(lwp) THEN + WRITE(numout,*) " " + WRITE(numout,*) "SST bias correction applied successfully" + WRITE(numout,*) "Obs types: ",ibiastypes(:), & + " Have all been bias corrected\n" + ENDIF + END SUBROUTINE obs_app_sstbias + +END MODULE obs_sstbias diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_surf_def.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_surf_def.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e9b22978b2904fb057cf53bc43d5e3174f9a269a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_surf_def.f90 @@ -0,0 +1,542 @@ + + + + + + + + + + + + + +MODULE obs_surf_def + !!===================================================================== + !! *** MODULE obs_surf_def *** + !! Observation diagnostics: Storage handling for surface observation + !! arrays and additional flags etc. + !! This module only defines the data type and + !! operations on the data type. There is no + !! actual data in the module. + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_surf : F90 type containing the surface information + !! obs_surf_alloc : Allocates surface data arrays + !! obs_surf_dealloc : Deallocates surface data arrays + !! obs_surf_compress : Extract sub-information from a obs_surf type + !! to a new obs_surf type + !! obs_surf_decompress : Reinsert sub-information from a obs_surf type + !! into the original obs_surf type + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE obs_mpp, ONLY : & ! MPP tools + obs_mpp_sum_integer + + IMPLICIT NONE + + !! * Routine/type accessibility + PRIVATE + + PUBLIC & + & obs_surf, & + & obs_surf_alloc, & + & obs_surf_dealloc, & + & obs_surf_compress, & + & obs_surf_decompress + + !! * Type definition for surface observation type + + TYPE obs_surf + + ! Bookkeeping + + INTEGER :: nsurf !: Local number of surface data within window + INTEGER :: nsurfmpp !: Global number of surface data within window + INTEGER :: nvar !: Number of variables at observation points + INTEGER :: nextra !: Number of extra fields at observation points + INTEGER :: nstp !: Number of time steps + INTEGER :: npi !: Number of 3D grid points + INTEGER :: npj + INTEGER :: nsurfup !: Observation counter used in obs_oper + INTEGER :: nrec !: Number of surface observation records in window + + ! Arrays with size equal to the number of surface observations + + INTEGER, POINTER, DIMENSION(:) :: & + & mi, & !: i-th grid coord. for interpolating to surface observation + & mj, & !: j-th grid coord. for interpolating to surface observation + & mt, & !: time record number for gridded data + & nsidx,& !: Surface observation number + & nsfil,& !: Surface observation number in file + & nyea, & !: Year of surface observation + & nmon, & !: Month of surface observation + & nday, & !: Day of surface observation + & nhou, & !: Hour of surface observation + & nmin, & !: Minute of surface observation + & mstp, & !: Time step nearest to surface observation + & nqc, & !: Surface observation qc flag + & ntyp !: Type of surface observation product + + CHARACTER(len=8), POINTER, DIMENSION(:) :: & + & cvars !: Variable names + + CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & + & cwmo !: WMO indentifier + + REAL(KIND=wp), POINTER, DIMENSION(:) :: & + & rlam, & !: Longitude coordinate of surface observation + & rphi !: Latitude coordinate of surface observation + + REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & + & robs, & !: Surface observation + & rmod !: Model counterpart of the surface observation vector + + REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & + & rext !: Extra fields interpolated to observation points + + REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & + & vdmean !: Time averaged of model field + + ! Arrays with size equal to the number of time steps in the window + + INTEGER, POINTER, DIMENSION(:) :: & + & nsstp, & !: Local number of surface observations per time step + & nsstpmpp !: Global number of surface observations per time step + + ! Arrays with size equal to the number of observation records in the window + INTEGER, POINTER, DIMENSION(:) :: & + & mrecstp ! Time step of the records + + ! Arrays used to store source indices when + ! compressing obs_surf derived types + + ! Array with size nsurf + + INTEGER, POINTER, DIMENSION(:) :: & + & nsind !: Source indices of surface data in compressed data + + ! Is this a gridded product? + + LOGICAL :: lgrid + + END TYPE obs_surf + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_surf_def.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_surf_alloc( surf, ksurf, kvar, kextra, kstp, kpi, kpj ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_surf_alloc *** + !! + !! ** Purpose : - Allocate data for surface data arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-03 (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: surf ! Surface data to be allocated + INTEGER, INTENT(IN) :: ksurf ! Number of surface observations + INTEGER, INTENT(IN) :: kvar ! Number of surface variables + INTEGER, INTENT(IN) :: kextra ! Number of extra fields at observation points + INTEGER, INTENT(IN) :: kstp ! Number of time steps + INTEGER, INTENT(IN) :: kpi ! Number of 3D grid points + INTEGER, INTENT(IN) :: kpj + + !!* Local variables + INTEGER :: ji + INTEGER :: jvar + + ! Set bookkeeping variables + + surf%nsurf = ksurf + surf%nsurfmpp = 0 + surf%nextra = kextra + surf%nvar = kvar + surf%nstp = kstp + surf%npi = kpi + surf%npj = kpj + + ! Allocate arrays of size number of variables + + ALLOCATE( & + & surf%cvars(kvar) & + & ) + + DO jvar = 1, kvar + surf%cvars(jvar) = "NotSet" + END DO + + ! Allocate arrays of number of surface data size + + ALLOCATE( & + & surf%mi(ksurf), & + & surf%mj(ksurf), & + & surf%mt(ksurf), & + & surf%nsidx(ksurf), & + & surf%nsfil(ksurf), & + & surf%nyea(ksurf), & + & surf%nmon(ksurf), & + & surf%nday(ksurf), & + & surf%nhou(ksurf), & + & surf%nmin(ksurf), & + & surf%mstp(ksurf), & + & surf%nqc(ksurf), & + & surf%ntyp(ksurf), & + & surf%cwmo(ksurf), & + & surf%rlam(ksurf), & + & surf%rphi(ksurf), & + & surf%nsind(ksurf) & + & ) + + surf%mt(:) = -1 + + + ! Allocate arrays of number of surface data size * number of variables + + ALLOCATE( & + & surf%robs(ksurf,kvar), & + & surf%rmod(ksurf,kvar) & + & ) + + ! Allocate arrays of number of extra fields at observation points + + ALLOCATE( & + & surf%rext(ksurf,kextra) & + & ) + + surf%rext(:,:) = 0.0_wp + + ! Allocate arrays of number of time step size + + ALLOCATE( & + & surf%nsstp(kstp), & + & surf%nsstpmpp(kstp) & + & ) + + ! Allocate arrays of size number of grid points + + ALLOCATE( & + & surf%vdmean(kpi,kpj) & + & ) + + ! Set defaults for compression indices + + DO ji = 1, ksurf + surf%nsind(ji) = ji + END DO + + ! Set defaults for number of observations per time step + + surf%nsstp(:) = 0 + surf%nsstpmpp(:) = 0 + + ! Set the observation counter used in obs_oper + + surf%nsurfup = 0 + + ! Not gridded by default + + surf%lgrid = .FALSE. + + END SUBROUTINE obs_surf_alloc + + SUBROUTINE obs_surf_dealloc( surf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_surf_dealloc *** + !! + !! ** Purpose : - Deallocate data for surface data arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-03 (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: & + & surf ! Surface data to be allocated + + !!* Local variables + + ! Deallocate arrays of number of surface data size + + DEALLOCATE( & + & surf%mi, & + & surf%mj, & + & surf%mt, & + & surf%nsidx, & + & surf%nsfil, & + & surf%nyea, & + & surf%nmon, & + & surf%nday, & + & surf%nhou, & + & surf%nmin, & + & surf%mstp, & + & surf%nqc, & + & surf%ntyp, & + & surf%cwmo, & + & surf%rlam, & + & surf%rphi, & + & surf%nsind & + & ) + + ! Allocate arrays of number of surface data size * number of variables + + DEALLOCATE( & + & surf%robs, & + & surf%rmod & + & ) + + ! Deallocate arrays of number of extra fields at observation points + + DEALLOCATE( & + & surf%rext & + & ) + + ! Deallocate arrays of size number of grid points size times + ! number of variables + + DEALLOCATE( & + & surf%vdmean & + & ) + + ! Deallocate arrays of number of time step size + + DEALLOCATE( & + & surf%nsstp, & + & surf%nsstpmpp & + & ) + + ! Dellocate arrays of size number of variables + + DEALLOCATE( & + & surf%cvars & + & ) + + END SUBROUTINE obs_surf_dealloc + + SUBROUTINE obs_surf_compress( surf, newsurf, lallocate, kumout, lvalid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_surf_compress *** + !! + !! ** Purpose : - Extract sub-information from a obs_surf type + !! into a new obs_surf type + !! + !! ** Method : - The data is copied from surf to new surf. + !! In the case of lvalid being present only the + !! selected data will be copied. + !! If lallocate is true the data in the newsurf is + !! allocated either with the same number of elements + !! as surf or with only the subset of elements defined + !! by the optional selection. + !! + !! History : + !! ! 07-03 (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_surf), INTENT(IN) :: surf ! Original surface data + TYPE(obs_surf), INTENT(INOUT) :: newsurf ! New surface data with a subset of the original data + LOGICAL, INTENT(IN) :: lallocate ! Allocate newsurf data + INTEGER,INTENT(IN) :: kumout ! Fortran unit for messages + LOGICAL, OPTIONAL, INTENT(in), DIMENSION(:) :: & + & lvalid ! Valid of surface observations + + !!* Local variables + INTEGER :: insurf + INTEGER :: ji + INTEGER :: jk + LOGICAL, DIMENSION(:), ALLOCATABLE :: llvalid + + ! Count how many elements there should be in the new data structure + + IF ( PRESENT(lvalid) ) THEN + insurf = 0 + DO ji = 1, surf%nsurf + IF ( lvalid(ji) ) THEN + insurf = insurf + 1 + ENDIF + END DO + ELSE + insurf = surf%nsurf + ENDIF + + ! Optionally allocate data in the new data structure + + IF ( lallocate ) THEN + CALL obs_surf_alloc( newsurf, insurf, surf%nvar, & + & surf%nextra, surf%nstp, surf%npi, surf%npj ) + ENDIF + + ! Allocate temporary valid array to unify the code for both cases + + ALLOCATE( llvalid(surf%nsurf) ) + IF ( PRESENT(lvalid) ) THEN + llvalid(:) = lvalid(:) + ELSE + llvalid(:) = .TRUE. + ENDIF + + ! Setup bookkeeping variables + + insurf = 0 + + ! Loop over source surface data + + DO ji = 1, surf%nsurf + + IF ( llvalid(ji) ) THEN + + ! Copy the header information + + insurf = insurf + 1 + + newsurf%mi(insurf) = surf%mi(ji) + newsurf%mj(insurf) = surf%mj(ji) + newsurf%mt(insurf) = surf%mt(ji) + newsurf%nsidx(insurf) = surf%nsidx(ji) + newsurf%nsfil(insurf) = surf%nsfil(ji) + newsurf%nyea(insurf) = surf%nyea(ji) + newsurf%nmon(insurf) = surf%nmon(ji) + newsurf%nday(insurf) = surf%nday(ji) + newsurf%nhou(insurf) = surf%nhou(ji) + newsurf%nmin(insurf) = surf%nmin(ji) + newsurf%mstp(insurf) = surf%mstp(ji) + newsurf%nqc(insurf) = surf%nqc(ji) + newsurf%ntyp(insurf) = surf%ntyp(ji) + newsurf%cwmo(insurf) = surf%cwmo(ji) + newsurf%rlam(insurf) = surf%rlam(ji) + newsurf%rphi(insurf) = surf%rphi(ji) + + DO jk = 1, surf%nvar + + newsurf%robs(insurf,jk) = surf%robs(ji,jk) + newsurf%rmod(insurf,jk) = surf%rmod(ji,jk) + + END DO + + DO jk = 1, surf%nextra + + newsurf%rext(insurf,jk) = surf%rext(ji,jk) + + END DO + + ! nsind is the index of the original surface data + + newsurf%nsind(insurf) = ji + + ENDIF + + END DO + + ! Update MPP counters + + newsurf%nsurf = insurf + CALL obs_mpp_sum_integer ( newsurf%nsurf, newsurf%nsurfmpp ) + + ! Set book keeping variables which do not depend on number of obs. + + newsurf%nstp = surf%nstp + newsurf%cvars(:) = surf%cvars(:) + + ! Set gridded stuff + + newsurf%mt(insurf) = surf%mt(ji) + + ! Deallocate temporary data + + DEALLOCATE( llvalid ) + + END SUBROUTINE obs_surf_compress + + SUBROUTINE obs_surf_decompress( surf, oldsurf, ldeallocate, kumout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_surf_decompress *** + !! + !! ** Purpose : - Copy back information to original surface data type + !! + !! ** Method : - Reinsert updated information from a previous + !! copied/compressed surface data type into the original + !! surface data and optionally deallocate the surface + !! data input + !! + !! History : + !! ! 07-03 (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_surf),INTENT(INOUT) :: surf ! Updated surface data + TYPE(obs_surf),INTENT(INOUT) :: oldsurf ! Original surface data + LOGICAL, INTENT(IN) :: ldeallocate ! Deallocate the updated data of insertion + INTEGER,INTENT(in) :: kumout ! Output unit + + !!* Local variables + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + + ! Copy data from surf to old surf + + DO ji = 1, surf%nsurf + + jj=surf%nsind(ji) + + oldsurf%mi(jj) = surf%mi(ji) + oldsurf%mj(jj) = surf%mj(ji) + oldsurf%mt(jj) = surf%mt(ji) + oldsurf%nsidx(jj) = surf%nsidx(ji) + oldsurf%nsfil(jj) = surf%nsfil(ji) + oldsurf%nyea(jj) = surf%nyea(ji) + oldsurf%nmon(jj) = surf%nmon(ji) + oldsurf%nday(jj) = surf%nday(ji) + oldsurf%nhou(jj) = surf%nhou(ji) + oldsurf%nmin(jj) = surf%nmin(ji) + oldsurf%mstp(jj) = surf%mstp(ji) + oldsurf%nqc(jj) = surf%nqc(ji) + oldsurf%ntyp(jj) = surf%ntyp(ji) + oldsurf%cwmo(jj) = surf%cwmo(ji) + oldsurf%rlam(jj) = surf%rlam(ji) + oldsurf%rphi(jj) = surf%rphi(ji) + + END DO + + DO jk = 1, surf%nvar + + DO ji = 1, surf%nsurf + + jj=surf%nsind(ji) + + oldsurf%robs(jj,jk) = surf%robs(ji,jk) + oldsurf%rmod(jj,jk) = surf%rmod(ji,jk) + + END DO + + END DO + + DO jk = 1, surf%nextra + + DO ji = 1, surf%nsurf + + jj=surf%nsind(ji) + + oldsurf%rext(jj,jk) = surf%rext(ji,jk) + + END DO + + END DO + + ! Optionally deallocate the updated surface data + + IF ( ldeallocate ) CALL obs_surf_dealloc( surf ) + + END SUBROUTINE obs_surf_decompress + +END MODULE obs_surf_def diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_types.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_types.f90 new file mode 100644 index 0000000000000000000000000000000000000000..452726640fb50c68bfaa6c8be10c85bab2739622 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_types.f90 @@ -0,0 +1,280 @@ + + + + + + + + + + + + + +MODULE obs_types + !!===================================================================== + !! *** MODULE obs_types *** + !! Observation diagnostics: Observation type integer to character + !! translation + !!===================================================================== + + !!--------------------------------------------------------------------- + !! + !! The NetCDF variable CWMO_INST_TYP_COR is used to identify the + !! different instrument types for coriolis data. + !! + !! WMO NEMOVAR TYPE DESCRIPTION + !! --- ------- ---- -------------------------------------------- + !! 800 0 MBT (1941-) mechanical bathythermograph data + !! 401 1 XBT (1967-) expendable bathythermograph data + !! 830 2 CTD (1967-) high resolution CTD data + !! 820 3 MRB (1990-) moored buoy data + !! 831 4 PFL (1994-) profiling float data + !! 995 5 DRB (1998-) drifting buoy data + !! 997 6 APB (1997-) autonomous pinniped bathythermograph + !! 996 7 UOR (1992-) undulating oceanographic recorder + !! 741 8 OSD (1800-) low resolution (bottle) CTD data + !! + !! History : + !! ! 06-03 (K. Mogensen) Original code + !! ! 06-10 (A. Weaver) Cleanup + !!--------------------------------------------------------------------- + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + !! * Shared Module variables + + INTEGER, PUBLIC, PARAMETER :: ntyp1770 = 1023 +!RBbug useless ? CHARACTER(LEN=4), PUBLIC, DIMENSION(0:ntyp1770) :: cwmotyp1770 + CHARACTER(LEN=80), PUBLIC, DIMENSION(0:ntyp1770) :: cwmonam1770 + CHARACTER(LEN=3), PUBLIC, DIMENSION(0:ntyp1770) :: ctypshort + + INTEGER, PUBLIC, PARAMETER :: ntypalt = 8 + CHARACTER(LEN=40), PUBLIC, DIMENSION(0:ntypalt) :: calttyp + + PUBLIC obs_typ_init + PUBLIC obs_wmo_init + PUBLIC obs_alt_typ_init + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_types.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_typ_init + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wmo_init *** + !! + !! ** Purpose : Initialize code tables + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! : 2007-06 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + + !! * Local declarations + + CALL obs_wmo_init + + CALL obs_alt_typ_init + + END SUBROUTINE obs_typ_init + + SUBROUTINE obs_wmo_init + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wmo_init *** + !! + !! ** Purpose : Initialize WMO code 1770 code tables + !! + !! ** Method : Direct initialisation of variables + !! + !! ** Action : + !! + !! References : WORLD METEOROLOGICAL ORGANIZATION + !! Manual on Codes + !! International Codes + !! VOLUME I.1 (Annex II to WMO Technical Regulations) + !! Part A -- Alphanumeric Codes + !! 1995 edition + !! WMO-No. 306 + !! Secretariat of the World Meteorological Organization + !! Geneva, Switzerland + !! + !! History : + !! ! : 2007-04 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + + !! * Local declarations + INTEGER :: ji + + DO ji = 0, ntyp1770 + + cwmonam1770(ji) = 'Not defined' + ctypshort(ji) = '---' + +! IF ( ji < 1000 ) THEN +! WRITE(cwmotyp1770(ji),'(1X,I3.3)') ji +! ELSE +! WRITE(cwmotyp1770(ji),'(I4.4)') ji +! ENDIF + + END DO + + cwmonam1770( 1) = 'Sippican T-4' + cwmonam1770( 2) = 'Sippican T-4' + cwmonam1770( 11) = 'Sippican T-5' + cwmonam1770( 21) = 'Sippican Fast Deep' + cwmonam1770( 31) = 'Sippican T-6' + cwmonam1770( 32) = 'Sippican T-6' + cwmonam1770( 41) = 'Sippican T-7' + cwmonam1770( 42) = 'Sippican T-7' + cwmonam1770( 51) = 'Sippican Deep Blue' + cwmonam1770( 52) = 'Sippican Deep Blue' + cwmonam1770( 61) = 'Sippican T-10' + cwmonam1770( 71) = 'Sippican T-11' + cwmonam1770( 201) = 'TSK T-4' + cwmonam1770( 202) = 'TSK T-4' + cwmonam1770( 211) = 'TSK T-6' + cwmonam1770( 212) = 'TSK T-6' + cwmonam1770( 221) = 'TSK T-7' + cwmonam1770( 222) = 'TSK T-7' + cwmonam1770( 231) = 'TSK T-5' + cwmonam1770( 241) = 'TSK T-10' + cwmonam1770( 251) = 'TSK Deep Blue' + cwmonam1770( 252) = 'TSK Deep Blue' + cwmonam1770( 261) = 'TSK AXBT ' + cwmonam1770( 401) = 'Sparton XBT-1' + cwmonam1770( 411) = 'Sparton XBT-3' + cwmonam1770( 421) = 'Sparton XBT-4' + cwmonam1770( 431) = 'Sparton XBT-5' + cwmonam1770( 441) = 'Sparton XBT-5DB' + cwmonam1770( 451) = 'Sparton XBT-6' + cwmonam1770( 461) = 'Sparton XBT-7' + cwmonam1770( 462) = 'Sparton XBT-7' + cwmonam1770( 471) = 'Sparton XBT-7DB' + cwmonam1770( 481) = 'Sparton XBT-10' + cwmonam1770( 491) = 'Sparton XBT-20' + cwmonam1770( 501) = 'Sparton XBT-20DB' + cwmonam1770( 510) = 'Sparton 536 AXBT' + cwmonam1770( 700) = 'Sippican XCTD standard' + cwmonam1770( 710) = 'Sippican XCTD deep' + cwmonam1770( 720) = 'Sippican AXCTD' + cwmonam1770( 730) = 'Sippican SXCTD' + cwmonam1770( 741) = 'TSK XCTD' + cwmonam1770( 742) = 'TSK XCTD-2 ' + cwmonam1770( 743) = 'TSK XCTD-2F ' + cwmonam1770( 751) = 'TSK AXCTD ' + cwmonam1770( 800) = 'Mechanical BT' + cwmonam1770( 810) = 'Hydrocast' + cwmonam1770( 820) = 'Thermistor Chain' + cwmonam1770( 825) = 'Temperature (sonic) and pressure probes' + cwmonam1770( 830) = 'CTD' + cwmonam1770( 831) = 'CTD-P-ALACE float' + cwmonam1770( 840) = 'PROVOR, No conductivity sensor ' + cwmonam1770( 841) = 'PROVOR, Seabird conductivity sensor ' + cwmonam1770( 842) = 'PROVOR, FSI conductivity sensor ' + cwmonam1770( 845) = 'Web Research, No conductivity sensor ' + cwmonam1770( 846) = 'Web Research, Seabird conductivity sensor ' + cwmonam1770( 847) = 'Web Research. FSI conductivity sensor' + cwmonam1770( 850) = 'SOLO, No conductivity sensor ' + cwmonam1770( 851) = 'SOLO, Seabird conductivity sensor ' + cwmonam1770( 852) = 'SOLO, FSI conductivity sensor' + cwmonam1770( 855) = 'Profiling float, NINJA, no conductivity sensor' + cwmonam1770( 856) = 'Profiling float, NINJA, SBE conductivity sensor' + cwmonam1770( 857) = 'Profiling float, NINJA, FSI conductivity sensor' + cwmonam1770( 858) = 'Profiling float, NINJA, TSK conductivity sensor' + cwmonam1770( 900) = 'Sippican T-12 XBT' + cwmonam1770(1023) = 'Missing value' + + DO ji = 853, 854 + cwmonam1770(ji) = 'Reserved' + END DO + + DO ji = 859, 899 + cwmonam1770(ji) = 'Reserved' + END DO + + DO ji = 901, 999 + cwmonam1770(ji) = 'Reserved' + END DO + + DO ji = 1000, 1022 + cwmonam1770(ji) = 'Reserved' + END DO + + ctypshort(800) = 'MBT' + ctypshort(401) = 'XBT' + ctypshort(830) = 'CTD' + ctypshort(820) = 'MRB' + ctypshort(831) = 'PFL' + ctypshort(995) = 'DRB' + ctypshort(997) = 'APB' + ctypshort(996) = 'UOR' + ctypshort(700:799) = 'OSD' + + END SUBROUTINE obs_wmo_init + + SUBROUTINE obs_alt_typ_init + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_alt_typ_init *** + !! + !! ** Purpose : Initialize CLS altimeter code tables + !! + !! ** Method : Direct initialisation of variables + !! + !! ** Action : + !! + !! References : CLS + !1 SSALTO/DUACS User Handbook + !! (M)SLA and (M)ADT Near-Real Time and + !! Delayed time products + !! CLS-DOS-NT-06-034 + !! 2006 + !! CLS + !! 8-10 Rue Hermes + !! Parc Technologique du Canal + !! 31526 Ramonville St-Agne + !! France + !! + !! History : + !! ! : 2007-06 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + + !! * Local declarations + + calttyp(0) = 'Unknown' + calttyp(1) = 'ERS-1' + calttyp(2) = 'ERS-2' + calttyp(3) = 'Topex/Poseidon' + calttyp(4) = 'Topex/Poseidon on its new orbit' + calttyp(5) = 'GFO' + calttyp(6) = 'Jason-1' + calttyp(7) = 'Envisat' + calttyp(8) = 'Jason-2' + + END SUBROUTINE obs_alt_typ_init + +END MODULE obs_types diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_utils.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_utils.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6f3452f95d3372becb52923b8d0a2681f5b65301 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_utils.f90 @@ -0,0 +1,370 @@ + + + + + + + + + + + + + +MODULE obs_utils + !!====================================================================== + !! *** MODULE obs_utils *** + !! Observation diagnostics: Utility functions + !!===================================================================== + + !!---------------------------------------------------------------------- + !! grt_cir_dis : Great circle distance + !! grt_cir_dis_saa : Great circle distance (small angle) + !! chkerr : Error-message managment for NetCDF files + !! chkdim : Error-message managment for NetCDF files + !! fatal_error : Fatal error handling + !! ddatetoymdhms : Convert YYYYMMDD.hhmmss to components + !!---------------------------------------------------------------------- + !! * Modules used + USE par_oce, ONLY : & ! Precision variables + & wp, & + & dp, & + & i8 + USE in_out_manager ! I/O manager + USE lib_mpp ! For ctl_warn/stop + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + PUBLIC grt_cir_dis, & ! Great circle distance + & grt_cir_dis_saa, & ! Great circle distance (small angle) + & str_c_to_for, & ! Remove non-printable chars from string + & chkerr, & ! Error-message managment for NetCDF files + & chkdim, & ! Check if dimensions are correct for a variable + & fatal_error, & ! Fatal error handling + & warning, & ! Warning handling + & ddatetoymdhms ! Convert YYYYMMDD.hhmmss to components + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_utils.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: grt_cir_dis.h90 13226 2020-07-02 14:24:31Z orioltp $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION grt_cir_dis( pa1, pa2, pb1, pb2, pc1, pc2 ) + !!---------------------------------------------------------------------- + !! *** FUNCTION grt_cir_dis *** + !! + !! ** Purpose : Great circle distance between pts (lat1,lon1) + !! & (lat2,lon2) + !! + !! ** Method : Geometry. + !! + !! History : + !! ! 1995-12 (G. Madec, E. Durand, A. Weaver, N. Daget) Original + !! ! 2006-03 (A. Vidard) Migration to NEMOVAR + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pa1 ! sin(lat1) + REAL(KIND=wp) :: pa2 ! sin(lat2) + REAL(KIND=wp) :: pb1 ! cos(lat1) * cos(lon1) + REAL(KIND=wp) :: pb2 ! cos(lat2) * cos(lon2) + REAL(KIND=wp) :: pc1 ! cos(lat1) * sin(lon1) + REAL(KIND=wp) :: pc2 ! cos(lat2) * sin(lon2) + + REAL(KIND=wp) :: cosdist ! cosine of great circle distance + + ! Compute cosine of great circle distance, constraining it to be between + ! -1 and 1 (rounding errors can take it slightly outside this range + cosdist = MAX( MIN( pa1 * pa2 + pb1 * pb2 + pc1 * pc2, 1.0_wp), -1.0_wp ) + + grt_cir_dis = & + & ASIN( SQRT( 1.0_wp - cosdist**2.0_wp ) ) + + END FUNCTION grt_cir_dis + +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: grt_cir_dis_saa.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION grt_cir_dis_saa( pa, pb, pc ) + !!---------------------------------------------------------------------- + !! *** FUNCTION grt_cir_dis_saa *** + !! + !! ** Purpose : Great circle distance between pts (lat1,lon1) + !! & (lat2,lon2) with a small-angle approximation + !! + !! ** Method : Geometry + !! + !! ** Action : + !! + !! History + !! ! 95-12 (G. Madec, E. Durand, A. Weaver, N. Daget) Original + !! ! 06-03 (A. Vidard) Migration to NEMOVAR + !! ! 06-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pa ! lon1 - lon2 + REAL(KIND=wp) :: pb ! lat1 - lat2 + REAL(KIND=wp) :: pc ! cos(lat2) + + grt_cir_dis_saa = SQRT( pa * pa + ( pb * pc )**2 ) + + END FUNCTION grt_cir_dis_saa + +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: str_c_to_for.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE str_c_to_for( cd_str ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE str_c_to_for *** + !! + !! ** Purpose : Loop over a string and replace all non-printable + !! ASCII characters with spaces assuming English + !! characters only + !! + !! ** Method : Loop over a string and replace all non-printable + !! ASCII characters with spaces assuming English + !! characters only + !! + !! ** Action : + !! + !! History : + !! ! : 06-05 (K. Mogensen) Original + !! ! : 06-05 (A. Vidard) Cleaning up + !! ! : 06-10 (A. Weaver) More cleaning + !!--------------------------------------------------------------------- + !! * Arguments + CHARACTER(LEN=*), INTENT(INOUT) :: cd_str + + !! * Local declarations + INTEGER :: & + & ji + + DO ji = 1, LEN( cd_str ) + IF ( ( IACHAR( cd_str(ji:ji) ) > 128 ) & + & .OR.( IACHAR( cd_str(ji:ji) ) < 32 ) ) cd_str(ji:ji) = ' ' + END DO + + END SUBROUTINE str_c_to_for + + SUBROUTINE chkerr( kstatus, cd_name, klineno ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE chkerr *** + !! + !! ** Purpose : Error-message managment for NetCDF files. + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !! ! 02-12 (N. Daget) hdlerr + !! ! 06-04 (A. Vidard) f90/nemovar migration, change name + !! ! 06-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + !! * Modules used + USE netcdf ! NetCDF library + + !! * Arguments + INTEGER, INTENT(IN) :: kstatus + INTEGER, INTENT(IN) :: klineno + CHARACTER(LEN=*), INTENT(IN) :: cd_name + + !! * Local declarations + CHARACTER(len=200) :: clineno + + ! Main computation + IF ( kstatus /= nf90_noerr ) THEN + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_stop( ' chkerr', ' Netcdf Error in ' // TRIM( cd_name ), & + & clineno, nf90_strerror( kstatus ) ) + ENDIF + + END SUBROUTINE chkerr + + SUBROUTINE chkdim( kfileid, kvarid, kndim, kdim, cd_name, klineno ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE chkerr *** + !! + !! ** Purpose : Error-message managment for NetCDF files. + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !! ! 07-03 (K. Mogenen + E. Remy) Initial version + !!---------------------------------------------------------------------- + !! * Modules used + USE netcdf ! NetCDF library + + !! * Arguments + INTEGER :: kfileid ! NetCDF file id + INTEGER :: kvarid ! NetCDF variable id + INTEGER :: kndim ! Expected number of dimensions + INTEGER, DIMENSION(kndim) :: kdim ! Expected dimensions + CHARACTER(LEN=*) :: cd_name ! Calling routine name + INTEGER :: klineno ! Calling line number + + !! * Local declarations + INTEGER :: indim + INTEGER, ALLOCATABLE, DIMENSION(:) :: & + & idim,ilendim + INTEGER :: ji + LOGICAL :: llerr + CHARACTER(len=200) :: clineno + + CALL chkerr( nf90_inquire_variable( kfileid, kvarid, ndims=indim ), & + & cd_name, klineno ) + + ALLOCATE(idim(indim),ilendim(indim)) + + CALL chkerr( nf90_inquire_variable( kfileid, kvarid, dimids=idim ), & + & cd_name, klineno ) + + DO ji = 1, indim + CALL chkerr( nf90_inquire_dimension( kfileid, idim(ji), & + & len=ilendim(ji) ), & + & cd_name, klineno ) + END DO + + IF ( indim /= kndim ) THEN + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_stop( ' chkdim', & + & ' Netcdf no dim error in ' // TRIM( cd_name ), & + & clineno ) + ENDIF + + DO ji = 1, indim + IF ( ilendim(ji) /= kdim(ji) ) THEN + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_stop( ' chkdim', & + & ' Netcdf dim len error in ' // TRIM( cd_name ), & + & clineno ) + ENDIF + END DO + + DEALLOCATE(idim,ilendim) + + END SUBROUTINE chkdim + + SUBROUTINE fatal_error( cd_name, klineno ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE fatal_error *** + !! + !! ** Purpose : Fatal error handling + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + INTEGER, INTENT(IN) :: klineno + CHARACTER(LEN=*) :: cd_name + !! * Local declarations + CHARACTER(len=200) :: clineno + + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_stop( ' fatal_error', ' Error in ' // TRIM( cd_name ), & + & clineno) + + END SUBROUTINE fatal_error + + SUBROUTINE warning( cd_name, klineno ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE warning *** + !! + !! ** Purpose : Warning handling + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + INTEGER, INTENT(IN) :: klineno + CHARACTER(LEN=*) :: cd_name + !! * Local declarations + CHARACTER(len=200) :: clineno + + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_warn( ' warning', ' Potential problem in ' // TRIM( cd_name ), & + & clineno) + + END SUBROUTINE warning + +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ddatetoymdhms.h90 13226 2020-07-02 14:24:31Z orioltp $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE ddatetoymdhms( ddate, kyea, kmon, kday, khou, kmin, ksec ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE ddatetoymdhms *** + !! + !! ** Purpose : Convert YYYYMMDD.hhmmss to components + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + real(wp), INTENT(IN) :: ddate + INTEGER, INTENT(OUT) :: kyea + INTEGER, INTENT(OUT) :: kmon + INTEGER, INTENT(OUT) :: kday + INTEGER, INTENT(OUT) :: khou + INTEGER, INTENT(OUT) :: kmin + INTEGER, INTENT(OUT) :: ksec + !! * Local declarations + INTEGER :: iyymmdd + INTEGER :: ihhmmss + + iyymmdd = INT( ddate ) + ihhmmss = INT( ( ddate - iyymmdd ) * 1000000 ) + kyea = iyymmdd/10000 + kmon = iyymmdd / 100 - 100 * kyea + kday = MOD( iyymmdd, 100 ) + khou = ihhmmss/10000 + kmin = ihhmmss / 100 - 100 * khou + ksec = MOD( ihhmmss, 100 ) + + END SUBROUTINE ddatetoymdhms + +END MODULE obs_utils diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_write.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_write.f90 new file mode 100644 index 0000000000000000000000000000000000000000..de58d684e2ed22032107be83843b8c6acf0a792b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/obs_write.f90 @@ -0,0 +1,648 @@ + + + + + + + + + + + + + +MODULE obs_write + !!====================================================================== + !! *** MODULE obs_write *** + !! Observation diagnosticss: Write observation related diagnostics + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_wri_prof : Write profile observations in feedback format + !! obs_wri_surf : Write surface observations in feedback format + !! obs_wri_stats : Print basic statistics on the data being written out + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE in_out_manager ! I/O manager + USE dom_oce ! Ocean space and time domain variables + USE obs_types ! Observation type integer to character translation + USE julian, ONLY : & ! Julian date routines + & greg2jul + USE obs_utils, ONLY : & ! Observation operator utility functions + & chkerr + USE obs_profiles_def ! Type definitions for profiles + USE obs_surf_def ! Type defintions for surface observations + USE obs_fbm ! Observation feedback I/O + USE obs_grid ! Grid tools + USE obs_conv ! Conversion between units + USE obs_const + USE obs_mpp ! MPP support routines for observation diagnostics + USE lib_mpp ! MPP routines + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + PUBLIC obs_wri_prof, & ! Write profile observation files + & obs_wri_surf, & ! Write surface observation files + & obswriinfo + + TYPE obswriinfo + INTEGER :: inum + INTEGER, POINTER, DIMENSION(:) :: ipoint + CHARACTER(len=ilenname), POINTER, DIMENSION(:) :: cdname + CHARACTER(len=ilenlong), POINTER, DIMENSION(:,:) :: cdlong + CHARACTER(len=ilenunit), POINTER, DIMENSION(:,:) :: cdunit + END TYPE obswriinfo + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_write.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_wri_prof( profdata, padd, pext ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wri_prof *** + !! + !! ** Purpose : Write profile feedback files + !! + !! ** Method : NetCDF + !! + !! ** Action : + !! + !! History : + !! ! 06-04 (A. Vidard) Original + !! ! 06-04 (A. Vidard) Reformatted + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-01 (K. Mogensen) Use profile data types + !! ! 07-03 (K. Mogensen) General handling of profiles + !! ! 09-01 (K. Mogensen) New feedback format + !! ! 15-02 (M. Martin) Combined routine for writing profiles + !!----------------------------------------------------------------------- + + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data + TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable + TYPE(obswriinfo), OPTIONAL :: pext ! Extra info + + !! * Local declarations + TYPE(obfbdata) :: fbdata + CHARACTER(LEN=40) :: clfname + CHARACTER(LEN=10) :: clfiletype + CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable + CHARACTER(LEN=ilenunit) :: clunits ! Units of variable + CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable + CHARACTER(LEN=12) :: clfmt ! writing format + INTEGER :: idg ! number of digits + INTEGER :: ilevel + INTEGER :: jvar + INTEGER :: jo + INTEGER :: jk + INTEGER :: ik + INTEGER :: ja + INTEGER :: je + INTEGER :: iadd + INTEGER :: iext + REAL(wp) :: zpres + + IF ( PRESENT( padd ) ) THEN + iadd = padd%inum + ELSE + iadd = 0 + ENDIF + + IF ( PRESENT( pext ) ) THEN + iext = pext%inum + ELSE + iext = 0 + ENDIF + + CALL init_obfbdata( fbdata ) + + ! Find maximum level + ilevel = 0 + DO jvar = 1, profdata%nvar + ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) + END DO + + SELECT CASE ( TRIM(profdata%cvars(1)) ) + CASE('POTM') + + clfiletype='profb' + CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & + & 1 + iadd, 1 + iext, .TRUE. ) + fbdata%cname(1) = profdata%cvars(1) + fbdata%cname(2) = profdata%cvars(2) + fbdata%coblong(1) = 'Potential temperature' + fbdata%coblong(2) = 'Practical salinity' + fbdata%cobunit(1) = 'Degrees centigrade' + fbdata%cobunit(2) = 'PSU' + fbdata%cextname(1) = 'TEMP' + fbdata%cextlong(1) = 'Insitu temperature' + fbdata%cextunit(1) = 'Degrees centigrade' + fbdata%caddlong(1,1) = 'Model interpolated potential temperature' + fbdata%caddlong(1,2) = 'Model interpolated practical salinity' + fbdata%caddunit(1,1) = 'Degrees centigrade' + fbdata%caddunit(1,2) = 'PSU' + fbdata%cgrid(:) = 'T' + DO je = 1, iext + fbdata%cextname(1+je) = pext%cdname(je) + fbdata%cextlong(1+je) = pext%cdlong(je,1) + fbdata%cextunit(1+je) = pext%cdunit(je,1) + END DO + DO ja = 1, iadd + fbdata%caddname(1+ja) = padd%cdname(ja) + DO jvar = 1, 2 + fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) + fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) + END DO + END DO + + CASE('UVEL') + + clfiletype='velfb' + CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 1, 0, .TRUE. ) + fbdata%cname(1) = profdata%cvars(1) + fbdata%cname(2) = profdata%cvars(2) + fbdata%coblong(1) = 'Zonal velocity' + fbdata%coblong(2) = 'Meridional velocity' + fbdata%cobunit(1) = 'm/s' + fbdata%cobunit(2) = 'm/s' + DO je = 1, iext + fbdata%cextname(je) = pext%cdname(je) + fbdata%cextlong(je) = pext%cdlong(je,1) + fbdata%cextunit(je) = pext%cdunit(je,1) + END DO + fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' + fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' + fbdata%caddunit(1,1) = 'm/s' + fbdata%caddunit(1,2) = 'm/s' + fbdata%cgrid(1) = 'U' + fbdata%cgrid(2) = 'V' + DO ja = 1, iadd + fbdata%caddname(1+ja) = padd%cdname(ja) + fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) + fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) + END DO + + END SELECT + + IF ( ( TRIM(profdata%cvars(1)) /= 'POTM' ) .AND. & + & ( TRIM(profdata%cvars(1)) /= 'UVEL' ) ) THEN + CALL alloc_obfbdata( fbdata, 1, profdata%nprof, ilevel, & + & 1 + iadd, iext, .TRUE. ) + fbdata%cname(1) = profdata%cvars(1) + fbdata%coblong(1) = cllongname + fbdata%cobunit(1) = clunits + fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(cllongname) + fbdata%caddunit(1,1) = clunits + fbdata%cgrid(:) = clgrid + DO je = 1, iext + fbdata%cextname(je) = pext%cdname(je) + fbdata%cextlong(je) = pext%cdlong(je,1) + fbdata%cextunit(je) = pext%cdunit(je,1) + END DO + DO ja = 1, iadd + fbdata%caddname(1+ja) = padd%cdname(ja) + fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) + fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) + END DO + ENDIF + + fbdata%caddname(1) = 'Hx' + + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' + WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', narea-1, '.nc' + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*)'obs_wri_prof :' + WRITE(numout,*)'~~~~~~~~~~~~~' + WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname) + ENDIF + + ! Transform obs_prof data structure into obfb data structure + fbdata%cdjuldref = '19500101000000' + DO jo = 1, profdata%nprof + fbdata%plam(jo) = profdata%rlam(jo) + fbdata%pphi(jo) = profdata%rphi(jo) + WRITE(fbdata%cdtyp(jo),'(I4)') profdata%ntyp(jo) + fbdata%ivqc(jo,:) = profdata%ivqc(jo,:) + fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) + IF ( profdata%nqc(jo) > 255 ) THEN + fbdata%ioqc(jo) = IBSET(profdata%nqc(jo),2) + fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) + fbdata%ioqcf(2,jo) = profdata%nqc(jo) + ELSE + fbdata%ioqc(jo) = profdata%nqc(jo) + fbdata%ioqcf(:,jo) = profdata%nqcf(:,jo) + ENDIF + fbdata%ipqc(jo) = profdata%ipqc(jo) + fbdata%ipqcf(:,jo) = profdata%ipqcf(:,jo) + fbdata%itqc(jo) = profdata%itqc(jo) + fbdata%itqcf(:,jo) = profdata%itqcf(:,jo) + fbdata%cdwmo(jo) = profdata%cwmo(jo) + fbdata%kindex(jo) = profdata%npfil(jo) + DO jvar = 1, profdata%nvar + IF (ln_grid_global) THEN + fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar) + fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar) + ELSE + fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar)) + fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar)) + ENDIF + END DO + CALL greg2jul( 0, & + & profdata%nmin(jo), & + & profdata%nhou(jo), & + & profdata%nday(jo), & + & profdata%nmon(jo), & + & profdata%nyea(jo), & + & fbdata%ptim(jo), & + & krefdate = 19500101 ) + ! Reform the profiles arrays for output + DO jvar = 1, profdata%nvar + DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) + ik = profdata%var(jvar)%nvlidx(jk) + fbdata%padd(ik,jo,1,jvar) = profdata%var(jvar)%vmod(jk) + fbdata%pob(ik,jo,jvar) = profdata%var(jvar)%vobs(jk) + fbdata%pdep(ik,jo) = profdata%var(jvar)%vdep(jk) + fbdata%idqc(ik,jo) = profdata%var(jvar)%idqc(jk) + fbdata%idqcf(:,ik,jo) = profdata%var(jvar)%idqcf(:,jk) + IF ( profdata%var(jvar)%nvqc(jk) > 255 ) THEN + fbdata%ivlqc(ik,jo,jvar) = IBSET(profdata%var(jvar)%nvqc(jk),2) + fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) +!$AGRIF_DO_NOT_TREAT + fbdata%ivlqcf(2,ik,jo,jvar) = IAND(profdata%var(jvar)%nvqc(jk),b'0000000011111111') +!$AGRIF_END_DO_NOT_TREAT + ELSE + fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) + fbdata%ivlqcf(:,ik,jo,jvar) = profdata%var(jvar)%nvqcf(:,jk) + ENDIF + fbdata%iobsk(ik,jo,jvar) = profdata%var(jvar)%mvk(jk) + DO ja = 1, iadd + fbdata%padd(ik,jo,1+ja,jvar) = & + & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) + END DO + DO je = 1, iext + fbdata%pext(ik,jo,1+je) = & + & profdata%var(jvar)%vext(jk,pext%ipoint(je)) + END DO + IF ( ( jvar == 1 ) .AND. & + & ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN + fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1) + ENDIF + END DO + END DO + END DO + + IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN + ! Convert insitu temperature to potential temperature using the model + ! salinity if no potential temperature + DO jo = 1, fbdata%nobs + IF ( fbdata%pphi(jo) < 9999.0 ) THEN + DO jk = 1, fbdata%nlev + IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & + & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & + & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & + & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN + zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & + & REAL(fbdata%pphi(jo),wp) ) + fbdata%pob(jk,jo,1) = potemp( & + & REAL(fbdata%padd(jk,jo,1,2), wp), & + & REAL(fbdata%pext(jk,jo,1), wp), & + & zpres, 0.0_wp ) + ENDIF + END DO + ENDIF + END DO + ENDIF + + ! Write the obfbdata structure + CALL write_obfbdata( clfname, fbdata ) + + ! Output some basic statistics + CALL obs_wri_stats( fbdata ) + + CALL dealloc_obfbdata( fbdata ) + + END SUBROUTINE obs_wri_prof + + SUBROUTINE obs_wri_surf( surfdata, padd, pext ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wri_surf *** + !! + !! ** Purpose : Write surface observation files + !! + !! ** Method : NetCDF + !! + !! ** Action : + !! + !! ! 07-03 (K. Mogensen) Original + !! ! 09-01 (K. Mogensen) New feedback format. + !! ! 15-02 (M. Martin) Combined surface writing routine. + !!----------------------------------------------------------------------- + + !! * Modules used + IMPLICIT NONE + + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data + TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable + TYPE(obswriinfo), OPTIONAL :: pext ! Extra info + + !! * Local declarations + TYPE(obfbdata) :: fbdata + CHARACTER(LEN=40) :: clfname ! netCDF filename + CHARACTER(LEN=10) :: clfiletype + CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable + CHARACTER(LEN=ilenunit) :: clunits ! Units of variable + CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable + CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' + CHARACTER(LEN=12) :: clfmt ! writing format + INTEGER :: idg ! number of digits + INTEGER :: jo + INTEGER :: ja + INTEGER :: je + INTEGER :: iadd + INTEGER :: iext + + IF ( PRESENT( padd ) ) THEN + iadd = padd%inum + ELSE + iadd = 0 + ENDIF + + IF ( PRESENT( pext ) ) THEN + iext = pext%inum + ELSE + iext = 0 + ENDIF + + CALL init_obfbdata( fbdata ) + + SELECT CASE ( TRIM(surfdata%cvars(1)) ) + CASE('SLA') + + ! SLA needs special treatment because of MDT, so is all done here + ! Other variables are done more generically + ! No climatology for SLA, MDT is our best estimate of that and is already output. + + CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & + & 2 + iadd, 1 + iext, .TRUE. ) + + clfiletype = 'slafb' + fbdata%cname(1) = surfdata%cvars(1) + fbdata%coblong(1) = 'Sea level anomaly' + fbdata%cobunit(1) = 'Metres' + fbdata%cextname(1) = 'MDT' + fbdata%cextlong(1) = 'Mean dynamic topography' + fbdata%cextunit(1) = 'Metres' + DO je = 1, iext + fbdata%cextname(je) = pext%cdname(je) + fbdata%cextlong(je) = pext%cdlong(je,1) + fbdata%cextunit(je) = pext%cdunit(je,1) + END DO + fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' + fbdata%caddunit(1,1) = 'Metres' + fbdata%caddname(2) = 'SSH' + fbdata%caddlong(2,1) = 'Model Sea surface height' + fbdata%caddunit(2,1) = 'Metres' + fbdata%cgrid(1) = 'T' + DO ja = 1, iadd + fbdata%caddname(2+ja) = padd%cdname(ja) + fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) + fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) + END DO + + CASE('SST') + + clfiletype = 'sstfb' + cllongname = 'Sea surface temperature' + clunits = 'Degree centigrade' + clgrid = 'T' + + CASE('ICECONC') + + clfiletype = 'sicfb' + cllongname = 'Sea ice concentration' + clunits = 'Fraction' + clgrid = 'T' + + CASE('SSS') + + clfiletype = 'sssfb' + cllongname = 'Sea surface salinity' + clunits = 'psu' + clgrid = 'T' + + CASE DEFAULT + + CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) + + END SELECT + + ! SLA needs special treatment because of MDT, so is done above + ! Remaining variables treated more generically + + IF ( TRIM(surfdata%cvars(1)) /= 'SLA' ) THEN + + CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & + & 1 + iadd, iext, .TRUE. ) + + fbdata%cname(1) = surfdata%cvars(1) + fbdata%coblong(1) = cllongname + fbdata%cobunit(1) = clunits + DO je = 1, iext + fbdata%cextname(je) = pext%cdname(je) + fbdata%cextlong(je) = pext%cdlong(je,1) + fbdata%cextunit(je) = pext%cdunit(je,1) + END DO + IF ( TRIM(surfdata%cvars(1)) == 'ICECONC' ) THEN + fbdata%caddlong(1,1) = 'Model interpolated ICE' + ELSE + fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(surfdata%cvars(1)) + ENDIF + fbdata%caddunit(1,1) = clunits + fbdata%cgrid(1) = clgrid + DO ja = 1, iadd + fbdata%caddname(1+ja) = padd%cdname(ja) + fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) + fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) + END DO + ENDIF + + fbdata%caddname(1) = 'Hx' + + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' + WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', narea-1, '.nc' + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*)'obs_wri_surf :' + WRITE(numout,*)'~~~~~~~~~~~~~' + WRITE(numout,*)'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname) + ENDIF + + ! Transform surf data structure into obfbdata structure + fbdata%cdjuldref = '19500101000000' + DO jo = 1, surfdata%nsurf + fbdata%plam(jo) = surfdata%rlam(jo) + fbdata%pphi(jo) = surfdata%rphi(jo) + WRITE(fbdata%cdtyp(jo),'(I4)') surfdata%ntyp(jo) + fbdata%ivqc(jo,:) = 0 + fbdata%ivqcf(:,jo,:) = 0 + IF ( surfdata%nqc(jo) > 255 ) THEN + fbdata%ioqc(jo) = 4 + fbdata%ioqcf(1,jo) = 0 +!$AGRIF_DO_NOT_TREAT + fbdata%ioqcf(2,jo) = IAND(surfdata%nqc(jo),b'0000000011111111') +!$AGRIF_END_DO_NOT_TREAT + ELSE + fbdata%ioqc(jo) = surfdata%nqc(jo) + fbdata%ioqcf(:,jo) = 0 + ENDIF + fbdata%ipqc(jo) = 0 + fbdata%ipqcf(:,jo) = 0 + fbdata%itqc(jo) = 0 + fbdata%itqcf(:,jo) = 0 + fbdata%cdwmo(jo) = surfdata%cwmo(jo) + fbdata%kindex(jo) = surfdata%nsfil(jo) + IF (ln_grid_global) THEN + fbdata%iobsi(jo,1) = surfdata%mi(jo) + fbdata%iobsj(jo,1) = surfdata%mj(jo) + ELSE + fbdata%iobsi(jo,1) = mig(surfdata%mi(jo)) + fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo)) + ENDIF + CALL greg2jul( 0, & + & surfdata%nmin(jo), & + & surfdata%nhou(jo), & + & surfdata%nday(jo), & + & surfdata%nmon(jo), & + & surfdata%nyea(jo), & + & fbdata%ptim(jo), & + & krefdate = 19500101 ) + fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1) + IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%padd(1,jo,2,1) = surfdata%rext(jo,1) + fbdata%pob(1,jo,1) = surfdata%robs(jo,1) + fbdata%pdep(1,jo) = 0.0 + fbdata%idqc(1,jo) = 0 + fbdata%idqcf(:,1,jo) = 0 + IF ( surfdata%nqc(jo) > 255 ) THEN + fbdata%ivqc(jo,1) = 4 + fbdata%ivlqc(1,jo,1) = 4 + fbdata%ivlqcf(1,1,jo,1) = 0 +!$AGRIF_DO_NOT_TREAT + fbdata%ivlqcf(2,1,jo,1) = IAND(surfdata%nqc(jo),b'0000000011111111') +!$AGRIF_END_DO_NOT_TREAT + ELSE + fbdata%ivqc(jo,1) = surfdata%nqc(jo) + fbdata%ivlqc(1,jo,1) = surfdata%nqc(jo) + fbdata%ivlqcf(:,1,jo,1) = 0 + ENDIF + fbdata%iobsk(1,jo,1) = 0 + IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2) + DO ja = 1, iadd + fbdata%padd(1,jo,2+ja,1) = & + & surfdata%rext(jo,padd%ipoint(ja)) + END DO + DO je = 1, iext + fbdata%pext(1,jo,1+je) = & + & surfdata%rext(jo,pext%ipoint(je)) + END DO + END DO + + ! Write the obfbdata structure + CALL write_obfbdata( clfname, fbdata ) + + ! Output some basic statistics + CALL obs_wri_stats( fbdata ) + + CALL dealloc_obfbdata( fbdata ) + + END SUBROUTINE obs_wri_surf + + SUBROUTINE obs_wri_stats( fbdata ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wri_stats *** + !! + !! ** Purpose : Output some basic statistics of the data being written out + !! + !! ** Method : + !! + !! ** Action : + !! + !! ! 2014-08 (D. Lea) Initial version + !!----------------------------------------------------------------------- + + !! * Arguments + TYPE(obfbdata) :: fbdata + + !! * Local declarations + INTEGER :: jvar + INTEGER :: jo + INTEGER :: jk + INTEGER :: inumgoodobs + INTEGER :: inumgoodobsmpp + REAL(wp) :: zsumx + REAL(wp) :: zsumx2 + REAL(wp) :: zomb + + + IF (lwp) THEN + WRITE(numout,*) '' + WRITE(numout,*) 'obs_wri_stats :' + WRITE(numout,*) '~~~~~~~~~~~~~~~' + ENDIF + + DO jvar = 1, fbdata%nvar + zsumx=0.0_wp + zsumx2=0.0_wp + inumgoodobs=0 + DO jo = 1, fbdata%nobs + DO jk = 1, fbdata%nlev + IF ( ( fbdata%pob(jk,jo,jvar) < 9999.0 ) .AND. & + & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & + & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN + + zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) + zsumx=zsumx+zomb + zsumx2=zsumx2+zomb**2 + inumgoodobs=inumgoodobs+1 + ENDIF + ENDDO + ENDDO + + CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp ) + CALL mpp_sum('obs_write', zsumx) + CALL mpp_sum('obs_write', zsumx2) + + IF (lwp) THEN + WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',inumgoodobsmpp + WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp + WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp ) + WRITE(numout,*) '' + ENDIF + + ENDDO + + END SUBROUTINE obs_wri_stats + +END MODULE obs_write diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..98128ff1de268d776e618569500d4d911406b052 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/oce.f90 @@ -0,0 +1,156 @@ + + + + + + + + + + + + + +MODULE oce + !!====================================================================== + !! *** MODULE oce *** + !! Ocean : dynamics and active tracers defined in memory + !!====================================================================== + !! History : 1.0 ! 2002-11 (G. Madec) F90: Free form and module + !! 3.1 ! 2009-02 (G. Madec, M. Leclair) pure z* coordinate + !! 3.3 ! 2010-09 (C. Ethe) TRA-TRC merge: add ts, gtsu, gtsv 4D arrays + !! 3.7 ! 2014-01 (G. Madec) suppression of curl and before hdiv from in-core memory + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename prognostic variables in preparation for new time scheme + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC oce_alloc ! routine called by nemo_init in nemogcm.F90 + PUBLIC oce_SWE_alloc ! routine called by nemo_init in SWE/nemogcm.F90 (Shallow Water Eq. case) + + !! dynamics and tracer fields + !! -------------------------- + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: uu , vv !: horizontal velocities [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ww !: vertical velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wi !: vertical vel. (adaptive-implicit) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv !: horizontal divergence [s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: ts !: 4D T-S fields [Celsius,psu] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_b, rab_n !: thermal/haline expansion coef. [Celsius-1,psu-1] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rn2b , rn2 !: brunt-vaisala frequency**2 [s-2] + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rhd !: in situ density anomalie rhd=(rho-rho0)/rho0 [no units] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rhop !: potential volumic mass [kg/m3] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: Cu_adv !: vertical Courant number (adaptive-implicit) + + !! free surface + !! ------------ + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uu_b, vv_b!: SSH [m] and barotropic velocities [m/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ssh!: SSH [m] and barotropic velocities [m/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssh_frc !: Forcing term in external mode for SSH [m/s] + + !! Arrays at barotropic time step: ! befbefore! before ! now ! after ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubb_e , ub_e , un_e , ua_e !: u-external velocity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vbb_e , vb_e , vn_e , va_e !: v-external velocity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshbb_e, sshb_e!: external ssh + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshn_e, ssha_e!: external ssh + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_e !: external u-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_e !: external v-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hur_e !: inverse of u-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hvr_e !: inverse of v-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_b , vb2_b !: Half step fluxes (ln_bt_fw=T) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_bf , vn_bf !: Asselin filtered half step fluxes (ln_bt_fw=T) + + !! interpolated gradient (only used in zps case) + !! --------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtsu, gtsv !: horizontal gradient of T, S bottom u-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gru , grv !: horizontal gradient of rd at bottom u-point + + !! (ISF) interpolated gradient (only used for ice shelf case) + !! --------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtui, gtvi !: horizontal gradient of T, S and rd at top u-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: grui, grvi !: horizontal gradient of T, S and rd at top v-point + !! (ISF) ice load + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: riceload + + !! Energy budget of the leads (open water embedded in sea ice) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fraqsr_1lev !: fraction of solar net radiation absorbed in the first ocean level [-] + INTEGER, PUBLIC, DIMENSION(2) :: noce_array !: unused array but seems to be needed to prevent agrif from creating an empty module + + !! Shallow Water Eq. case (SWE) + LOGICAL, PUBLIC :: lk_SWE = .FALSE. !: shallow water flag =T in SWE configurations only + + !! Stand-Alone Surface module (SAS) + LOGICAL, PUBLIC :: l_SAS = .FALSE. !: SAS flag =T in SAS configurations only + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: oce.F90 15556 2021-11-29 15:23:06Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION oce_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(6) + !!---------------------------------------------------------------------- + ! + ierr(:) = 0 + ALLOCATE( uu (jpi,jpj,jpk,jpt) , vv (jpi,jpj,jpk,jpt) , & + & ww (jpi,jpj,jpk) , hdiv(jpi,jpj,jpk) , & + & ts (jpi,jpj,jpk,jpts,jpt) , & + & rab_b(jpi,jpj,jpk,jpts) , rab_n(jpi,jpj,jpk,jpts) , & + & rn2b (jpi,jpj,jpk) , rn2 (jpi,jpj,jpk) , & + & rhd (jpi,jpj,jpk) , rhop (jpi,jpj,jpk) , STAT=ierr(1) ) + ! + ALLOCATE( ssh (jpi,jpj,jpt) , uu_b(jpi,jpj,jpt) , vv_b(jpi,jpj,jpt) , & + & ssh_frc(jpi,jpj) , & + & gtsu(jpi,jpj,jpts) , gtsv(jpi,jpj,jpts) , & + & gru (jpi,jpj) , grv (jpi,jpj) , & + & gtui(jpi,jpj,jpts) , gtvi(jpi,jpj,jpts) , & + & grui(jpi,jpj) , grvi(jpi,jpj) , & + & riceload(jpi,jpj) , STAT=ierr(2) ) + ! + ALLOCATE( fraqsr_1lev(jpi,jpj) , STAT=ierr(3) ) + ! + ALLOCATE( ssha_e(jpi,jpj), sshn_e(jpi,jpj), sshb_e(jpi,jpj), sshbb_e(jpi,jpj), & + & ua_e(jpi,jpj), un_e(jpi,jpj), ub_e(jpi,jpj), ubb_e(jpi,jpj), & + & va_e(jpi,jpj), vn_e(jpi,jpj), vb_e(jpi,jpj), vbb_e(jpi,jpj), & + & hu_e(jpi,jpj), hur_e(jpi,jpj), hv_e(jpi,jpj), hvr_e(jpi,jpj), STAT=ierr(4) ) + ! + ALLOCATE( ub2_b(jpi,jpj), vb2_b(jpi,jpj), un_bf(jpi,jpj), vn_bf(jpi,jpj) , STAT=ierr(5) ) + ! + oce_alloc = MAXVAL( ierr ) + IF( oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'oce_alloc: failed to allocate arrays' ) + ! + END FUNCTION oce_alloc + + + INTEGER FUNCTION oce_SWE_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION oce_SWE_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(2) + !!---------------------------------------------------------------------- + ! + lk_SWE = .TRUE. ! =T SWE case + ! + ierr(:) = 0 + ALLOCATE( uu(jpi,jpj,jpk,jpt) , vv (jpi,jpj,jpk,jpt) , & + & ww(jpi,jpj,jpk) , hdiv(jpi,jpj,jpk) , ssh(jpi,jpj,jpt) , STAT=ierr(1) ) + ! + ALLOCATE( ts(jpi,jpj,jpk,jpts,jpt) , fraqsr_1lev(jpi,jpj) , & + & uu_b(jpi,jpj,jpt) , vv_b(jpi,jpj,jpt) , rn2(jpi,jpj,jpk) , STAT=ierr(2) ) + ! + oce_SWE_alloc = MAXVAL( ierr ) + IF( oce_SWE_alloc /= 0 ) CALL ctl_stop( 'STOP', 'oce_SWE_alloc: failed to allocate arrays' ) + ! + END FUNCTION oce_SWE_alloc + + !!====================================================================== +END MODULE oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ocealb.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ocealb.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4efce851fe5003079eda875f83a62ec5baad883f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/ocealb.f90 @@ -0,0 +1,61 @@ + + + + + + + + + + + + + +MODULE ocealb + !!====================================================================== + !! *** MODULE ocealb *** + !! Ocean forcing: bulk thermohaline forcing of the ocean + !!===================================================================== + !! History : + !! NEMO 4.0 ! 2017-07 (C. Rousset) Split ocean and ice albedos + !!---------------------------------------------------------------------- + !! oce_alb : albedo for ocean (clear and overcast skies) + !!---------------------------------------------------------------------- + USE phycst ! physical constants + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC oce_alb ! routine called by sbccpl + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ocealb.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE oce_alb( palb_os , palb_cs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE oce_alb *** + !! + !! ** Purpose : Computation of the albedo of the ocean + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_os ! albedo of ocean under overcast sky + REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_cs ! albedo of ocean under clear sky + !! + REAL(wp) :: zcoef + REAL(wp) :: rmue = 0.40 ! cosine of local solar altitude + !!---------------------------------------------------------------------- + ! + zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 ) ! Parameterization of Briegled and Ramanathan, 1982 + palb_cs(:,:) = zcoef + palb_os(:,:) = 0.06 ! Parameterization of Kondratyev, 1969 and Payne, 1972 + ! + END SUBROUTINE oce_alb + + !!====================================================================== +END MODULE ocealb diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/par_kind.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/par_kind.f90 new file mode 100644 index 0000000000000000000000000000000000000000..67271823d585665ff2dfe238d6faa92592487675 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/par_kind.f90 @@ -0,0 +1,51 @@ + + + + + + + + + + + + + +MODULE par_kind + !!====================================================================== + !! *** MODULE par_kind *** + !! Ocean : define the kind of real for the whole model + !!====================================================================== + !! History : 1.0 ! 2002-06 (G. Madec) Original code + !! 3.3 ! 2010-12 (G. Madec) add a standard length of character strings + !!---------------------------------------------------------------------- + + IMPLICIT NONE + PRIVATE + + ! Number model from which the SELECTED_*_KIND are requested: + ! 4 byte REAL 8 byte REAL + ! CRAY: - precision = 13 + ! exponent = 2465 + ! IEEE: precision = 6 precision = 15 + ! exponent = 37 exponent = 307 + + ! !!** Floating point ** + INTEGER, PUBLIC, PARAMETER :: sp = SELECTED_REAL_KIND( 6, 37) !: single precision (real 4) + INTEGER, PUBLIC, PARAMETER :: dp = SELECTED_REAL_KIND(12,307) !: double precision (real 8) + INTEGER, PUBLIC, PARAMETER :: wp = sp !: working precision + + ! !!** Integer ** + INTEGER, PUBLIC, PARAMETER :: i4 = SELECTED_INT_KIND( 9) !: single precision (integer 4) + INTEGER, PUBLIC, PARAMETER :: i8 = SELECTED_INT_KIND(14) !: double precision (integer 8) + + ! !!** Integer ** + INTEGER, PUBLIC, PARAMETER :: lc = 256 !: Lenght of Character strings + INTEGER, PUBLIC, PARAMETER :: lca = 400 !: Lenght of Character arrays + + !!---------------------------------------------------------------------- + !! NEMO 3.3 , NEMO Consortium (2018) + !! $Id: par_kind.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +END MODULE par_kind diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/par_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/par_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6df8e33191aa34a09e6eb8706443eef1edb5191e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/par_oce.f90 @@ -0,0 +1,120 @@ + + + + + + + + + + + + + +MODULE par_oce + !!====================================================================== + !! *** par_oce *** + !! Ocean : set the ocean parameters + !!====================================================================== + !! History : OPA ! 1991 (Imbard, Levy, Madec) Original code + !! NEMO 1.0 ! 2004-01 (G. Madec, J.-M. Molines) Free form and module + !! 3.3 ! 2010-09 (C. Ethe) TRA-TRC merge: add jpts, jp_tem & jp_sal + !!---------------------------------------------------------------------- + USE par_kind ! kind parameters + + IMPLICIT NONE + PUBLIC + + !!---------------------------------------------------------------------- + !! namcfg namelist parameters + !!---------------------------------------------------------------------- + LOGICAL :: ln_read_cfg !: (=T) read the domain configuration file or (=F) not + CHARACTER(lc) :: cn_domcfg !: filename the configuration file to be read + LOGICAL :: ln_write_cfg !: (=T) create the domain configuration file + CHARACTER(lc) :: cn_domcfg_out !: filename the configuration file to be read + ! + LOGICAL :: ln_use_jattr !: input file read offset + ! ! Use file global attribute: open_ocean_jstart to determine start j-row + ! ! when reading input from those netcdf files that have the + ! ! attribute defined. This is designed to enable input files associated + ! ! with the extended grids used in the under ice shelf configurations to + ! ! be used without redundant rows when the ice shelves are not in use. + LOGICAL :: ln_closea !: (=T) special treatment of closed sea + ! + + !!--------------------------------------------------------------------- + !! Domain Matrix size + !!--------------------------------------------------------------------- + ! configuration name & resolution (required only in ORCA family case) + CHARACTER(lc) :: cn_cfg !: name of the configuration + INTEGER :: nn_cfg !: resolution of the configuration + + ! time dimension + INTEGER, PUBLIC, PARAMETER :: jpt = 3 !: time dimension + + ! global domain size !!! * total computational domain * + INTEGER :: jpiglo !: 1st dimension of global domain --> i-direction + INTEGER :: jpjglo !: 2nd - - --> j-direction + INTEGER :: jpkglo !: 3nd - - --> k levels + + ! global domain size for AGRIF !!! * total AGRIF computational domain * + INTEGER, PUBLIC :: nbug_in_agrif_conv_do_not_remove_or_modify = 1 - 1 + INTEGER, PUBLIC, PARAMETER :: nbghostcells = 4 !: number of ghost cells: default value + INTEGER, PUBLIC :: nbghostcells_x_w !: number of ghost cells in i-direction at west + INTEGER, PUBLIC :: nbghostcells_x_e !: number of ghost cells in i-direction at east + INTEGER, PUBLIC :: nbghostcells_y_s !: number of ghost cells in j-direction at south + INTEGER, PUBLIC :: nbghostcells_y_n !: number of ghost cells in j-direction at north + INTEGER, PUBLIC :: nbcellsx !: number of cells in i-direction + INTEGER, PUBLIC :: nbcellsy !: number of cells in j-direction + + ! local domain size !!! * local computational domain * + INTEGER, PUBLIC :: jpi ! !: first dimension + INTEGER, PUBLIC :: jpj ! !: second dimension + INTEGER, PUBLIC :: jpk ! = jpkglo !: third dimension + INTEGER, PUBLIC :: jpkm1 ! = jpk-1 !: - - - + INTEGER, PUBLIC :: jpij ! = jpi*jpj !: jpi x jpj + INTEGER, PUBLIC :: jpimax! = ( Ni0glo + jpni-1 ) / jpni + 2*nn_hls !: maximum jpi + INTEGER, PUBLIC :: jpjmax! = ( Nj0glo + jpnj-1 ) / jpnj + 2*nn_hls !: maximum jpj + + ! Domain tiling + INTEGER, PUBLIC :: nijtile !: number of tiles in total + INTEGER, PUBLIC :: ntile !: current tile number + INTEGER, PUBLIC :: ntsi !: start of internal part of tile domain + INTEGER, PUBLIC :: ntsj ! + INTEGER, PUBLIC :: ntei !: end of internal part of tile domain + INTEGER, PUBLIC :: ntej ! + INTEGER, PUBLIC :: nthl, nthr !: Modifier on DO loop macro bound offset (left, right) + INTEGER, PUBLIC :: nthb, ntht !: " " (bottom, top) + + !!--------------------------------------------------------------------- + !! Active tracer parameters + !!--------------------------------------------------------------------- + INTEGER, PUBLIC, PARAMETER :: jpts = 2 !: Number of active tracers (=2, i.e. T & S ) + INTEGER, PUBLIC, PARAMETER :: jp_tem = 1 !: indice for temperature + INTEGER, PUBLIC, PARAMETER :: jp_sal = 2 !: indice for salinity + + !!---------------------------------------------------------------------- + !! Domain decomposition + !!---------------------------------------------------------------------- + !! if we dont use massively parallel computer (parameters jpni=jpnj=1) so jpiglo=jpi and jpjglo=jpj + INTEGER, PUBLIC :: jpni !: number of processors following i + INTEGER, PUBLIC :: jpnj !: number of processors following j + INTEGER, PUBLIC :: jpnij !: nb of local domain = nb of processors ( <= jpni x jpnj ) + INTEGER, PUBLIC, PARAMETER :: jpr2di = 0 !: number of columns for extra outer halo + INTEGER, PUBLIC, PARAMETER :: jpr2dj = 0 !: number of rows for extra outer halo + + ! halo with and starting/inding DO-loop indices + INTEGER, PUBLIC :: nn_hls !: halo width (applies to both rows and columns) + INTEGER, PUBLIC :: Nis0 !: start I-index without halo + INTEGER, PUBLIC :: Nie0 !: end I-index without halo + INTEGER, PUBLIC :: Njs0 !: start J-index without halo + INTEGER, PUBLIC :: Nje0 !: end J-index without halo + INTEGER, PUBLIC :: Ni_0, Nj_0 !: local domain size without halo + INTEGER, PUBLIC :: Ni0glo, Nj0glo !: global domain size without halo + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: par_oce.F90 15119 2021-07-13 14:43:22Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE par_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/phycst.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/phycst.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e02c4ea99f71dc5f9d5a06ab13f337473dad3ef7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/phycst.f90 @@ -0,0 +1,150 @@ + + + + + + + + + + + + + +MODULE phycst + !!====================================================================== + !! *** MODULE phycst *** + !! Definition of of both ocean and ice parameters used in the code + !!===================================================================== + !! History : OPA ! 1990-10 (C. Levy - G. Madec) Original code + !! 8.1 ! 1991-11 (G. Madec, M. Imbard) cosmetic changes + !! NEMO 1.0 ! 2002-08 (G. Madec, C. Ethe) F90, add ice constants + !! - ! 2006-08 (G. Madec) style + !! 3.2 ! 2006-08 (S. Masson, G. Madec) suppress useless variables + style + !! 3.4 ! 2011-11 (C. Harris) minor changes for CICE constants + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! phy_cst : define and print physical constant and domain parameters + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC phy_cst ! routine called by inipar.F90 + + REAL(wp), PUBLIC :: rpi = 3.141592653589793_wp !: pi + REAL(wp), PUBLIC :: rad = 3.141592653589793_wp / 180._wp !: conversion from degre into radian + REAL(wp), PUBLIC :: rsmall = 0.5 * EPSILON( 1.e0 ) !: smallest real computer value + + REAL(wp), PUBLIC :: rday = 24.*60.*60. !: day [s] + REAL(wp), PUBLIC :: rsiyea !: sideral year [s] + REAL(wp), PUBLIC :: rsiday !: sideral day [s] + REAL(wp), PUBLIC :: raamo = 12._wp !: number of months in one year + REAL(wp), PUBLIC :: rjjhh = 24._wp !: number of hours in one day + REAL(wp), PUBLIC :: rhhmm = 60._wp !: number of minutes in one hour + REAL(wp), PUBLIC :: rmmss = 60._wp !: number of seconds in one minute + REAL(wp), PUBLIC :: omega !: earth rotation parameter [s-1] + REAL(wp), PUBLIC :: ra = 6371229._wp !: earth radius [m] + REAL(wp), PUBLIC :: grav = 9.80665_wp !: gravity [m/s2] + REAL(wp), PUBLIC :: rt0 = 273.15_wp !: freezing point of fresh water [Kelvin] + + REAL(wp), PUBLIC :: rho0 !: volumic mass of reference [kg/m3] + REAL(wp), PUBLIC :: r1_rho0 !: = 1. / rho0 [m3/kg] + REAL(wp), PUBLIC :: rcp !: ocean specific heat [J/Kelvin] + REAL(wp), PUBLIC :: r1_rcp !: = 1. / rcp [Kelvin/J] + REAL(wp), PUBLIC :: rho0_rcp !: = rho0 * rcp + REAL(wp), PUBLIC :: r1_rho0_rcp !: = 1. / ( rho0 * rcp ) + + REAL(wp), PUBLIC :: emic = 0.97_wp !: emissivity of snow or ice (not used?) + + REAL(wp), PUBLIC :: sice = 6.0_wp !: salinity of ice (for pisces) [psu] + REAL(wp), PUBLIC :: soce = 34.7_wp !: salinity of sea (for pisces and isf) [psu] + REAL(wp), PUBLIC :: rLevap = 2.5e+6_wp !: latent heat of evaporation (water) + REAL(wp), PUBLIC :: vkarmn = 0.4_wp !: von Karman constant + REAL(wp), PUBLIC :: vkarmn2 = 0.4_wp*0.4_wp !: square of von Karman constant + REAL(wp), PUBLIC :: stefan = 5.67e-8_wp !: Stefan-Boltzmann constant + + REAL(wp), PUBLIC :: rhos = 330._wp !: volumic mass of snow [kg/m3] + REAL(wp), PUBLIC :: rhoi = 917._wp !: volumic mass of sea ice [kg/m3] + REAL(wp), PUBLIC :: rhow = 1000._wp !: volumic mass of freshwater in melt ponds [kg/m3] + REAL(wp), PUBLIC :: rcnd_i = 2.034396_wp !: thermal conductivity of fresh ice [W/m/K] + REAL(wp), PUBLIC :: rcpi = 2067.0_wp !: specific heat of fresh ice [J/kg/K] + REAL(wp), PUBLIC :: rLsub = 2.834e+6_wp !: pure ice latent heat of sublimation [J/kg] + REAL(wp), PUBLIC :: rLfus = 0.334e+6_wp !: latent heat of fusion of fresh ice [J/kg] + REAL(wp), PUBLIC :: rTmlt = 0.054_wp !: decrease of seawater meltpoint with salinity + + REAL(wp), PUBLIC :: r1_rhoi !: 1 / rhoi + REAL(wp), PUBLIC :: r1_rhos !: 1 / rhos + REAL(wp), PUBLIC :: r1_rcpi !: 1 / rcpi + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: phycst.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE phy_cst + !!---------------------------------------------------------------------- + !! *** ROUTINE phy_cst *** + !! + !! ** Purpose : set and print the constants + !!---------------------------------------------------------------------- + + rsiyea = 365.25_wp * rday * 2._wp * rpi / 6.283076_wp + rsiday = rday / ( 1._wp + rday / rsiyea ) + omega = 2._wp * rpi / rsiday + + r1_rhoi = 1._wp / rhoi + r1_rhos = 1._wp / rhos + r1_rcpi = 1._wp / rcpi + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'phy_cst : initialization of ocean parameters and constants' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) ' mathematical constant rpi = ', rpi + WRITE(numout,*) ' day rday = ', rday, ' s' + WRITE(numout,*) ' sideral year rsiyea = ', rsiyea, ' s' + WRITE(numout,*) ' sideral day rsiday = ', rsiday, ' s' + WRITE(numout,*) ' omega omega = ', omega, ' s^-1' + WRITE(numout,*) + WRITE(numout,*) ' nb of months per year raamo = ', raamo, ' months' + WRITE(numout,*) ' nb of hours per day rjjhh = ', rjjhh, ' hours' + WRITE(numout,*) ' nb of minutes per hour rhhmm = ', rhhmm, ' mn' + WRITE(numout,*) ' nb of seconds per minute rmmss = ', rmmss, ' s' + WRITE(numout,*) + WRITE(numout,*) ' earth radius ra = ', ra , ' m' + WRITE(numout,*) ' gravity grav = ', grav , ' m/s^2' + WRITE(numout,*) + WRITE(numout,*) ' freezing point of water rt0 = ', rt0 , ' K' + WRITE(numout,*) + WRITE(numout,*) ' reference density and heat capacity now defined in eosbn2.f90' + WRITE(numout,*) + WRITE(numout,*) ' thermal conductivity of pure ice = ', rcnd_i , ' J/s/m/K' + WRITE(numout,*) ' thermal conductivity of snow is defined in a namelist ' + WRITE(numout,*) ' fresh ice specific heat = ', rcpi , ' J/kg/K' + WRITE(numout,*) ' latent heat of fusion of fresh ice / snow = ', rLfus , ' J/kg' + WRITE(numout,*) ' latent heat of subl. of fresh ice / snow = ', rLsub , ' J/kg' + WRITE(numout,*) ' density of sea ice = ', rhoi , ' kg/m^3' + WRITE(numout,*) ' density of snow = ', rhos , ' kg/m^3' + WRITE(numout,*) ' density of freshwater (in melt ponds) = ', rhow , ' kg/m^3' + WRITE(numout,*) ' salinity of ice (for pisces) = ', sice , ' psu' + WRITE(numout,*) ' salinity of sea (for pisces and isf) = ', soce , ' psu' + WRITE(numout,*) ' latent heat of evaporation (water) = ', rLevap , ' J/m^3' + WRITE(numout,*) ' von Karman constant = ', vkarmn + WRITE(numout,*) ' Stefan-Boltzmann constant = ', stefan , ' J/s/m^2/K^4' + WRITE(numout,*) + WRITE(numout,*) ' conversion: degre ==> radian rad = ', rad + WRITE(numout,*) + WRITE(numout,*) ' smallest real computer value rsmall = ', rsmall + ENDIF + + END SUBROUTINE phy_cst + + !!====================================================================== +END MODULE phycst diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/prtctl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/prtctl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8d4ef67f9c3a31f93b2add70bf6f2b246454a639 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/prtctl.f90 @@ -0,0 +1,504 @@ + + + + + + + + + + + + + +MODULE prtctl + !!====================================================================== + !! *** MODULE prtctl *** + !! Ocean system : print all SUM trends for each processor domain + !!====================================================================== + !! History : 9.0 ! 05-07 (C. Talandier) original code + !! 3.4 ! 11-11 (C. Harris) decomposition changes for running with CICE + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain variables + USE domutl, ONLY : is_tile + USE in_out_manager ! I/O manager + USE mppini ! distributed memory computing + USE lib_mpp ! distributed memory computing + + IMPLICIT NONE + PRIVATE + + INTEGER , DIMENSION( :), ALLOCATABLE :: numprt_oce, numprt_top + INTEGER , DIMENSION( :), ALLOCATABLE :: nall_ictls, nall_ictle ! first, last indoor index for each i-domain + INTEGER , DIMENSION( :), ALLOCATABLE :: nall_jctls, nall_jctle ! first, last indoor index for each j-domain + REAL(wp), DIMENSION( :), ALLOCATABLE :: t_ctl , s_ctl ! previous tracer trend values + REAL(wp), DIMENSION( :), ALLOCATABLE :: u_ctl , v_ctl ! previous velocity trend values + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl ! previous top trend values + ! + PUBLIC prt_ctl ! called by all subroutines + PUBLIC prt_ctl_info ! called by all subroutines + PUBLIC prt_ctl_init ! called by nemogcm.F90 and prt_ctl_trc_init + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: prtctl.F90 15148 2021-07-27 09:40:32Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE prt_ctl (tab2d_1, tab3d_1, tab4d_1, tab2d_2, tab3d_2, mask1, mask2, & + & clinfo, clinfo1, clinfo2, clinfo3, kdim ) + !! + REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1 + REAL(wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1 + REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 + CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo1 + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo2 + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3 + INTEGER , INTENT(in), OPTIONAL :: kdim + ! + !IF( PRESENT(tab2d_2) ) THEN + !CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = is_tile(tab2d_2), ktab3d_2 = 0, & + ! & tab2d_1 = REAL(tab2d_1, wp), tab2d_2 = REAL(tab2d_2, wp), & + ! & mask1 = mask1, mask2 = mask2, & + ! & clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3 ) + !ELSEIF( PRESENT(tab3d_2) ) THEN + !CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = is_tile(tab3d_2), & + ! & tab3d_1 = REAL(tab3d_1, wp), tab3d_2 = REAL(tab3d_2, wp), & + ! & mask1 = mask1, mask2 = mask2, & + ! & clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3, kdim = kdim ) + ! ELSEIF( PRESENT(tab2d_1) ) THEN + !CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, & + ! & tab2d_1 = REAL(tab2d_1,wp), & + ! & mask1 = mask1, & + ! & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3 ) + !ELSEIF( PRESENT(tab3d_1) ) THEN + !CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, & + ! & tab3d_1 = REAL(tab3d_1, wp), & + ! & mask1 = mask1, & + ! & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim ) +! ELSEIF( PRESENT(tab4d_1) ) THEN + !CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = 0, ktab4d_1 = is_tile(tab4d_1), ktab2d_2 = 0, ktab3d_2 = 0, & + ! & tab4d_1 = REAL(tab4d_1, wp), & + ! & mask1 = mask1, & + ! & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim ) + ! ENDIF + + END SUBROUTINE prt_ctl + + + SUBROUTINE prt_ctl_t (tab2d_1, ktab2d_1, tab3d_1, ktab3d_1, tab4d_1, ktab4d_1, tab2d_2, ktab2d_2, tab3d_2, ktab3d_2, & + & mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim ) + !!---------------------------------------------------------------------- + !! *** ROUTINE prt_ctl *** + !! + !! ** Purpose : - print sum control of 2D or 3D arrays over the same area + !! in mono and mpp case. This way can be usefull when + !! debugging a new parametrization in mono or mpp. + !! + !! ** Method : 2 possibilities exist when setting the sn_cfctl%prtctl parameter to + !! .true. in the ocean namelist: + !! - to debug a MPI run .vs. a mono-processor one; + !! the control print will be done over each sub-domain. + !! The nictl[se] and njctl[se] parameters in the namelist must + !! be set to zero and [ij]splt to the corresponding splitted + !! domain in MPI along respectively i-, j- directions. + !! - to debug a mono-processor run over the whole domain/a specific area; + !! in the first case the nictl[se] and njctl[se] parameters must be set + !! to zero else to the indices of the area to be controled. In both cases + !! isplt and jsplt must be set to 1. + !! - All arguments of the above calling sequence are optional so their + !! name must be explicitly typed if used. For instance if the 3D + !! array tn(:,:,:) must be passed through the prt_ctl subroutine, + !! it must look like: !CALL prt_ctl(tab3d_1=tn). + !! + !! tab2d_1 : first 2D array + !! tab3d_1 : first 3D array + !! tab4d_1 : first 4D array + !! mask1 : mask (3D) to apply to the tab[23]d_1 array + !! clinfo1 : information about the tab[23]d_1 array + !! tab2d_2 : second 2D array + !! tab3d_2 : second 3D array + !! mask2 : mask (3D) to apply to the tab[23]d_2 array + !! clinfo2 : information about the tab[23]d_2 array + !! kdim : k- direction for 3D arrays + !! clinfo3 : additional information + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2 + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktab2d_1+1:,(ntsj-nn_hls-1)*ktab2d_1+1:) , INTENT(in), OPTIONAL :: tab2d_1 + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktab3d_1+1:,(ntsj-nn_hls-1)*ktab3d_1+1:,:) , INTENT(in), OPTIONAL :: tab3d_1 + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktab4d_1+1:,(ntsj-nn_hls-1)*ktab4d_1+1:,:,:), INTENT(in), OPTIONAL :: tab4d_1 + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktab2d_2+1:,(ntsj-nn_hls-1)*ktab2d_2+1:) , INTENT(in), OPTIONAL :: tab2d_2 + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktab3d_2+1:,(ntsj-nn_hls-1)*ktab3d_2+1:,:) , INTENT(in), OPTIONAL :: tab3d_2 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 + CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo1 + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo2 + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3 + INTEGER , INTENT(in), OPTIONAL :: kdim + ! + CHARACTER(len=30) :: cl1, cl2 + CHARACTER(len=6) :: clfmt + INTEGER :: jn, jl, kdir + INTEGER :: iis, iie, jjs, jje + INTEGER :: itra, inum + REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2 + !!---------------------------------------------------------------------- + ! + ! Arrays, scalars initialization + cl1 = '' + cl2 = '' + kdir = jpkm1 + itra = 1 + + ! Control of optional arguments + IF( PRESENT(clinfo1) ) cl1 = clinfo1 + IF( PRESENT(clinfo2) ) cl2 = clinfo2 + IF( PRESENT(kdim) ) kdir = kdim + IF( PRESENT(tab4d_1) ) itra = SIZE(tab4d_1,dim=4) + + IF( wp == sp ) clfmt = 'D23.16' ! 16 significant numbers + IF( wp == dp ) clfmt = 'D41.34' ! 34 significant numbers + + ! Loop over each sub-domain, i.e. the total number of processors ijsplt + DO jl = 1, SIZE(nall_ictls) + + ! define shoter names... + iis = MAX( nall_ictls(jl), ntsi ) + iie = MIN( nall_ictle(jl), ntei ) + jjs = MAX( nall_jctls(jl), ntsj ) + jje = MIN( nall_jctle(jl), ntej ) + + IF( PRESENT(clinfo) ) THEN ; inum = numprt_top(jl) + ELSE ; inum = numprt_oce(jl) + ENDIF + + ! Compute the sum control only where the tile domain and control print area overlap + IF( iie >= iis .AND. jje >= jjs ) THEN + DO jn = 1, itra + + IF( PRESENT(clinfo3) ) THEN + IF ( clinfo3 == 'tra-ta' ) THEN + zvctl1 = t_ctl(jl) + ELSEIF( clinfo3 == 'tra' ) THEN + zvctl1 = t_ctl(jl) + zvctl2 = s_ctl(jl) + ELSEIF( clinfo3 == 'dyn' ) THEN + zvctl1 = u_ctl(jl) + zvctl2 = v_ctl(jl) + ELSE + zvctl1 = tra_ctl(jn,jl) + ENDIF + ENDIF + + ! 2D arrays + IF( PRESENT(tab2d_1) ) THEN + IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) ) + ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) ) + ENDIF + ENDIF + IF( PRESENT(tab2d_2) ) THEN + IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) ) + ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) ) + ENDIF + ENDIF + + ! 3D arrays + IF( PRESENT(tab3d_1) ) THEN + IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) ) + ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) ) + ENDIF + ENDIF + IF( PRESENT(tab3d_2) ) THEN + IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) ) + ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) ) + ENDIF + ENDIF + + ! 4D arrays + IF( PRESENT(tab4d_1) ) THEN + IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) ) + ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) ) + ENDIF + ENDIF + + ! Print the result + IF( PRESENT(clinfo ) ) cl1 = clinfo(jn) + IF( PRESENT(clinfo3) ) THEN + ! + IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN + WRITE(inum, "(3x,a,' : ',"//clfmt//",3x,a,' : ',"//clfmt//")") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2 + ELSE + WRITE(inum, "(3x,a,' : ',"//clfmt//" )") cl1, zsum1 - zvctl1 + ENDIF + ! + SELECT CASE( clinfo3 ) + CASE ( 'tra-ta' ) + t_ctl(jl) = zsum1 + CASE ( 'tra' ) + t_ctl(jl) = zsum1 + s_ctl(jl) = zsum2 + CASE ( 'dyn' ) + u_ctl(jl) = zsum1 + v_ctl(jl) = zsum2 + CASE default + tra_ctl(jn,jl) = zsum1 + END SELECT + ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN + WRITE(inum, "(3x,a,' : ',"//clfmt//",3x,a,' : ',"//clfmt//")") cl1, zsum1, cl2, zsum2 + ELSE + WRITE(inum, "(3x,a,' : ',"//clfmt//" )") cl1, zsum1 + ENDIF + + END DO + ENDIF + IF( jpnij == 1 ) CALL FLUSH(inum) + END DO + ! + END SUBROUTINE prt_ctl_t + + + SUBROUTINE prt_ctl_info (clinfo, ivar, cdcomp ) + !!---------------------------------------------------------------------- + !! *** ROUTINE prt_ctl_info *** + !! + !! ** Purpose : - print information without any computation + !! + !! ** Action : - input arguments + !! clinfo : information about the ivar + !! ivar : value to print + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: clinfo + INTEGER , OPTIONAL, INTENT(in) :: ivar + CHARACTER(len=3), OPTIONAL, INTENT(in) :: cdcomp ! only 'top' is accepted + ! + CHARACTER(len=3) :: clcomp + INTEGER :: jl, inum + !!---------------------------------------------------------------------- + ! + IF( PRESENT(cdcomp) ) THEN ; clcomp = cdcomp + ELSE ; clcomp = 'oce' + ENDIF + ! + DO jl = 1, SIZE(nall_ictls) + ! + IF( clcomp == 'oce' ) inum = numprt_oce(jl) + IF( clcomp == 'top' ) inum = numprt_top(jl) + ! + IF ( PRESENT(ivar) ) THEN ; WRITE(inum,*) clinfo, ivar + ELSE ; WRITE(inum,*) clinfo + ENDIF + ! + END DO + ! + END SUBROUTINE prt_ctl_info + + + SUBROUTINE prt_ctl_init( cdcomp, kntra ) + !!---------------------------------------------------------------------- + !! *** ROUTINE prt_ctl_init *** + !! + !! ** Purpose : open ASCII files & compute indices + !!---------------------------------------------------------------------- + CHARACTER(len=3), OPTIONAL, INTENT(in ) :: cdcomp ! only 'top' is accepted + INTEGER , OPTIONAL, INTENT(in ) :: kntra ! only for 'top': number of tracers + ! + INTEGER :: ji, jj, jl + INTEGER :: inum, idg, idg2 + INTEGER :: ijsplt, iimax, ijmax + INTEGER, DIMENSION(:,:), ALLOCATABLE :: iimppt, ijmppt, ijpi, ijpj, iproc + INTEGER, DIMENSION( :), ALLOCATABLE :: iipos, ijpos + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisoce + CHARACTER(len=64) :: clfile_out + CHARACTER(LEN=64) :: clfmt, clfmt2, clfmt3, clfmt4 + CHARACTER(len=32) :: clname, cl_run + CHARACTER(len= 3) :: clcomp + !!---------------------------------------------------------------------- + ! + clname = 'output' + IF( PRESENT(cdcomp) ) THEN + clname = TRIM(clname)//'.'//TRIM(cdcomp) + clcomp = cdcomp + ELSE + clcomp = 'oce' + ENDIF + ! + IF( jpnij > 1 ) THEN ! MULTI processor run + cl_run = 'MULTI processor run' + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)' + WRITE(clfile_out,clfmt) 'mpp.'//trim(clname)//'_', narea - 1 + ijsplt = 1 + ELSE ! MONO processor run + cl_run = 'MONO processor run ' + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'prt_ctl_init: sn_cfctl%l_prtctl parameters' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 ) THEN ! print control done over the default area + nn_isplt = MAX(1, nn_isplt) ! number of processors following i-direction + nn_jsplt = MAX(1, nn_jsplt) ! number of processors following j-direction + ijsplt = nn_isplt * nn_jsplt ! total number of processors ijsplt + IF( ijsplt == 1 ) CALL ctl_warn( 'nn_isplt & nn_jsplt are equal to 1 -> control sum done over the whole domain' ) + IF(lwp) WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt + IF(lwp) WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt + idg = MAX( INT(LOG10(REAL(MAX(1,ijsplt-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)' + IF( ijsplt == 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', 0 + ELSE ! print control done over a specific area + ijsplt = 1 + IF( nn_ictls < 1 .OR. nn_ictls > Ni0glo ) THEN + CALL ctl_warn( ' - nictls must be 1<=nictls>=Ni0glo, it is forced to 1' ) + nn_ictls = 1 + ENDIF + IF( nn_ictle < 1 .OR. nn_ictle > Ni0glo ) THEN + CALL ctl_warn( ' - nictle must be 1<=nictle>=Ni0glo, it is forced to Ni0glo' ) + nn_ictle = Ni0glo + ENDIF + IF( nn_jctls < 1 .OR. nn_jctls > Nj0glo ) THEN + CALL ctl_warn( ' - njctls must be 1<=njctls>=Nj0glo, it is forced to 1' ) + nn_jctls = 1 + ENDIF + IF( nn_jctle < 1 .OR. nn_jctle > Nj0glo ) THEN + CALL ctl_warn( ' - njctle must be 1<=njctle>=Nj0glo, it is forced to Nj0glo' ) + nn_jctle = Nj0glo + ENDIF + WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls + WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle + WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls + WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle + idg = MAXVAL( (/ nn_ictls,nn_ictle,nn_jctls,nn_jctle /) ) ! temporary use of idg to store the largest index + idg = MAX( INT(LOG10(REAL(idg,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(4(a,i', i1, '.', i1, '))')") idg, idg ! '(4(a,ix.x))' + WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', nn_ictls, '_', nn_ictle, '_', nn_jctls, '_', nn_jctle + ENDIF + ENDIF + + ! Allocate arrays + IF( .NOT. ALLOCATED(nall_ictls) ) ALLOCATE( nall_ictls(ijsplt), nall_ictle(ijsplt), nall_jctls(ijsplt), nall_jctle(ijsplt) ) + + IF( jpnij > 1 ) THEN ! MULTI processor run + ! + nall_ictls(1) = Nis0 + nall_ictle(1) = Nie0 + nall_jctls(1) = Njs0 + nall_jctle(1) = Nje0 + ! + ELSE ! MONO processor run + ! + IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 ) THEN ! print control done over the default area + ! + ALLOCATE( iimppt(nn_isplt,nn_jsplt), ijmppt(nn_isplt,nn_jsplt), ijpi(nn_isplt,nn_jsplt), ijpj(nn_isplt,nn_jsplt), & + & llisoce(nn_isplt,nn_jsplt), iproc(nn_isplt,nn_jsplt), iipos(nn_isplt*nn_jsplt), ijpos(nn_isplt*nn_jsplt) ) + CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, nn_isplt, nn_jsplt, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj ) + CALL mpp_is_ocean( llisoce ) + CALL mpp_getnum( llisoce, iproc, iipos, ijpos ) + ! + DO jj = 1,nn_jsplt + DO ji = 1, nn_isplt + jl = iproc(ji,jj) + 1 + nall_ictls(jl) = iimppt(ji,jj) - 1 + 1 + nn_hls + nall_ictle(jl) = iimppt(ji,jj) - 1 + ijpi(ji,jj) - nn_hls + nall_jctls(jl) = ijmppt(ji,jj) - 1 + 1 + nn_hls + nall_jctle(jl) = ijmppt(ji,jj) - 1 + ijpj(ji,jj) - nn_hls + END DO + END DO + ! + DEALLOCATE( iimppt, ijmppt, ijpi, ijpj, llisoce, iproc, iipos, ijpos ) + ! + ELSE ! print control done over a specific area + ! + nall_ictls(1) = nn_ictls + nn_hls + nall_ictle(1) = nn_ictle + nn_hls + nall_jctls(1) = nn_jctls + nn_hls + nall_jctle(1) = nn_jctle + nn_hls + ! + ENDIF + ENDIF + + ! Initialization + IF( clcomp == 'oce' ) THEN + ALLOCATE( t_ctl(ijsplt), s_ctl(ijsplt), u_ctl(ijsplt), v_ctl(ijsplt), numprt_oce(ijsplt) ) + t_ctl(:) = 0.e0 + s_ctl(:) = 0.e0 + u_ctl(:) = 0.e0 + v_ctl(:) = 0.e0 + ENDIF + IF( clcomp == 'top' ) THEN + ALLOCATE( tra_ctl(kntra,ijsplt), numprt_top(ijsplt) ) + tra_ctl(:,:) = 0.e0 + ENDIF + + DO jl = 1,ijsplt + + IF( ijsplt > 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', jl-1 + + CALL ctl_opn( inum, clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. ) + IF( clcomp == 'oce' ) numprt_oce(jl) = inum + IF( clcomp == 'top' ) numprt_top(jl) = inum + WRITE(inum,*) + WRITE(inum,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC' + WRITE(inum,*) ' NEMO team' + WRITE(inum,*) ' Ocean General Circulation Model' + IF( clcomp == 'oce' ) WRITE(inum,*) ' NEMO version 4.x (2020) ' + IF( clcomp == 'top' ) WRITE(inum,*) ' TOP vversion x (2020) ' + WRITE(inum,*) + IF( ijsplt > 1 ) & + & WRITE(inum,*) ' MPI-subdomain number: ', jl-1 + IF( jpnij > 1 ) & + & WRITE(inum,*) ' MPI-subdomain number: ', narea-1 + WRITE(inum,*) + WRITE(inum,'(19x,a20)') cl_run + WRITE(inum,*) + WRITE(inum,*) 'prt_ctl : Sum control indices' + WRITE(inum,*) '~~~~~~~' + WRITE(inum,*) + ! + ! clfmt2: ' ----- jctle = XXX (YYY) -----' -> '(18x, 13a1, a9, iM, a2, iN, a2, 13a1)' + ! clfmt3: ' | |' -> '(18x, a1, Nx, a1)' + ! clfmt4: ' ictls = XXX (YYY) ictle = XXX (YYY)' -> '(Nx, a9, iM, a2, iP, a2, Qx, a9, iM, a2, iP, a2)' + ! ' | |' + ! ' ----- jctle = XXX (YYY) -----' + ! clfmt5: ' njmpp = XXX' -> '(Nx, a9, iM)' + ! clfmt6: ' nimpp = XXX' -> '(Nx, a9, iM)' + ! + idg = MAXVAL( (/ nall_ictls(jl), nall_ictle(jl), nall_jctls(jl), nall_jctle(jl) /) ) ! temporary use of idg + idg = INT(LOG10(REAL(idg,wp))) + 1 ! how many digits do we use? + idg2 = MAXVAL( (/ mig0(nall_ictls(jl)), mig0(nall_ictle(jl)), mjg0(nall_jctls(jl)), mjg0(nall_jctle(jl)) /) ) + idg2 = INT(LOG10(REAL(idg2,wp))) + 1 ! how many digits do we use? + WRITE(clfmt2, "('(18x, 13a1, a9, i', i1, ', a2, i',i1,', a2, 13a1)')") idg, idg2 + WRITE(clfmt3, "('(18x, a1, ', i2,'x, a1)')") 13+9+idg+2+idg2+2+13 - 2 + WRITE(clfmt4, "('(', i2,'x, a9, i', i1,', a2, i', i1,', a2, ', i2,'x, a9, i', i1,', a2, i', i1,', a2)')") & + & 18-7, idg, idg2, 13+9+idg+2+idg2+2+13 - (2+idg+2+idg2+2+8), idg, idg2 + WRITE(inum,clfmt2) ('-', ji=1,13), ' jctle = ', nall_jctle(jl), ' (', mjg0(nall_jctle(jl)), ') ', ('-', ji=1,13) + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt4) ' ictls = ', nall_ictls(jl), ' (', mig0(nall_ictls(jl)), ') ', & + & ' ictle = ', nall_ictle(jl), ' (', mig0(nall_ictle(jl)), ') ' + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt2) ('-', ji=1,13), ' jctls = ', nall_jctls(jl), ' (', mjg0(nall_jctls(jl)), ') ', ('-', ji=1,13) + WRITE(inum,*) + WRITE(inum,*) + ! + END DO + ! + END SUBROUTINE prt_ctl_init + + + !!====================================================================== +END MODULE prtctl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/restart.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/restart.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b0a91b4a9c26f4fd181267d5d6a67756afbeabc7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/restart.f90 @@ -0,0 +1,423 @@ + + + + + + + + + + + + + +MODULE restart + !!====================================================================== + !! *** MODULE restart *** + !! Ocean restart : write the ocean restart file + !!====================================================================== + !! History : OPA ! 1999-11 (M. Imbard) Original code + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form + !! 2.0 ! 2006-07 (S. Masson) use IOM for restart + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) modified LF-RA + !! - - ! 2010-10 (C. Ethe, G. Madec) TRC-TRA merge (T-S in 4D) + !! 3.7 ! 2014-01 (G. Madec) suppression of curl and hdiv from the restart + !! - ! 2014-12 (G. Madec) remove KPP scheme + !! 4.1 ! 2020-11 (S. Techene, G. Madec) move ssh initiatlisation in rst_read_ssh + !! - ! add restart in Shallow Water Eq. case + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! rst_opn : open the ocean restart file for writting + !! rst_write : write the ocean restart file + !! rst_read_open : open the restart file for reading + !! rst_read : read the ocean restart file + !! rst_read_ssh : ssh set from restart or domcfg.nc file or usr_def_istat_ssh + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_ice ! only lk_si3 + USE phycst ! physical constants + USE eosbn2 ! equation of state + USE wet_dry ! Wetting/Drying flux limiting + USE usrdef_istate, ONLY : usr_def_istate_ssh ! user defined ssh initial state + USE trdmxl_oce ! ocean active mixed layer tracers trends variables + USE diu_bulk ! ??? + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC rst_opn ! called by step.F90 + PUBLIC rst_write ! called by step.F90 + PUBLIC rst_read_open ! called in rst_read_ssh + PUBLIC rst_read ! called by istate.F90 + PUBLIC rst_read_ssh ! called by domain.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: restart.F90 15141 2021-07-23 14:20:12Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE rst_opn( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE rst_opn *** + !! + !! ** Purpose : + initialization (should be read in the namelist) of nitrst + !! + open the restart when we are one time step before nitrst + !! - restart header is defined when kt = nitrst-1 + !! - restart data are written when kt = nitrst + !! + define lrst_oce to .TRUE. when we need to define or write the restart + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step + !! + CHARACTER(LEN=20) :: clkt ! ocean time-step deine as a character + CHARACTER(LEN=50) :: clname ! ocean output restart file name + CHARACTER(lc) :: clpath ! full path to ocean output restart file + CHARACTER(LEN=52) :: clpname ! ocean output restart file name including prefix for AGRIF + CHARACTER(LEN=256) :: clinfo ! info character + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN ! default definitions + lrst_oce = .FALSE. + IF( ln_rst_list ) THEN + nrst_lst = 1 + nitrst = nn_stocklist( nrst_lst ) + ELSE + nitrst = nitend + ENDIF + ENDIF + + IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart + + ! frequency-based restart dumping (nn_stock) + IF( .NOT. ln_rst_list .AND. MOD( kt - 1, nn_stock ) == 0 ) THEN + ! we use kt - 1 and not kt - nit000 to keep the same periodicity from the beginning of the experiment + nitrst = kt + nn_stock - 1 ! define the next value of nitrst for restart writing + IF( nitrst > nitend ) nitrst = nitend ! make sure we write a restart at the end of the run + ENDIF + ! to get better performances with NetCDF format: + ! we open and define the ocean restart file one time step before writing the data (-> at nitrst - 1) + ! except if we write ocean restart files every time step or if an ocean restart file was writen at nitend - 1 + IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN + IF( nitrst <= nitend .AND. nitrst > 0 ) THEN + ! beware of the format used to write kt (default is i8.8, that should be large enough...) + IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst + ELSE ; WRITE(clkt, '(i8.8)') nitrst + ENDIF + ! create the file + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_ocerst_out) + clpath = TRIM(cn_ocerst_outdir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + IF(lwp) THEN + WRITE(numout,*) + IF(.NOT.lwxios) THEN + WRITE(numout,*) ' open ocean restart NetCDF file: ',TRIM(clpath)//TRIM(clname) + IF ( snc4set%luse ) WRITE(numout,*) ' opened for NetCDF4 chunking and compression' + IF( kt == nitrst - 1 ) THEN ; WRITE(numout,*) ' kt = nitrst - 1 = ', kt + ELSE ; WRITE(numout,*) ' kt = ' , kt + ENDIF + ENDIF + ENDIF + ! + IF(.NOT.lwxios) THEN + CALL iom_open( TRIM(clpath)//TRIM(clname), numrow, ldwrt = .TRUE. ) + ELSE + cw_ocerst_cxt = "rstw_"//TRIM(ADJUSTL(clkt)) + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + clpname = clname + ELSE + clpname = TRIM(Agrif_CFixed())//"_"//clname + ENDIF + numrow = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) + CALL iom_init( cw_ocerst_cxt, kdid = numrow, ld_closedef = .false. ) + CALL iom_swap( cxios_context ) + ENDIF + lrst_oce = .TRUE. + ENDIF + ENDIF + ! + END SUBROUTINE rst_opn + + + SUBROUTINE rst_write( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE rstwrite *** + !! + !! ** Purpose : Write restart fields in NetCDF format + !! + !! ** Method : Write in numrow when kt == nitrst in NetCDF + !! file, save fields which are necessary for restart + !! + !! NB: ssh is written here (rst_write) + !! but is read or set in rst_read_ssh + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + !!---------------------------------------------------------------------- + ! + CALL iom_rstput( kt, nitrst, numrow, 'rdt' , rn_Dt ) ! dynamics time step + ! + IF( .NOT.lwxios ) CALL iom_delay_rst( 'WRITE', 'OCE', numrow ) ! save only ocean delayed global communication variables + ! + IF( .NOT.ln_diurnal_only ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'sshb', ssh(:,: ,Kbb) ) ! before fields + CALL iom_rstput( kt, nitrst, numrow, 'ub' , uu(:,:,: ,Kbb) ) + CALL iom_rstput( kt, nitrst, numrow, 'vb' , vv(:,:,: ,Kbb) ) + CALL iom_rstput( kt, nitrst, numrow, 'tb' , ts(:,:,:,jp_tem,Kbb) ) + CALL iom_rstput( kt, nitrst, numrow, 'sb' , ts(:,:,:,jp_sal,Kbb) ) + ! + CALL iom_rstput( kt, nitrst, numrow, 'sshn', ssh(:,: ,Kmm) ) ! now fields + CALL iom_rstput( kt, nitrst, numrow, 'un' , uu(:,:,: ,Kmm) ) + CALL iom_rstput( kt, nitrst, numrow, 'vn' , vv(:,:,: ,Kmm) ) + CALL iom_rstput( kt, nitrst, numrow, 'tn' , ts(:,:,:,jp_tem,Kmm) ) + CALL iom_rstput( kt, nitrst, numrow, 'sn' , ts(:,:,:,jp_sal,Kmm) ) + IF( .NOT.lk_SWE ) CALL iom_rstput( kt, nitrst, numrow, 'rhop', rhop ) + ENDIF + + IF( ln_diurnal ) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst ) + IF( kt == nitrst ) THEN + IF( .NOT.lwxios ) THEN + CALL iom_close( numrow ) ! close the restart file (only at last time step) + ELSE + CALL iom_context_finalize( cw_ocerst_cxt ) + iom_file(numrow)%nfid = 0 + numrow = 0 + ENDIF +!!gm IF( .NOT. lk_trdmld ) lrst_oce = .FALSE. +!!gm not sure what to do here ===>>> ask to Sebastian + lrst_oce = .FALSE. + IF( ln_rst_list ) THEN + nrst_lst = MIN(nrst_lst + 1, SIZE(nn_stocklist,1)) + nitrst = nn_stocklist( nrst_lst ) + ENDIF + ENDIF + ! + END SUBROUTINE rst_write + + + SUBROUTINE rst_read_open + !!---------------------------------------------------------------------- + !! *** ROUTINE rst_read_open *** + !! + !! ** Purpose : Open read files for NetCDF restart + !! + !! ** Method : Use a non-zero, positive value of numror to assess whether or not + !! the file has already been opened + !!---------------------------------------------------------------------- + LOGICAL :: llok + CHARACTER(len=lc) :: clpath ! full path to ocean output restart file + CHARACTER(len=lc+2) :: clpname ! file name including agrif prefix + !!---------------------------------------------------------------------- + ! + IF( numror <= 0 ) THEN + IF(lwp) THEN ! Contol prints + WRITE(numout,*) + WRITE(numout,*) 'rst_read : read oce NetCDF restart file' + IF ( snc4set%luse ) WRITE(numout,*) 'rst_read : configured with NetCDF4 support' + WRITE(numout,*) '~~~~~~~~' + ENDIF + lxios_sini = .FALSE. + clpath = TRIM(cn_ocerst_indir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + CALL iom_open( TRIM(clpath)//cn_ocerst_in, numror ) +! are we using XIOS to read the data? Part above will have to modified once XIOS +! can handle checking if variable is in the restart file (there will be no need to open +! restart) + lrxios = lrxios.AND.lxios_sini + + IF( lrxios) THEN + cr_ocerst_cxt = 'oce_rst' + IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS' +! IF( TRIM(Agrif_CFixed()) == '0' ) THEN +! clpname = cn_ocerst_in +! ELSE +! clpname = TRIM(Agrif_CFixed())//"_"//cn_ocerst_in +! ENDIF + CALL iom_init( cr_ocerst_cxt, kdid = numror, ld_closedef = .TRUE. ) + CALL iom_swap( cxios_context ) + ENDIF + + ENDIF + + END SUBROUTINE rst_read_open + + + SUBROUTINE rst_read( Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rst_read *** + !! + !! ** Purpose : Read velocity and T-S fields in the restart file + !! + !! ** Method : Read in restart.nc fields which are necessary for restart + !! + !! NB: restart file openned in DOM/domain.F90:dom_init + !! before field in restart tested in DOM/domain.F90:dom_init + !! (sshb) + !! + !! NB: ssh is read or set in rst_read_ssh + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices + INTEGER :: jk + REAL(wp), DIMENSION(jpi, jpj, jpk) :: w3d + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zgdept ! 3D workspace for QCO + !!---------------------------------------------------------------------- + ! + IF(.NOT.lrxios ) CALL iom_delay_rst( 'READ', 'OCE', numror ) ! read only ocean delayed global communication variables + ! + ! !* Diurnal DSST + IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst ) + IF( ln_diurnal_only ) THEN + IF(lwp) WRITE( numout, * ) & + & "rst_read:- ln_diurnal_only set, setting rhop=rho0" + rhop = rho0 + CALL iom_get( numror, jpdom_auto, 'tn' , w3d ) + ts(:,:,1,jp_tem,Kmm) = w3d(:,:,1) + RETURN + ENDIF + ! + ! !* Read Kmm fields (MLF only) + IF(lwp) WRITE(numout,*) ' Kmm u, v and T-S fields read in the restart file' + CALL iom_get( numror, jpdom_auto, 'un', uu(:,:,: ,Kmm), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vn', vv(:,:,: ,Kmm), cd_type = 'V', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'tn', ts(:,:,:,jp_tem,Kmm) ) + CALL iom_get( numror, jpdom_auto, 'sn', ts(:,:,:,jp_sal,Kmm) ) + ! + IF( l_1st_euler ) THEN !* Euler restart (MLF only) + IF(lwp) WRITE(numout,*) ' Kbb u, v and T-S fields set to Kmm values' + uu(:,:,: ,Kbb) = uu(:,:,: ,Kmm) ! all before fields set to now values + vv(:,:,: ,Kbb) = vv(:,:,: ,Kmm) + ts(:,:,:,:,Kbb) = ts(:,:,:,:,Kmm) + ! + ELSE !* Leap frog restart (MLF only) + IF(lwp) WRITE(numout,*) ' Kbb u, v and T-S fields read in the restart file' + CALL iom_get( numror, jpdom_auto, 'ub', uu(:,:,: ,Kbb), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vb', vv(:,:,: ,Kbb), cd_type = 'V', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'tb', ts(:,:,:,jp_tem,Kbb) ) + CALL iom_get( numror, jpdom_auto, 'sb', ts(:,:,:,jp_sal,Kbb) ) + ENDIF + ! + IF( .NOT.lk_SWE ) THEN + IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_auto, 'rhop' , rhop ) ! now potential density + ELSE + ALLOCATE( zgdept(jpi,jpj,jpk) ) + DO jk = 1, jpk + zgdept(:,:,jk) = (gdept_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) + END DO + CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, zgdept ) + DEALLOCATE( zgdept ) + ENDIF + ENDIF + ! + END SUBROUTINE rst_read + + + SUBROUTINE rst_read_ssh( Kbb, Kmm, Kaa ) + !!--------------------------------------------------------------------- + !! *** ROUTINE rst_read_ssh *** + !! + !! ** Purpose : ssh initialization of the sea surface height (ssh) + !! + !! ** Method : set ssh from restart or read configuration, or user_def + !! * ln_rstart = T + !! USE of IOM library to read ssh in the restart file + !! Leap-Frog: Kbb and Kmm are read except for l_1st_euler=T + !! + !! * otherwise + !! call user defined ssh or + !! set to -ssh_ref in wet and drying case with domcfg.nc + !! + !! NB: ssh_b/n are written by restart.F90 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + ! + INTEGER :: ji, jj, jk + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'rst_read_ssh : ssh initialization' + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! + ! !=============================! + IF( ln_rstart ) THEN !== Read the restart file ==! + ! !=============================! + ! + ! !* MLF: Read ssh at Kmm + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Kmm sea surface height read in the restart file' + CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) + ! + IF( l_1st_euler ) THEN !* MLF: Euler at first time-step + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Euler first time step : ssh(Kbb) = ssh(Kmm)' + ssh(:,:,Kbb) = ssh(:,:,Kmm) + ! + ELSE !* MLF: read ssh at Kbb + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Kbb sea surface height read in the restart file' + CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) + ENDIF + ! !============================! + ELSE !== Initialize at "rest" ==! + ! !============================! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' initialization at rest' + ! + IF( ll_wd ) THEN !* wet and dry + ! + IF( ln_read_cfg ) THEN ! read configuration : ssh_ref is read in domain_cfg file +!!st why ssh is not masked : i.e. ssh(:,:,Kmm) = -ssh_ref*ssmask(:,:), +!!st since at the 1st time step lbclnk will be applied on ssh at Kaa but not initially at Kbb and Kmm + ssh(:,:,Kbb) = -ssh_ref + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth + ssh(ji,jj,Kbb) = rn_wdmin1 - ht_0(ji,jj) + ENDIF + END DO ; END DO + ELSE ! user define configuration case + CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) + ENDIF + ! + ELSE !* user defined configuration + CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) + ! + ENDIF + ssh(:,:,Kmm) = ssh(:,:,Kbb) !* MLF: set now values from to before ones + ENDIF + ! + ! !==========================! + ssh(:,:,Kaa) = 0._wp !== Set to 0 for AGRIF ==! + ! !==========================! + ! + END SUBROUTINE rst_read_ssh + + !!===================================================================== +END MODULE restart diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbc_ice.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbc_ice.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2e3f84c10bbb7275e7a0baf7debd0c5f9274f692 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbc_ice.f90 @@ -0,0 +1,72 @@ + + + + + + + + + + + + + +MODULE sbc_ice + !!====================================================================== + !! *** MODULE sbc_ice *** + !! Surface module - SI3 & CICE: parameters & variables defined in memory + !!====================================================================== + !! History : 3.0 ! 2006-08 (G. Madec) Surface module + !! 3.2 ! 2009-06 (S. Masson) merge with ice_oce + !! 3.3.1 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation + !! 3.4 ! 2011-11 (C. Harris) CICE added as an option + !! 4.0 ! 2018 (many people) SI3 compatibility + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! Default option NO SI3 or CICE sea-ice model + !!---------------------------------------------------------------------- + USE lib_mpp ! MPP library + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_ice_alloc ! + + LOGICAL , PUBLIC, PARAMETER :: lk_si3 = .FALSE. !: no SI3 ice model + LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE ice model + + INTEGER , PUBLIC, PARAMETER :: jpl = 1 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice, alb_ice, qns_ice, dqns_ice ! (jpi,jpj,jpl) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i, h_s + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt, botmelt + ! + !! arrays related to embedding ice in the ocean. + !! These arrays need to be declared even if no ice model is required. + !! In the no ice model or traditional levitating ice cases they contain only zeros + !! --------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass !: mass of snow and ice at current ice time step [Kg/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass_b !: mass of snow and ice at previous ice time step [Kg/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_fmass !: time evolution of mass of snow+ice [Kg/m2/s] + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_ice_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_ice_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(1) + !!---------------------------------------------------------------------- + ierr(:) = 0 + ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) ) + sbc_ice_alloc = MAXVAL( ierr ) + CALL mpp_sum ( 'sbc_ice', sbc_ice_alloc ) + IF( sbc_ice_alloc > 0 ) CALL ctl_warn('sbc_ice_alloc: allocation of arrays failed') + END FUNCTION sbc_ice_alloc + + !!====================================================================== +END MODULE sbc_ice diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbc_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbc_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5a6ca21f8c6e5f6a3f1a7c96bf1424b33967f14e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbc_oce.f90 @@ -0,0 +1,247 @@ + + + + + + + + + + + + + +MODULE sbc_oce + !!====================================================================== + !! *** MODULE sbc_oce *** + !! Surface module : variables defined in core memory + !!====================================================================== + !! History : 3.0 ! 2006-06 (G. Madec) Original code + !! - ! 2008-08 (G. Madec) namsbc moved from sbcmod + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps + !! - ! 2010-11 (G. Madec) ice-ocean stress always computed at each ocean time-step + !! 3.3 ! 2010-10 (J. Chanut, C. Bricaud) add the surface pressure forcing + !! 4.0 ! 2012-05 (C. Rousset) add attenuation coef for use in ice model + !! 4.0 ! 2016-06 (L. Brodeau) new unified bulk routine (based on AeroBulk) + !! 4.0 ! 2019-03 (F. Lemarié, G. Samson) add compatibility with ABL mode + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) modified wave parameters in namelist + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_oce_alloc : allocation of sbc arrays + !! sbc_tau2wnd : wind speed estimated from wind stress + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_oce_alloc ! routine called in sbcmod.F90 + PUBLIC sbc_tau2wnd ! routine called in several sbc modules + + !!---------------------------------------------------------------------- + !! Namelist for the Ocean Surface Boundary Condition + !!---------------------------------------------------------------------- + ! !!* namsbc namelist * + LOGICAL , PUBLIC :: ln_usr !: user defined formulation + LOGICAL , PUBLIC :: ln_flx !: flux formulation + LOGICAL , PUBLIC :: ln_blk !: bulk formulation + LOGICAL , PUBLIC :: ln_abl !: Atmospheric boundary layer model + LOGICAL , PUBLIC :: ln_wave !: wave in the system (forced or coupled) + LOGICAL , PUBLIC :: lk_oasis = .FALSE. !: OASIS unused + LOGICAL , PUBLIC :: ln_cpl !: ocean-atmosphere coupled formulation + LOGICAL , PUBLIC :: ln_mixcpl !: ocean-atmosphere forced-coupled mixed formulation + LOGICAL , PUBLIC :: ln_dm2dc !: Daily mean to Diurnal Cycle short wave (qsr) + LOGICAL , PUBLIC :: ln_rnf !: runoffs / runoff mouths + LOGICAL , PUBLIC :: ln_ssr !: Sea Surface restoring on SST and/or SSS + LOGICAL , PUBLIC :: ln_apr_dyn !: Atmospheric pressure forcing used on dynamics (ocean & ice) + INTEGER , PUBLIC :: nn_ice !: flag for ice in the surface boundary condition (=0/1/2/3) + LOGICAL , PUBLIC :: ln_ice_embd !: flag for levitating/embedding sea-ice in the ocean + ! !: =F levitating ice (no presure effect) with mass and salt exchanges + ! !: =T embedded sea-ice (pressure effect + mass and salt exchanges) + INTEGER , PUBLIC :: nn_components !: flag for sbc module (including sea-ice) coupling mode (see component definition below) + INTEGER , PUBLIC :: nn_fwb !: FreshWater Budget: + ! !: = 0 unchecked + ! !: = 1 global mean of e-p-r set to zero at each nn_fsbc time step + ! !: = 2 annual global mean of e-p-r set to zero + LOGICAL , PUBLIC :: ln_icebergs !: Icebergs + ! + INTEGER , PUBLIC :: nn_lsm !: Number of iteration if seaoverland is applied + ! + ! !!* namsbc_cpl namelist * + INTEGER , PUBLIC :: nn_cats_cpl !: Number of sea ice categories over which the coupling is carried out + ! + ! !!* namsbc_wave namelist * + LOGICAL , PUBLIC :: ln_sdw !: =T 3d stokes drift from wave model + LOGICAL , PUBLIC :: ln_stcor !: =T if Stokes-Coriolis and tracer advection terms are used + LOGICAL , PUBLIC :: ln_cdgw !: =T neutral drag coefficient from wave model + LOGICAL , PUBLIC :: ln_tauoc !: =T if normalized stress from wave is used + LOGICAL , PUBLIC :: ln_wave_test !: =T wave test case (constant Stokes drift) + LOGICAL , PUBLIC :: ln_charn !: =T Chranock coefficient from wave model + LOGICAL , PUBLIC :: ln_taw !: =T wind stress corrected by wave intake + LOGICAL , PUBLIC :: ln_phioc !: =T TKE surface BC from wave model + LOGICAL , PUBLIC :: ln_bern_srfc !: Bernoulli head, waves' inuced pressure + LOGICAL , PUBLIC :: ln_breivikFV_2016 !: Breivik 2016 profile + LOGICAL , PUBLIC :: ln_vortex_force !: vortex force activation + LOGICAL , PUBLIC :: ln_stshear !: Stoked Drift shear contribution in zdftke + ! + !!---------------------------------------------------------------------- + !! switch definition (improve readability) + !!---------------------------------------------------------------------- + INTEGER , PUBLIC, PARAMETER :: jp_usr = 1 !: user defined formulation + INTEGER , PUBLIC, PARAMETER :: jp_flx = 2 !: flux formulation + INTEGER , PUBLIC, PARAMETER :: jp_blk = 3 !: bulk formulation + INTEGER , PUBLIC, PARAMETER :: jp_abl = 4 !: Atmospheric boundary layer formulation + INTEGER , PUBLIC, PARAMETER :: jp_purecpl = 5 !: Pure ocean-atmosphere Coupled formulation + INTEGER , PUBLIC, PARAMETER :: jp_none = 6 !: for OCE when doing coupling via SAS module + ! + !!---------------------------------------------------------------------- + !! component definition + !!---------------------------------------------------------------------- + INTEGER , PUBLIC, PARAMETER :: jp_iam_nemo = 0 !: Initial single executable configuration + ! (no internal OASIS coupling) + INTEGER , PUBLIC, PARAMETER :: jp_iam_oce = 1 !: Multi executable configuration - OCE component + ! (internal OASIS coupling) + INTEGER , PUBLIC, PARAMETER :: jp_iam_sas = 2 !: Multi executable configuration - SAS component + ! (internal OASIS coupling) + !!---------------------------------------------------------------------- + !! Ocean Surface Boundary Condition fields + !!---------------------------------------------------------------------- + INTEGER , PUBLIC :: ncpl_qsr_freq = 0 !: qsr coupling frequency per days from atmosphere (used by top) + ! + !! !! now ! before !! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau , utau_b !: sea surface i-stress (ocean referential) [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau , vtau_b !: sea surface j-stress (ocean referential) [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_icb, vtau_icb !: sea surface (i,j)-stress used by icebergs [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: taum !: module of sea surface stress (at T-point) [N/m2] + !! wndm is used compute surface gases exchanges in ice-free ocean or leads + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm !: wind speed module at T-point (=|U10m-Uoce|) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhoa !: air density at "rn_zu" m above the sea [kg/m3] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr !: sea heat flux: solar [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns , qns_b !: sea heat flux: non solar [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_tot !: total solar heat flux (over sea and ice) [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns_tot !: total non solar heat flux (over sea and ice) [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp , emp_b !: freshwater budget: volume flux [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx , sfx_b !: salt flux [PSS.kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_tot !: total E-P over ocean and ice [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fmmflx !: freshwater budget: freezing/melting [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf , rnf_b !: river runoff [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwficb , fwficb_b !: iceberg melting [Kg/m2/s] + !! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sbc_tsc, sbc_tsc_b !: sbc content trend [K.m/s] jpi,jpj,jpts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_hc , qsr_hc_b !: heat content trend due to qsr flux [K.m/s] jpi,jpj,jpk + !! + !! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tprecip !: total precipitation [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sprecip !: solid precipitation [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_i !: ice fraction = 1 - lead fraction (between 0 to 1) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: atm_co2 !: atmospheric pCO2 [ppm] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask !: coupling mask for ln_mixcpl (warning: allocated in sbccpl) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: cloud_fra !: cloud cover (fraction of cloud in a gridcell) [-] + + !!--------------------------------------------------------------------- + !! ABL Vertical Domain size + !!--------------------------------------------------------------------- + INTEGER , PUBLIC :: jpka = 2 !: ABL number of vertical levels (default definition) + INTEGER , PUBLIC :: jpkam1 = 1 !: jpka-1 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ght_abl, ghw_abl !: ABL geopotential height (needed for iom) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_abl, e3w_abl !: ABL vertical scale factors (needed for iom) + + !!---------------------------------------------------------------------- + !! Sea Surface Mean fields + !!---------------------------------------------------------------------- + INTEGER , PUBLIC :: nn_fsbc !: frequency of sbc computation (as well as sea-ice model) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssu_m !: mean (nn_fsbc time-step) surface sea i-current (U-point) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssv_m !: mean (nn_fsbc time-step) surface sea j-current (V-point) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sst_m !: mean (nn_fsbc time-step) surface sea temperature [Celsius] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sss_m !: mean (nn_fsbc time-step) surface sea salinity [psu] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssh_m !: mean (nn_fsbc time-step) sea surface height [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tsk_m !: mean (nn_fsbc time-step) SKIN surface sea temp. [Celsius] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3t_m !: mean (nn_fsbc time-step) sea surface layer thickness [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_m !: mean (nn_fsbc time-step) fraction of solar net radiation absorbed in the 1st T level [-] + + !!---------------------------------------------------------------------- + !! Surface atmospheric fields + !!---------------------------------------------------------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_air_zt !: specific humidity of air at z=zt [kg/kg]ww + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: theta_air_zt !: potential temperature of air at z=zt [K] + + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbc_oce.F90 15372 2021-10-14 15:47:24Z davestorkey $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_oce_alloc() + !!--------------------------------------------------------------------- + !! *** FUNCTION sbc_oce_alloc *** + !!--------------------------------------------------------------------- + INTEGER :: ierr(6) + !!--------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( utau(jpi,jpj) , utau_b(jpi,jpj) , taum(jpi,jpj) , & + & vtau(jpi,jpj) , vtau_b(jpi,jpj) , wndm(jpi,jpj) , rhoa(jpi,jpj) , STAT=ierr(1) ) + ! + ALLOCATE( qns_tot(jpi,jpj) , qns (jpi,jpj) , qns_b(jpi,jpj), & + & qsr_tot(jpi,jpj) , qsr (jpi,jpj) , & + & emp (jpi,jpj) , emp_b(jpi,jpj) , & + & sfx (jpi,jpj) , sfx_b(jpi,jpj) , emp_tot(jpi,jpj), fmmflx(jpi,jpj), STAT=ierr(2) ) + ! + ALLOCATE( rnf (jpi,jpj) , sbc_tsc (jpi,jpj,jpts) , qsr_hc (jpi,jpj,jpk) , & + & rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , & + & fwficb (jpi,jpj), fwficb_b(jpi,jpj), STAT=ierr(3) ) + ! + ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) , & + & atm_co2(jpi,jpj) , tsk_m(jpi,jpj) , cloud_fra(jpi,jpj), & + & ssu_m (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) , & + & ssv_m (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) ) + ! + ALLOCATE( e3t_m(jpi,jpj) , STAT=ierr(5) ) + ! + ALLOCATE( q_air_zt(jpi,jpj) , theta_air_zt(jpi,jpj) , STAT=ierr(6) ) !#LB + ! + sbc_oce_alloc = MAXVAL( ierr ) + CALL mpp_sum ( 'sbc_oce', sbc_oce_alloc ) + IF( sbc_oce_alloc > 0 ) CALL ctl_warn('sbc_oce_alloc: allocation of arrays failed') + ! + END FUNCTION sbc_oce_alloc + + + SUBROUTINE sbc_tau2wnd + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_tau2wnd *** + !! + !! ** Purpose : Estimation of wind speed as a function of wind stress + !! + !! ** Method : |tau|=rhoa*Cd*|U|^2 + !!--------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: ztx, zty, ztau, zcoef ! temporary variables + INTEGER :: ji, jj ! dummy indices + !!--------------------------------------------------------------------- + zcoef = 0.5 / ( zrhoa * zcdrag ) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ztx = utau(ji-1,jj ) + utau(ji,jj) + zty = vtau(ji ,jj-1) + vtau(ji,jj) + ztau = SQRT( ztx * ztx + zty * zty ) + wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1) + END DO ; END DO + CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1.0_wp ) + ! + END SUBROUTINE sbc_tau2wnd + + !!====================================================================== +END MODULE sbc_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbc_phy.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbc_phy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cc1a26e1a2e4669aa79f7cce4344e046b5e6b761 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbc_phy.f90 @@ -0,0 +1,1293 @@ + + + + + + + + + + + + + +MODULE sbc_phy + !!====================================================================== + !! *** MODULE sbc_phy *** + !! A set of functions to compute air themodynamics parameters + !! needed by Aerodynamic Bulk Formulas + !!===================================================================== + !! 4.x ! 2020 L. Brodeau from AeroBulk package (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------- + + !! virt_temp : virtual (aka sensible) temperature (potential or absolute) + !! rho_air : density of (moist) air (depends on T_air, q_air and SLP + !! visc_air : kinematic viscosity (aka Nu_air) of air from temperature + !! L_vap : latent heat of vaporization of water as a function of temperature + !! cp_air : specific heat of (moist) air (depends spec. hum. q_air) + !! gamma_moist : adiabatic lapse-rate of moist air + !! One_on_L : 1. / ( Obukhov length ) + !! Ri_bulk : bulk Richardson number aka BRN + !! q_sat : saturation humidity as a function of SLP and temperature + !! q_air_rh : specific humidity as a function of RH (fraction, not %), t_air and SLP + + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + + IMPLICIT NONE + PUBLIC !! Haleluja that was the solution for AGRIF + + INTEGER , PARAMETER, PUBLIC :: nb_iter0 = 5 ! Default number of itterations in bulk-param algorithms (can be overriden b.m.o `nb_iter` optional argument) + + !! (mainly removed from sbcblk.F90) + REAL(wp), PARAMETER, PUBLIC :: rCp_dry = 1005.0_wp !: Specic heat of dry air, constant pressure [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: rCp_vap = 1860.0_wp !: Specic heat of water vapor, constant pressure [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: R_dry = 287.05_wp !: Specific gas constant for dry air [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: R_vap = 461.495_wp !: Specific gas constant for water vapor [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: reps0 = R_dry/R_vap !: ratio of gas constant for dry air and water vapor => ~ 0.622 + REAL(wp), PARAMETER, PUBLIC :: rctv0 = R_vap/R_dry - 1._wp !: for virtual temperature (== (1-eps)/eps) => ~ 0.608 + REAL(wp), PARAMETER, PUBLIC :: rCp_air = 1000.5_wp !: specific heat of air (only used for ice fluxes now...) + REAL(wp), PARAMETER, PUBLIC :: albo = 0.066_wp !: ocean albedo assumed to be constant + REAL(wp), PARAMETER, PUBLIC :: R_gas = 8.314510_wp !: Universal molar gas constant [J/mol/K] + REAL(wp), PARAMETER, PUBLIC :: rmm_dryair = 28.9647e-3_wp !: dry air molar mass / molecular weight [kg/mol] + REAL(wp), PARAMETER, PUBLIC :: rmm_water = 18.0153e-3_wp !: water molar mass / molecular weight [kg/mol] + REAL(wp), PARAMETER, PUBLIC :: rmm_ratio = rmm_water / rmm_dryair + REAL(wp), PARAMETER, PUBLIC :: rgamma_dry = R_gas / ( rmm_dryair * rCp_dry ) !: Poisson constant for dry air + REAL(wp), PARAMETER, PUBLIC :: rpref = 1.e5_wp !: reference air pressure for exner function [Pa] + ! + REAL(wp), PARAMETER, PUBLIC :: rho0_a = 1.2_wp !: Approx. of density of air [kg/m^3] + REAL(wp), PARAMETER, PUBLIC :: rho0_w = 1025._wp !: Density of sea-water (ECMWF->1025) [kg/m^3] + REAL(wp), PARAMETER, PUBLIC :: radrw = rho0_a/rho0_w !: Density ratio + REAL(wp), PARAMETER, PUBLIC :: sq_radrw = SQRT(rho0_a/rho0_w) + REAL(wp), PARAMETER, PUBLIC :: rCp0_w = 4190._wp !: Specific heat capacity of seawater (ECMWF 4190) [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: rnu0_w = 1.e-6_wp !: kinetic viscosity of water [m^2/s] + REAL(wp), PARAMETER, PUBLIC :: rk0_w = 0.6_wp !: thermal conductivity of water (at 20C) [W/m/K] + ! + REAL(wp), PARAMETER, PUBLIC :: emiss_w = 0.98_wp !: Long-wave (thermal) emissivity of sea-water [] + ! + REAL(wp), PARAMETER, PUBLIC :: emiss_i = 0.996_wp !: " for ice and snow => but Rees 1993 suggests can be lower in winter on fresh snow... 0.72 ... + + REAL(wp), PARAMETER, PUBLIC :: wspd_thrshld_ice = 0.2_wp !: minimum scalar wind speed accepted over sea-ice... [m/s] + + ! + REAL(wp), PARAMETER, PUBLIC :: rdct_qsat_salt = 0.98_wp !: reduction factor on specific humidity at saturation (q_sat(T_s)) due to salt + REAL(wp), PARAMETER, PUBLIC :: rtt0 = 273.16_wp !: triple point of temperature [K] + ! + REAL(wp), PARAMETER, PUBLIC :: rcst_cs = -16._wp*9.80665_wp*rho0_w*rCp0_w*rnu0_w*rnu0_w*rnu0_w/(rk0_w*rk0_w) !: for cool-skin parameterizations... (grav = 9.80665_wp) + ! => see eq.(14) in Fairall et al. 1996 (eq.(6) of Zeng aand Beljaars is WRONG! (typo?) + + REAL(wp), PARAMETER, PUBLIC :: z0_sea_max = 0.0025_wp !: maximum realistic value for roughness length of sea-surface... [m] + + REAL(wp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] + + + REAL(wp), PARAMETER, PUBLIC :: Cx_min = 0.1E-3_wp ! smallest value allowed for bulk transfer coefficients (usually in stable conditions with now wind) + + REAL(wp), PARAMETER :: & + !! Constants for Goff formula in the presence of ice: + & rAg_i = -9.09718_wp, & + & rBg_i = -3.56654_wp, & + & rCg_i = 0.876793_wp, & + & rDg_i = LOG10(6.1071_wp) + + REAL(wp), PARAMETER :: rc_louis = 5._wp + REAL(wp), PARAMETER :: rc2_louis = rc_louis * rc_louis + REAL(wp), PARAMETER :: ram_louis = 2. * rc_louis + REAL(wp), PARAMETER :: rah_louis = 3. * rc_louis + + + INTERFACE virt_temp + MODULE PROCEDURE virt_temp_vctr, virt_temp_sclr + END INTERFACE virt_temp + + INTERFACE pres_temp + MODULE PROCEDURE pres_temp_vctr, pres_temp_sclr + END INTERFACE pres_temp + + INTERFACE theta_exner + MODULE PROCEDURE theta_exner_vctr, theta_exner_sclr + END INTERFACE theta_exner + + INTERFACE visc_air + MODULE PROCEDURE visc_air_vctr, visc_air_sclr + END INTERFACE visc_air + + INTERFACE gamma_moist + MODULE PROCEDURE gamma_moist_vctr, gamma_moist_sclr + END INTERFACE gamma_moist + + INTERFACE e_sat + MODULE PROCEDURE e_sat_vctr, e_sat_sclr + END INTERFACE e_sat + + INTERFACE e_sat_ice + MODULE PROCEDURE e_sat_ice_vctr, e_sat_ice_sclr + END INTERFACE e_sat_ice + + INTERFACE de_sat_dt_ice + MODULE PROCEDURE de_sat_dt_ice_vctr, de_sat_dt_ice_sclr + END INTERFACE de_sat_dt_ice + + INTERFACE Ri_bulk + MODULE PROCEDURE Ri_bulk_vctr, Ri_bulk_sclr + END INTERFACE Ri_bulk + + INTERFACE q_sat + MODULE PROCEDURE q_sat_vctr, q_sat_sclr + END INTERFACE q_sat + + INTERFACE dq_sat_dt_ice + MODULE PROCEDURE dq_sat_dt_ice_vctr, dq_sat_dt_ice_sclr + END INTERFACE dq_sat_dt_ice + + INTERFACE L_vap + MODULE PROCEDURE L_vap_vctr, L_vap_sclr + END INTERFACE L_vap + + INTERFACE rho_air + MODULE PROCEDURE rho_air_vctr, rho_air_sclr + END INTERFACE rho_air + + INTERFACE cp_air + MODULE PROCEDURE cp_air_vctr, cp_air_sclr + END INTERFACE cp_air + + INTERFACE alpha_sw + MODULE PROCEDURE alpha_sw_vctr, alpha_sw_sclr + END INTERFACE alpha_sw + + INTERFACE bulk_formula + MODULE PROCEDURE bulk_formula_vctr, bulk_formula_sclr + END INTERFACE bulk_formula + + INTERFACE qlw_net + MODULE PROCEDURE qlw_net_vctr, qlw_net_sclr + END INTERFACE qlw_net + + INTERFACE f_m_louis + MODULE PROCEDURE f_m_louis_vctr, f_m_louis_sclr + END INTERFACE f_m_louis + + INTERFACE f_h_louis + MODULE PROCEDURE f_h_louis_vctr, f_h_louis_sclr + END INTERFACE f_h_louis + + + PUBLIC virt_temp + PUBLIC pres_temp + PUBLIC theta_exner + PUBLIC rho_air + PUBLIC visc_air + PUBLIC L_vap + PUBLIC cp_air + PUBLIC gamma_moist + PUBLIC One_on_L + PUBLIC Ri_bulk + PUBLIC q_sat + PUBLIC q_air_rh + PUBLIC dq_sat_dt_ice + ! + PUBLIC update_qnsol_tau + PUBLIC alpha_sw + PUBLIC bulk_formula + PUBLIC qlw_net + ! + PUBLIC f_m_louis, f_h_louis + PUBLIC z0_from_Cd + PUBLIC Cd_from_z0 + PUBLIC UN10_from_ustar + PUBLIC UN10_from_CD + PUBLIC z0tq_LKB + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcblk.F90 10535 2019-01-16 17:36:47Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + + FUNCTION virt_temp_sclr( pta, pqa ) + !!------------------------------------------------------------------------ + !! + !! Compute the (absolute/potential) VIRTUAL temperature, based on the + !! (absolute/potential) temperature and specific humidity + !! + !! If input temperature is absolute then output virtual temperature is absolute + !! If input temperature is potential then output virtual temperature is potential + !! + !! Author: L. Brodeau, June 2019 / AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------ + REAL(wp) :: virt_temp_sclr !: virtual temperature [K] + REAL(wp), INTENT(in) :: pta !: absolute or potential air temperature [K] + REAL(wp), INTENT(in) :: pqa !: specific humidity of air [kg/kg] + !!------------------------------------------------------------------- + ! + virt_temp_sclr = pta * (1._wp + rctv0*pqa) + !! + !! This is exactly the same thing as: + !! virt_temp_sclr = pta * ( pwa + reps0) / (reps0*(1.+pwa)) + !! with wpa (mixing ration) defined as : pwa = pqa/(1.-pqa) + ! + END FUNCTION virt_temp_sclr + + FUNCTION virt_temp_vctr( pta, pqa ) + + REAL(wp), DIMENSION(jpi,jpj) :: virt_temp_vctr !: virtual temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute or potential air temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: specific humidity of air [kg/kg] + + virt_temp_vctr(:,:) = pta(:,:) * (1._wp + rctv0*pqa(:,:)) + + END FUNCTION virt_temp_vctr + + + FUNCTION pres_temp_sclr( pqspe, pslp, pz, ptpot, pta, l_ice ) + + !!------------------------------------------------------------------------------- + !! *** FUNCTION pres_temp *** + !! + !! ** Purpose : compute air pressure using barometric equation + !! from either potential or absolute air temperature + !! ** Author: G. Samson, Feb 2021 + !!------------------------------------------------------------------------------- + + REAL(wp) :: pres_temp_sclr ! air pressure [Pa] + REAL(wp), INTENT(in ) :: pqspe ! air specific humidity [kg/kg] + REAL(wp), INTENT(in ) :: pslp ! sea-level pressure [Pa] + REAL(wp), INTENT(in ) :: pz ! height above surface [m] + REAL(wp), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K] + REAL(wp), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K] + REAL(wp) :: ztpot, zta, zpa, zxm, zmask, zqsat + INTEGER :: it, niter = 3 ! iteration indice and number + LOGICAL , INTENT(in) , OPTIONAL :: l_ice ! sea-ice presence + LOGICAL :: lice ! sea-ice presence + + IF( PRESENT(ptpot) ) THEN + zmask = 1._wp + ztpot = ptpot + zta = 0._wp + ELSE + zmask = 0._wp + ztpot = 0._wp + zta = pta + ENDIF + + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + + zpa = pslp ! air pressure first guess [Pa] + DO it = 1, niter + zta = ztpot * ( zpa / rpref )**rgamma_dry * zmask + (1._wp - zmask) * zta + zqsat = q_sat( zta, zpa, l_ice=lice ) ! saturation specific humidity [kg/kg] + zxm = (1._wp - pqspe/zqsat) * rmm_dryair + pqspe/zqsat * rmm_water ! moist air molar mass [kg/mol] + zpa = pslp * EXP( -grav * zxm * pz / ( R_gas * zta ) ) + END DO + + pres_temp_sclr = zpa + IF(( PRESENT(pta) ).AND.( PRESENT(ptpot) )) pta = zta + + END FUNCTION pres_temp_sclr + + + FUNCTION pres_temp_vctr( pqspe, pslp, pz, ptpot, pta, l_ice ) + + !!------------------------------------------------------------------------------- + !! *** FUNCTION pres_temp *** + !! + !! ** Purpose : compute air pressure using barometric equation + !! from either potential or absolute air temperature + !! ** Author: G. Samson, Feb 2021 + !!------------------------------------------------------------------------------- + + REAL(wp), DIMENSION(jpi,jpj) :: pres_temp_vctr ! air pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqspe ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pslp ! sea-level pressure [Pa] + REAL(wp), INTENT(in ) :: pz ! height above surface [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K] + INTEGER :: ji, jj ! loop indices + LOGICAL , INTENT(in) , OPTIONAL :: l_ice ! sea-ice presence + LOGICAL :: lice ! sea-ice presence + + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + + IF( PRESENT(ptpot) ) THEN + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + pres_temp_vctr(ji,jj) = pres_temp_sclr( pqspe(ji,jj), pslp(ji,jj), pz, ptpot=ptpot(ji,jj), pta=pta(ji,jj), l_ice=lice ) + END DO ; END DO + ELSE + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + pres_temp_vctr(ji,jj) = pres_temp_sclr( pqspe(ji,jj), pslp(ji,jj), pz, pta=pta(ji,jj), l_ice=lice ) + END DO ; END DO + ENDIF + + END FUNCTION pres_temp_vctr + + + FUNCTION theta_exner_sclr( pta, ppa ) + + !!------------------------------------------------------------------------------- + !! *** FUNCTION theta_exner *** + !! + !! ** Purpose : compute air/surface potential temperature from absolute temperature + !! and pressure using Exner function + !! ** Author: G. Samson, Feb 2021 + !!------------------------------------------------------------------------------- + + REAL(wp) :: theta_exner_sclr ! air/surface potential temperature [K] + REAL(wp), INTENT(in) :: pta ! air/surface absolute temperature [K] + REAL(wp), INTENT(in) :: ppa ! air/surface pressure [Pa] + + theta_exner_sclr = pta * ( rpref / ppa ) ** rgamma_dry + + END FUNCTION theta_exner_sclr + + FUNCTION theta_exner_vctr( pta, ppa ) + + !!------------------------------------------------------------------------------- + !! *** FUNCTION theta_exner *** + !! + !! ** Purpose : compute air/surface potential temperature from absolute temperature + !! and pressure using Exner function + !! ** Author: G. Samson, Feb 2021 + !!------------------------------------------------------------------------------- + + REAL(wp), DIMENSION(jpi,jpj) :: theta_exner_vctr ! air/surface potential temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta ! air/surface absolute temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! air/surface pressure [Pa] + INTEGER :: ji, jj ! loop indices + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + theta_exner_vctr(ji,jj) = theta_exner_sclr( pta(ji,jj), ppa(ji,jj) ) + END DO ; END DO + + END FUNCTION theta_exner_vctr + + + FUNCTION rho_air_vctr( ptak, pqa, ppa ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION rho_air_vctr *** + !! + !! ** Purpose : compute density of (moist) air using the eq. of state of the atmosphere + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! pressure in [Pa] + REAL(wp), DIMENSION(jpi,jpj) :: rho_air_vctr ! density of moist air [kg/m^3] + !!------------------------------------------------------------------------------- + + rho_air_vctr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp ) + + END FUNCTION rho_air_vctr + + FUNCTION rho_air_sclr( ptak, pqa, ppa ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION rho_air_sclr *** + !! + !! ** Purpose : compute density of (moist) air using the eq. of state of the atmosphere + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: ptak ! air temperature [K] + REAL(wp), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), INTENT(in) :: ppa ! pressure in [Pa] + REAL(wp) :: rho_air_sclr ! density of moist air [kg/m^3] + !!------------------------------------------------------------------------------- + rho_air_sclr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp ) + + END FUNCTION rho_air_sclr + + + FUNCTION visc_air_sclr(ptak) + !!---------------------------------------------------------------------------------- + !! Air kinetic viscosity (m^2/s) given from air temperature in Kelvin + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: visc_air_sclr ! kinetic viscosity (m^2/s) + REAL(wp), INTENT(in) :: ptak ! air temperature in (K) + ! + REAL(wp) :: ztc, ztc2 ! local scalar + !!---------------------------------------------------------------------------------- + ! + ztc = ptak - rt0 ! air temp, in deg. C + ztc2 = ztc*ztc + visc_air_sclr = 1.326e-5*(1. + 6.542E-3*ztc + 8.301e-6*ztc2 - 4.84e-9*ztc2*ztc) + ! + END FUNCTION visc_air_sclr + + FUNCTION visc_air_vctr(ptak) + + REAL(wp), DIMENSION(jpi,jpj) :: visc_air_vctr ! kinetic viscosity (m^2/s) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature in (K) + INTEGER :: ji, jj ! dummy loop indices + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + visc_air_vctr(ji,jj) = visc_air_sclr( ptak(ji,jj) ) + END DO ; END DO + + END FUNCTION visc_air_vctr + + + FUNCTION L_vap_vctr( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION L_vap_vctr *** + !! + !! ** Purpose : Compute the latent heat of vaporization of water from temperature + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: L_vap_vctr ! latent heat of vaporization [J/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K] + !!---------------------------------------------------------------------------------- + ! + L_vap_vctr = ( 2.501_wp - 0.00237_wp * ( psst(:,:) - rt0) ) * 1.e6_wp + ! + END FUNCTION L_vap_vctr + + FUNCTION L_vap_sclr( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION L_vap_sclr *** + !! + !! ** Purpose : Compute the latent heat of vaporization of water from temperature + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: L_vap_sclr ! latent heat of vaporization [J/kg] + REAL(wp), INTENT(in) :: psst ! water temperature [K] + !!---------------------------------------------------------------------------------- + ! + L_vap_sclr = ( 2.501_wp - 0.00237_wp * ( psst - rt0) ) * 1.e6_wp + ! + END FUNCTION L_vap_sclr + + + FUNCTION cp_air_vctr( pqa ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION cp_air_vctr *** + !! + !! ** Purpose : Compute specific heat (Cp) of moist air + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(jpi,jpj) :: cp_air_vctr ! specific heat of moist air [J/K/kg] + !!------------------------------------------------------------------------------- + + cp_air_vctr = rCp_dry + rCp_vap * pqa + + END FUNCTION cp_air_vctr + + FUNCTION cp_air_sclr( pqa ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION cp_air_sclr *** + !! + !! ** Purpose : Compute specific heat (Cp) of moist air + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp) :: cp_air_sclr ! specific heat of moist air [J/K/kg] + !!------------------------------------------------------------------------------- + + cp_air_sclr = rCp_dry + rCp_vap * pqa + + END FUNCTION cp_air_sclr + + + FUNCTION gamma_moist_sclr( ptak, pqa ) + !!---------------------------------------------------------------------------------- + !! ** Purpose : Compute the moist adiabatic lapse-rate. + !! => http://glossary.ametsoc.org/wiki/Moist-adiabatic_lapse_rate + !! => http://www.geog.ucsb.edu/~joel/g266_s10/lecture_notes/chapt03/oh10_3_01/oh10_3_01.html + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: gamma_moist_sclr ! [K/m] + REAL(wp), INTENT(in) :: ptak ! absolute air temperature [K] !#LB: double check it's absolute !!! + REAL(wp), INTENT(in) :: pqa ! specific humidity [kg/kg] + ! + REAL(wp) :: zta, zqa, zwa, ziRT, zLvap ! local scalars + !!---------------------------------------------------------------------------------- + zta = MAX( ptak, 180._wp) ! prevents screw-up over masked regions where field == 0. + zqa = MAX( pqa, 1.E-6_wp) ! " " " + !! + zwa = zqa / (1._wp - zqa) ! w is mixing ratio w = q/(1-q) | q = w/(1+w) + ziRT = 1._wp / (R_dry*zta) ! 1/RT + zLvap = L_vap_sclr( ptak ) + !! + gamma_moist_sclr = grav * ( 1._wp + zLvap*zwa*ziRT ) / ( rCp_dry + zLvap*zLvap*zwa*reps0*ziRT/zta ) + !! + END FUNCTION gamma_moist_sclr + + FUNCTION gamma_moist_vctr( ptak, pqa ) + + REAL(wp), DIMENSION(jpi,jpj) :: gamma_moist_vctr + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa + INTEGER :: ji, jj + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + gamma_moist_vctr(ji,jj) = gamma_moist_sclr( ptak(ji,jj), pqa(ji,jj) ) + END DO ; END DO + + END FUNCTION gamma_moist_vctr + + + FUNCTION One_on_L( ptha, pqa, pus, pts, pqs ) + !!------------------------------------------------------------------------ + !! + !! Evaluates the 1./(Obukhov length) from air temperature, + !! air specific humidity, and frictional scales u*, t* and q* + !! + !! Author: L. Brodeau, June 2019 / AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------ + REAL(wp), DIMENSION(jpi,jpj) :: One_on_L !: 1./(Obukhov length) [m^-1] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha !: reference potential temperature of air [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: reference specific humidity of air [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: u*: friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts, pqs !: \theta* and q* friction aka turb. scales for temp. and spec. hum. + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zqa ! local scalar + !!------------------------------------------------------------------- + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zqa = (1._wp + rctv0*pqa(ji,jj)) + ! + ! The main concern is to know whether, the vertical turbulent flux of virtual temperature, < u' theta_v' > is estimated with: + ! a/ -u* [ theta* (1 + 0.61 q) + 0.61 theta q* ] => this is the one that seems correct! chose this one! + ! or + ! b/ -u* [ theta* + 0.61 theta q* ] + ! + One_on_L(ji,jj) = grav*vkarmn*( pts(ji,jj)*zqa + rctv0*ptha(ji,jj)*pqs(ji,jj) ) & + & / MAX( pus(ji,jj)*pus(ji,jj)*ptha(ji,jj)*zqa , 1.E-9_wp ) + END DO ; END DO + ! + One_on_L = SIGN( MIN(ABS(One_on_L),200._wp), One_on_L ) ! (prevent FPE from stupid values over masked regions...) + ! + END FUNCTION One_on_L + + + FUNCTION Ri_bulk_sclr( pz, psst, ptha, pssq, pqa, pub, pta_layer, pqa_layer ) + !!---------------------------------------------------------------------------------- + !! Bulk Richardson number according to "wide-spread equation"... + !! + !! Reminder: the Richardson number is the ratio "buoyancy" / "shear" + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: Ri_bulk_sclr + REAL(wp), INTENT(in) :: pz ! height above the sea (aka "delta z") [m] + REAL(wp), INTENT(in) :: psst ! potential SST [K] + REAL(wp), INTENT(in) :: ptha ! pot. air temp. at height "pz" [K] + REAL(wp), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] + REAL(wp), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg] + REAL(wp), INTENT(in) :: pub ! bulk wind speed [m/s] + REAL(wp), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] + REAL(wp), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] + !! + LOGICAL :: l_ptqa_l_prvd = .FALSE. + REAL(wp) :: zqa, zta, zgamma, zdthv, ztv, zsstv ! local scalars + REAL(wp) :: ztptv + !!------------------------------------------------------------------- + IF( PRESENT(pta_layer) .AND. PRESENT(pqa_layer) ) l_ptqa_l_prvd = .TRUE. + ! + zsstv = virt_temp_sclr( psst, pssq ) ! virtual potential SST + ztptv = virt_temp_sclr( ptha, pqa ) ! virtual potential air temperature + zdthv = ztptv - zsstv ! air-sea delta of "virtual potential temperature" + ! + Ri_bulk_sclr = grav * zdthv * pz / ( ztptv * pub * pub ) ! the usual definition of Ri_bulk_sclr + ! + END FUNCTION Ri_bulk_sclr + + FUNCTION Ri_bulk_vctr( pz, psst, ptha, pssq, pqa, pub, pta_layer, pqa_layer ) + + REAL(wp), DIMENSION(jpi,jpj) :: Ri_bulk_vctr + REAL(wp) , INTENT(in) :: pz ! height above the sea (aka "delta z") [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! SST [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha ! pot. air temp. at height "pz" [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub ! bulk wind speed [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] + !! + LOGICAL :: l_ptqa_l_prvd = .FALSE. + INTEGER :: ji, jj + + IF( PRESENT(pta_layer) .AND. PRESENT(pqa_layer) ) l_ptqa_l_prvd = .TRUE. + IF( l_ptqa_l_prvd ) THEN + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj), & + & pta_layer=pta_layer(ji,jj ), pqa_layer=pqa_layer(ji,jj ) ) + END DO ; END DO + ELSE + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj) ) + END DO ; END DO + END IF + + END FUNCTION Ri_bulk_vctr + + + FUNCTION e_sat_sclr( ptak ) + !!---------------------------------------------------------------------------------- + !! *** FUNCTION e_sat_sclr *** + !! < SCALAR argument version > + !! ** Purpose : water vapor at saturation in [Pa] + !! Based on accurate estimate by Goff, 1957 + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !! + !! Note: what rt0 should be here, is 273.16 (triple point of water) and not 273.15 like here + !!---------------------------------------------------------------------------------- + REAL(wp) :: e_sat_sclr ! water vapor at saturation [kg/kg] + REAL(wp), INTENT(in) :: ptak ! air temperature [K] + REAL(wp) :: zta, ztmp ! local scalar + !!---------------------------------------------------------------------------------- + zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... + ztmp = rt0 / zta !#LB: rt0 or rtt0 ???? (273.15 vs 273.16 ) + ! + ! Vapour pressure at saturation [Pa] : WMO, (Goff, 1957) + e_sat_sclr = 100.*( 10.**( 10.79574*(1. - ztmp) - 5.028*LOG10(zta/rt0) & + & + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(zta/rt0 - 1.)) ) & + & + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614) ) + ! + END FUNCTION e_sat_sclr + + FUNCTION e_sat_vctr(ptak) + REAL(wp), DIMENSION(jpi,jpj) :: e_sat_vctr !: vapour pressure at saturation [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: temperature (K) + INTEGER :: ji, jj ! dummy loop indices + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + e_sat_vctr(ji,jj) = e_sat_sclr(ptak(ji,jj)) + END DO ; END DO + END FUNCTION e_sat_vctr + + + FUNCTION e_sat_ice_sclr(ptak) + !!--------------------------------------------------------------------------------- + !! Same as "e_sat" but over ice rather than water! + !!--------------------------------------------------------------------------------- + REAL(wp) :: e_sat_ice_sclr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp), INTENT(in) :: ptak + !! + REAL(wp) :: zta, zle, ztmp + !!--------------------------------------------------------------------------------- + zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... + ztmp = rtt0/zta + !! + zle = rAg_i*(ztmp - 1._wp) + rBg_i*LOG10(ztmp) + rCg_i*(1._wp - zta/rtt0) + rDg_i + !! + e_sat_ice_sclr = 100._wp * 10._wp**zle + + END FUNCTION e_sat_ice_sclr + + FUNCTION e_sat_ice_vctr(ptak) + !! Same as "e_sat" but over ice rather than water! + REAL(wp), DIMENSION(jpi,jpj) :: e_sat_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + e_sat_ice_vctr(ji,jj) = e_sat_ice_sclr( ptak(ji,jj) ) + END DO ; END DO + + END FUNCTION e_sat_ice_vctr + + + FUNCTION de_sat_dt_ice_sclr(ptak) + !!--------------------------------------------------------------------------------- + !! d [ e_sat_ice ] / dT (derivative / temperature) + !! Analytical exact formulation: double checked!!! + !! => DOUBLE-check possible / finite-difference version with "./bin/test_phymbl.x" + !!--------------------------------------------------------------------------------- + REAL(wp) :: de_sat_dt_ice_sclr !: [Pa/K] + REAL(wp), INTENT(in) :: ptak + !! + REAL(wp) :: zta, zde + !!--------------------------------------------------------------------------------- + zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... + !! + zde = -(rAg_i*rtt0)/(zta*zta) - rBg_i/(zta*LOG(10._wp)) - rCg_i/rtt0 + !! + de_sat_dt_ice_sclr = LOG(10._wp) * zde * e_sat_ice_sclr(zta) + END FUNCTION de_sat_dt_ice_sclr + + FUNCTION de_sat_dt_ice_vctr(ptak) + !! Same as "e_sat" but over ice rather than water! + REAL(wp), DIMENSION(jpi,jpj) :: de_sat_dt_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + de_sat_dt_ice_vctr(ji,jj) = de_sat_dt_ice_sclr( ptak(ji,jj) ) + END DO ; END DO + + END FUNCTION de_sat_dt_ice_vctr + + + FUNCTION q_sat_sclr( pta, ppa, l_ice ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION q_sat_sclr *** + !! + !! ** Purpose : Conputes specific humidity of air at saturation + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: q_sat_sclr + REAL(wp), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), INTENT(in) :: ppa !: atmospheric pressure [Pa] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + REAL(wp) :: ze_s + LOGICAL :: lice + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + IF( lice ) THEN + ze_s = e_sat_ice( pta ) + ELSE + ze_s = e_sat( pta ) ! Vapour pressure at saturation (Goff) : + END IF + q_sat_sclr = reps0*ze_s/(ppa - (1._wp - reps0)*ze_s) + + END FUNCTION q_sat_sclr + + FUNCTION q_sat_vctr( pta, ppa, l_ice ) + + REAL(wp), DIMENSION(jpi,jpj) :: q_sat_vctr + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + LOGICAL :: lice + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + q_sat_vctr(ji,jj) = q_sat_sclr( pta(ji,jj) , ppa(ji,jj), l_ice=lice ) + END DO ; END DO + + END FUNCTION q_sat_vctr + + + FUNCTION dq_sat_dt_ice_sclr( pta, ppa ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION dq_sat_dt_ice_sclr *** + !! => d [ q_sat_ice(T) ] / dT + !! Analytical exact formulation: double checked!!! + !! => DOUBLE-check possible / finite-difference version with "./bin/test_phymbl.x" + !!---------------------------------------------------------------------------------- + REAL(wp) :: dq_sat_dt_ice_sclr + REAL(wp), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), INTENT(in) :: ppa !: atmospheric pressure [Pa] + REAL(wp) :: ze_s, zde_s_dt, ztmp + !!---------------------------------------------------------------------------------- + ze_s = e_sat_ice_sclr( pta ) ! Vapour pressure at saturation in presence of ice (Goff) + zde_s_dt = de_sat_dt_ice( pta ) + ! + ztmp = (reps0 - 1._wp)*ze_s + ppa + ! + dq_sat_dt_ice_sclr = reps0*ppa*zde_s_dt / ( ztmp*ztmp ) + ! + END FUNCTION dq_sat_dt_ice_sclr + + FUNCTION dq_sat_dt_ice_vctr( pta, ppa ) + + REAL(wp), DIMENSION(jpi,jpj) :: dq_sat_dt_ice_vctr + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + dq_sat_dt_ice_vctr(ji,jj) = dq_sat_dt_ice_sclr( pta(ji,jj) , ppa(ji,jj) ) + END DO ; END DO + + END FUNCTION dq_sat_dt_ice_vctr + + + FUNCTION q_air_rh(prha, ptak, ppa) + !!---------------------------------------------------------------------------------- + !! Specific humidity of air out of Relative Humidity + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: q_air_rh + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prha !: relative humidity [fraction, not %!!!] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: air temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: ze ! local scalar + !!---------------------------------------------------------------------------------- + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ze = prha(ji,jj)*e_sat_sclr(ptak(ji,jj)) + q_air_rh(ji,jj) = ze*reps0/(ppa(ji,jj) - (1. - reps0)*ze) + END DO ; END DO + ! + END FUNCTION q_air_rh + + + SUBROUTINE UPDATE_QNSOL_TAU( pzu, pTs, pqs, pTa, pqa, pust, ptst, pqst, pwnd, pUb, ppa, prlw, prhoa, & + & pQns, pTau, & + & Qlat) + !!---------------------------------------------------------------------------------- + !! Purpose: returns the non-solar heat flux to the ocean aka "Qlat + Qsen + Qlw" + !! and the module of the wind stress => pTau = Tau + !! ** Author: L. Brodeau, Sept. 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pust ! u* + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptst ! t* + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqst ! q* + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prlw ! downwelling longwave radiative flux [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! air density [kg/m3] + ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQns ! non-solar heat flux to the ocean aka "Qlat + Qsen + Qlw" [W/m^2]] + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + ! + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(out) :: Qlat + ! + REAL(wp) :: zdt, zdq, zCd, zCh, zCe, zz0, zQlat, zQsen, zQlw + INTEGER :: ji, jj ! dummy loop indices + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + + zdt = pTa(ji,jj) - pTs(ji,jj) ; zdt = SIGN( MAX(ABS(zdt),1.E-6_wp), zdt ) + zdq = pqa(ji,jj) - pqs(ji,jj) ; zdq = SIGN( MAX(ABS(zdq),1.E-9_wp), zdq ) + zz0 = pust(ji,jj)/pUb(ji,jj) + zCd = zz0*zz0 + zCh = zz0*ptst(ji,jj)/zdt + zCe = zz0*pqst(ji,jj)/zdq + + CALL bulk_formula( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), zCd, zCh, zCe, & + & pwnd(ji,jj), pUb(ji,jj), ppa(ji,jj), prhoa(ji,jj), & + & pTau(ji,jj), zQsen, zQlat ) + + zQlw = qlw_net_sclr( prlw(ji,jj), pTs(ji,jj) ) ! Net longwave flux + + pQns(ji,jj) = zQlat + zQsen + zQlw + + IF( PRESENT(Qlat) ) Qlat(ji,jj) = zQlat + + END DO ; END DO + + END SUBROUTINE UPDATE_QNSOL_TAU + + + SUBROUTINE bulk_formula_sclr( pzu, pTs, pqs, pTa, pqa, & + & pCd, pCh, pCe, & + & pwnd, pUb, ppa, prhoa, & + & pTau, pQsen, pQlat, & + & pEvap, pfact_evap ) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), INTENT(in) :: pCd + REAL(wp), INTENT(in) :: pCh + REAL(wp), INTENT(in) :: pCe + REAL(wp), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3] + !! + REAL(wp), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + REAL(wp), INTENT(out) :: pQsen ! [W/m^2] + REAL(wp), INTENT(out) :: pQlat ! [W/m^2] + !! + REAL(wp), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] + REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) + !! + REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap + INTEGER :: jq + !!---------------------------------------------------------------------------------- + zfact_evap = 1._wp + IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap + + zUrho = pUb*MAX(prhoa, 1._wp) ! rho*U10 + + pTau = zUrho * pCd * pwnd ! Wind stress module + + zevap = zUrho * pCe * (pqa - pqs) + pQsen = zUrho * pCh * (pTa - pTs) * cp_air(pqa) + pQlat = L_vap(pTs) * zevap + + IF( PRESENT(pEvap) ) pEvap = - zfact_evap * zevap + + END SUBROUTINE bulk_formula_sclr + + SUBROUTINE bulk_formula_vctr( pzu, pTs, pqs, pTa, pqa, & + & pCd, pCh, pCe, & + & pwnd, pUb, ppa, prhoa, & + & pTau, pQsen, pQlat, & + & pEvap, pfact_evap ) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCh + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCe + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3] + !! + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQsen ! [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQlat ! [W/m^2] + !! + REAL(wp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] + REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) + !! + REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + zfact_evap = 1._wp + IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + + CALL bulk_formula_sclr( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & + & pCd(ji,jj), pCh(ji,jj), pCe(ji,jj), & + & pwnd(ji,jj), pUb(ji,jj), ppa(ji,jj), prhoa(ji,jj), & + & pTau(ji,jj), pQsen(ji,jj), pQlat(ji,jj), & + & pEvap=zevap, pfact_evap=zfact_evap ) + + IF( PRESENT(pEvap) ) pEvap(ji,jj) = zevap + END DO ; END DO + + END SUBROUTINE bulk_formula_vctr + + + FUNCTION alpha_sw_vctr( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION alpha_sw_vctr *** + !! + !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (P =~ 1010 hpa) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: alpha_sw_vctr ! thermal expansion coefficient of sea-water [1/K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K] + !!---------------------------------------------------------------------------------- + alpha_sw_vctr = 2.1e-5_wp * MAX(psst(:,:)-rt0 + 3.2_wp, 0._wp)**0.79 + + END FUNCTION alpha_sw_vctr + + FUNCTION alpha_sw_sclr( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION alpha_sw_sclr *** + !! + !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (P =~ 1010 hpa) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: alpha_sw_sclr ! thermal expansion coefficient of sea-water [1/K] + REAL(wp), INTENT(in) :: psst ! sea-water temperature [K] + !!---------------------------------------------------------------------------------- + alpha_sw_sclr = 2.1e-5_wp * MAX(psst-rt0 + 3.2_wp, 0._wp)**0.79 + + END FUNCTION alpha_sw_sclr + + + FUNCTION qlw_net_sclr( pdwlw, pts, l_ice ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION qlw_net_sclr *** + !! + !! ** Purpose : Estimate of the net longwave flux at the surface + !!---------------------------------------------------------------------------------- + REAL(wp) :: qlw_net_sclr + REAL(wp), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] + REAL(wp), INTENT(in) :: pts !: surface temperature [K] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + REAL(wp) :: zemiss, zt2 + LOGICAL :: lice + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + IF( lice ) THEN + zemiss = emiss_i + ELSE + zemiss = emiss_w + END IF + zt2 = pts*pts + qlw_net_sclr = zemiss*( pdwlw - stefan*zt2*zt2) ! zemiss used both as the IR albedo and IR emissivity... + + END FUNCTION qlw_net_sclr + + FUNCTION qlw_net_vctr( pdwlw, pts, l_ice ) + + REAL(wp), DIMENSION(jpi,jpj) :: qlw_net_vctr + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts !: surface temperature [K] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + LOGICAL :: lice + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + qlw_net_vctr(ji,jj) = qlw_net_sclr( pdwlw(ji,jj) , pts(ji,jj), l_ice=lice ) + END DO ; END DO + + END FUNCTION qlw_net_vctr + + + FUNCTION z0_from_Cd( pzu, pCd, ppsi ) + + REAL(wp), DIMENSION(jpi,jpj) :: z0_from_Cd !: roughness length [m] + REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: (neutral or non-neutral) drag coefficient [] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !! + !! If pCd is the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given + !! If pCd is the drag coefficient (in stable or unstable conditions) then pssi must be provided + !!---------------------------------------------------------------------------------- + IF( PRESENT(ppsi) ) THEN + !! Cd provided is the actual Cd (not the neutral-stability CdN) : + z0_from_Cd = pzu * EXP( - ( vkarmn/SQRT(pCd(:,:)) + ppsi(:,:) ) ) !LB: ok, double-checked! + ELSE + !! Cd provided is the neutral-stability Cd, aka CdN : + z0_from_Cd = pzu * EXP( - vkarmn/SQRT(pCd(:,:)) ) !LB: ok, double-checked! + END IF + + END FUNCTION z0_from_Cd + + + FUNCTION Cd_from_z0( pzu, pz0, ppsi ) + + REAL(wp), DIMENSION(jpi,jpj) :: Cd_from_z0 !: (neutral or non-neutral) drag coefficient [] + REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !! + !! If we want to return the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given + !! If we want to return the stability-corrected Cd (i.e. in stable or unstable conditions) then pssi must be provided + !!---------------------------------------------------------------------------------- + IF( PRESENT(ppsi) ) THEN + !! The Cd we return is the actual Cd (not the neutral-stability CdN) : + Cd_from_z0 = 1._wp / ( LOG( pzu / pz0(:,:) ) - ppsi(:,:) ) + ELSE + !! The Cd we return is the neutral-stability Cd, aka CdN : + Cd_from_z0 = 1._wp / LOG( pzu / pz0(:,:) ) + END IF + Cd_from_z0 = vkarmn2 * Cd_from_z0 * Cd_from_z0 + + END FUNCTION Cd_from_z0 + + + FUNCTION f_m_louis_sclr( pzu, pRib, pCdn, pz0 ) + !!---------------------------------------------------------------------------------- + !! Stability correction function for MOMENTUM + !! Louis (1979) + !!---------------------------------------------------------------------------------- + REAL(wp) :: f_m_louis_sclr ! term "f_m" in Eq.(6) when option "Louis" rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), + REAL(wp), INTENT(in) :: pzu ! reference height (height for pwnd) [m] + REAL(wp), INTENT(in) :: pRib ! Bulk Richardson number + REAL(wp), INTENT(in) :: pCdn ! neutral drag coefficient + REAL(wp), INTENT(in) :: pz0 ! roughness length [m] + !!---------------------------------------------------------------------------------- + REAL(wp) :: ztu, zts, zstab + !!---------------------------------------------------------------------------------- + zstab = 0.5 + SIGN(0.5_wp, pRib) ; ! Unstable (Ri<0) => zstab = 0 | Stable (Ri>0) => zstab = 1 + ! + ztu = pRib / ( 1._wp + 3._wp * rc2_louis * pCdn * SQRT( ABS( -pRib * ( pzu / pz0 + 1._wp) ) ) ) ! ABS is just here for when it's stable conditions and ztu is not used anyways + zts = pRib / SQRT( ABS( 1._wp + pRib ) ) ! ABS is just here for when it's UNstable conditions and zts is not used anyways + ! + f_m_louis_sclr = (1._wp - zstab) * ( 1._wp - ram_louis * ztu ) & ! Unstable Eq.(A6) + & + zstab * 1._wp / ( 1._wp + ram_louis * zts ) ! Stable Eq.(A7) + ! + END FUNCTION f_m_louis_sclr + + FUNCTION f_m_louis_vctr( pzu, pRib, pCdn, pz0 ) + + REAL(wp), DIMENSION(jpi,jpj) :: f_m_louis_vctr + REAL(wp), INTENT(in) :: pzu + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCdn + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 + INTEGER :: ji, jj + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + f_m_louis_vctr(ji,jj) = f_m_louis_sclr( pzu, pRib(ji,jj), pCdn(ji,jj), pz0(ji,jj) ) + END DO ; END DO + + END FUNCTION f_m_louis_vctr + + + FUNCTION f_h_louis_sclr( pzu, pRib, pChn, pz0 ) + !!---------------------------------------------------------------------------------- + !! Stability correction function for HEAT + !! Louis (1979) + !!---------------------------------------------------------------------------------- + REAL(wp) :: f_h_louis_sclr ! term "f_h" in Eq.(6) when option "Louis" rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), + REAL(wp), INTENT(in) :: pzu ! reference height (height for pwnd) [m] + REAL(wp), INTENT(in) :: pRib ! Bulk Richardson number + REAL(wp), INTENT(in) :: pChn ! neutral heat transfer coefficient + REAL(wp), INTENT(in) :: pz0 ! roughness length [m] + !!---------------------------------------------------------------------------------- + REAL(wp) :: ztu, zts, zstab + !!---------------------------------------------------------------------------------- + zstab = 0.5 + SIGN(0.5_wp, pRib) ; ! Unstable (Ri<0) => zstab = 0 | Stable (Ri>0) => zstab = 1 + ! + ztu = pRib / ( 1._wp + 3._wp * rc2_louis * pChn * SQRT( ABS(-pRib * ( pzu / pz0 + 1._wp) ) ) ) + zts = pRib / SQRT( ABS( 1._wp + pRib ) ) + ! + f_h_louis_sclr = (1._wp - zstab) * ( 1._wp - rah_louis * ztu ) & ! Unstable Eq.(A6) + & + zstab * 1._wp / ( 1._wp + rah_louis * zts ) ! Stable Eq.(A7) !#LB: in paper it's "ram_louis" and not "rah_louis" typo or what???? + ! + END FUNCTION f_h_louis_sclr + + FUNCTION f_h_louis_vctr( pzu, pRib, pChn, pz0 ) + + REAL(wp), DIMENSION(jpi,jpj) :: f_h_louis_vctr + REAL(wp), INTENT(in) :: pzu + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pChn + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 + INTEGER :: ji, jj + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + f_h_louis_vctr(ji,jj) = f_h_louis_sclr( pzu, pRib(ji,jj), pChn(ji,jj), pz0(ji,jj) ) + END DO ; END DO + + END FUNCTION f_h_louis_vctr + + + FUNCTION UN10_from_ustar( pzu, pUzu, pus, ppsi ) + !!---------------------------------------------------------------------------------- + !! Provides the neutral-stability wind speed at 10 m + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_ustar !: neutral stability wind speed at 10m [m/s] + REAL(wp), INTENT(in) :: pzu !: measurement heigh of wind speed [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUzu !: bulk wind speed at height pzu m [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !!---------------------------------------------------------------------------------- + UN10_from_ustar(:,:) = pUzu(:,:) - pus(:,:)/vkarmn * ( LOG(pzu/10._wp) - ppsi(:,:) ) + !! + END FUNCTION UN10_from_ustar + + + FUNCTION UN10_from_CD( pzu, pUb, pCd, ppsi ) + !!---------------------------------------------------------------------------------- + !! Provides the neutral-stability wind speed at 10 m + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_CD !: [m/s] + REAL(wp), INTENT(in) :: pzu !: measurement heigh of bulk wind speed + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb !: bulk wind speed at height pzu m [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: drag coefficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !!---------------------------------------------------------------------------------- + !! Reminder: UN10 = u*/vkarmn * log(10/z0) + !! and: u* = sqrt(Cd) * Ub + !! u*/vkarmn * log( 10 / z0 ) + UN10_from_CD(:,:) = SQRT(pCd(:,:))*pUb/vkarmn * LOG( 10._wp / z0_from_Cd( pzu, pCd(:,:), ppsi=ppsi(:,:) ) ) + !! + END FUNCTION UN10_from_CD + + + FUNCTION z0tq_LKB( iflag, pRer, pz0 ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION z0tq_LKB *** + !! + !! ** Purpose : returns the "temperature/humidity roughness lengths" + !! * iflag==1 => temperature => returns: z_{0t} + !! * iflag==2 => humidity => returns: z_{0q} + !! from roughness reynold number "pRer" (i.e. [z_0 u*]/Nu_{air}) + !! between 0 and 1000. Out of range "pRer" indicated by prt=-999. + !! and roughness length (for momentum) + !! + !! Based on Liu et al. (1979) JAS 36 1722-1723s + !! + !! Note: this is what is used into COARE 2.5 to estimate z_{0t} and z_{0q} + !! + !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: z0tq_LKB + INTEGER, INTENT(in) :: iflag !: 1 => dealing with temperature; 2 => dealing with humidity + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRer !: roughness Reynolds number [z_0 u*]/Nu_{air} + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length (for momentum) [m] + !------------------------------------------------------------------- + ! Scalar Re_r relation from Liu et al. + REAL(wp), DIMENSION(8,2), PARAMETER :: & + & XA = RESHAPE( (/ 0.177, 1.376, 1.026, 1.625, 4.661, 34.904, 1667.19, 5.88e5, & + & 0.292, 1.808, 1.393, 1.956, 4.994, 30.709, 1448.68, 2.98e5 /), (/8,2/) ) + !! + REAL(wp), DIMENSION(8,2), PARAMETER :: & + & XB = RESHAPE( (/ 0., 0.929, -0.599, -1.018, -1.475, -2.067, -2.907, -3.935, & + & 0., 0.826, -0.528, -0.870, -1.297, -1.845, -2.682, -3.616 /), (/8,2/) ) + !! + REAL(wp), DIMENSION(0:8), PARAMETER :: & + & XRAN = (/ 0., 0.11, 0.825, 3.0, 10.0, 30.0, 100., 300., 1000. /) + !------------------------------------------------------------------- + ! + !------------------------------------------------------------------- + ! Scalar Re_r relation from Moana Wave data. + ! + ! real*8 A(9,2),B(9,2),RAN(9),pRer,prt + ! integer iflag + ! DATA A/0.177,2.7e3,1.03,1.026,1.625,4.661,34.904,1667.19,5.88E5, + ! & 0.292,3.7e3,1.4,1.393,1.956,4.994,30.709,1448.68,2.98E5/ + ! DATA B/0.,4.28,0,-0.599,-1.018,-1.475,-2.067,-2.907,-3.935, + ! & 0.,4.28,0,-0.528,-0.870,-1.297,-1.845,-2.682,-3.616/ + ! DATA RAN/0.11,.16,1.00,3.0,10.0,30.0,100.,300.,1000./ + !------------------------------------------------------------------- + + LOGICAL :: lfound=.FALSE. + REAL(wp) :: zrr + INTEGER :: ji, jj, jm + + z0tq_LKB(:,:) = -999._wp + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + + zrr = pRer(ji,jj) + lfound = .FALSE. + + IF( (zrr > 0.).AND.(zrr < 1000.) ) THEN + jm = 0 + DO WHILE ( .NOT. lfound ) + jm = jm + 1 + lfound = ( (zrr > XRAN(jm-1)) .AND. (zrr <= XRAN(jm)) ) + END DO + + z0tq_LKB(ji,jj) = XA(jm,iflag)*zrr**XB(jm,iflag) * pz0(ji,jj)/zrr + + END IF + + END DO ; END DO + + z0tq_LKB(:,:) = MIN( MAX(ABS(z0tq_LKB(:,:)), 1.E-9) , 0.05_wp ) + + END FUNCTION z0tq_LKB + + + +END MODULE sbc_phy diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcabl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcabl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..08175466e13078b9b1200178bf7e6673241279fe --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcabl.f90 @@ -0,0 +1,64 @@ + + + + + + + + + + + + + +MODULE sbcabl + !!====================================================================== + !! *** MODULE sbcabl *** + !! Ocean forcing: momentum, heat and freshwater flux formulation + !! derived from an ABL model + !!===================================================================== + !! History : 4.0 ! 2019-03 (F. Lemarié & G. Samson) Original code + !!---------------------------------------------------------------------- + USE sbc_oce, ONLY : ght_abl, ghw_abl, e3t_abl, e3w_abl + USE lib_mpp, ONLY : ctl_stop + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_abl_init ! routine called in sbcmod module + PUBLIC sbc_abl ! routine called in sbcmod module + + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO-consortium (2014) + !! $Id: sbcabl.F90 6416 2016-04-01 12:22:17Z clem $ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_abl_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_abl_init *** + !! + !! ** Purposes : dummy routine for compilation + !! + !!---------------------------------------------------------------------- + CALL ctl_stop( 'STOP', 'ln_abl = .true. but ABL source directory was not included', & + & '(Either switch to ln_abl = .false. or modify your cfg.txt file and recompile)' ) + !! + END SUBROUTINE sbc_abl_init + + + SUBROUTINE sbc_abl( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_abl *** + !! + !! ** Purposes : dummy routine for compilation + !! + !!--------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time step + !! + END SUBROUTINE sbc_abl + + + !!====================================================================== +END MODULE sbcabl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcapr.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcapr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..08d393430fc38b1989432254fcd9d41ff68e13f7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcapr.f90 @@ -0,0 +1,184 @@ + + + + + + + + + + + + + +MODULE sbcapr + !!====================================================================== + !! *** MODULE sbcapr *** + !! Surface module : atmospheric pressure forcing + !!====================================================================== + !! History : 3.3 ! 2010-09 (J. Chanut, C. Bricaud, G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_apr : read atmospheric pressure in netcdf files + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition + USE phycst ! physical constants + ! + USE fldread ! read input fields + USE in_out_manager ! I/O manager + USE lib_fortran ! distribued memory computing library + USE iom ! IOM library + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_apr ! routine called in sbcmod + PUBLIC sbc_apr_init ! routine called in sbcmod + + ! !!* namsbc_apr namelist (Atmospheric PRessure) * + LOGICAL, PUBLIC :: ln_apr_obc = .false. !: inverse barometer added to OBC ssh data + LOGICAL, PUBLIC :: ln_ref_apr !: ref. pressure: global mean Patm (F) or a constant (F) + REAL(wp) :: rn_pref ! reference atmospheric pressure [N/m2] + + REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: ssh_ib ! Inverse barometer now sea surface height [m] + REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: ssh_ibb ! Inverse barometer before sea surface height [m] + REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: apr ! atmospheric pressure at kt [N/m2] + + REAL(wp) :: tarea ! whole domain mean masked ocean surface + REAL(wp) :: r1_grau ! = 1.e0 / (grav * rho0) + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_apr ! structure of input fields (file informations, fields read) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcapr.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_apr_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_apr *** + !! + !! ** Purpose : read atmospheric pressure fields in netcdf files. + !! + !! ** Method : - Read namelist namsbc_apr + !! - Read Patm fields in netcdf files + !! - Compute reference atmospheric pressure + !! - Compute inverse barometer ssh + !! ** action : apr : atmospheric pressure at kt + !! ssh_ib : inverse barometer ssh at kt + !!--------------------------------------------------------------------- + INTEGER :: ierror ! local integer + INTEGER :: ios ! Local integer output status for namelist read + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N) :: sn_apr ! informations about the fields to be read + !! + NAMELIST/namsbc_apr/ cn_dir, sn_apr, ln_ref_apr, rn_pref, ln_apr_obc + !!---------------------------------------------------------------------- + READ ( numnam_ref, namsbc_apr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_apr in reference namelist' ) + + READ ( numnam_cfg, namsbc_apr, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_apr in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_apr ) + ! + ALLOCATE( sf_apr(1), STAT=ierror ) !* allocate and fill sf_sst (forcing structure) with sn_sst + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_apr: unable to allocate sf_apr structure' ) + ! + CALL fld_fill( sf_apr, (/ sn_apr /), cn_dir, 'sbc_apr', 'Atmospheric pressure ', 'namsbc_apr' ) + ALLOCATE( sf_apr(1)%fnow(jpi,jpj,1) ) + IF( sn_apr%ln_tint ) ALLOCATE( sf_apr(1)%fdta(jpi,jpj,1,2) ) + ALLOCATE( ssh_ib(jpi,jpj) , ssh_ibb(jpi,jpj) ) + ALLOCATE( apr (jpi,jpj) ) + ! + IF( lwp )THEN !* control print + WRITE(numout,*) + WRITE(numout,*) ' Namelist namsbc_apr : Atmospheric PRessure as extrenal forcing' + WRITE(numout,*) ' ref. pressure: global mean Patm (T) or a constant (F) ln_ref_apr = ', ln_ref_apr + ENDIF + ! + IF( ln_ref_apr ) THEN !* Compute whole inner domain mean masked ocean surface + tarea = glob_sum( 'sbcapr', e1e2t(:,:) ) + IF(lwp) WRITE(numout,*) ' Variable ref. Patm computed over a ocean surface of ', tarea*1e-6, 'km2' + ELSE + IF(lwp) WRITE(numout,*) ' Reference Patm used : ', rn_pref, ' N/m2' + ENDIF + ! + r1_grau = 1.e0 / (grav * rho0) !* constant for optimization + ! + ! !* control check + IF( ln_apr_obc ) THEN + IF(lwp) WRITE(numout,*) ' Inverse barometer added to OBC ssh data' + ENDIF +!jc: stop below should rather be a warning + IF( ln_apr_obc .AND. .NOT.ln_apr_dyn ) & + CALL ctl_warn( 'sbc_apr: use inverse barometer ssh at open boundary ONLY requires ln_apr_dyn=T' ) + ! + END SUBROUTINE sbc_apr_init + + SUBROUTINE sbc_apr( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_apr *** + !! + !! ** Purpose : read atmospheric pressure fields in netcdf files. + !! + !! ** Method : - Read namelist namsbc_apr + !! - Read Patm fields in netcdf files + !! - Compute reference atmospheric pressure + !! - Compute inverse barometer ssh + !! ** action : apr : atmospheric pressure at kt + !! ssh_ib : inverse barometer ssh at kt + !!--------------------------------------------------------------------- + INTEGER, INTENT(in):: kt ! ocean time step + ! + !!---------------------------------------------------------------------- + + ! ! ========================== ! + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! At each sbc time-step ! + ! ! ===========+++============ ! + ! + IF( kt /= nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) !* Swap of ssh_ib fields + ! + CALL fld_read( kt, nn_fsbc, sf_apr ) !* input Patm provided at kt + nn_fsbc/2 + ! + ! !* update the reference atmospheric pressure (if necessary) + IF( ln_ref_apr ) rn_pref = glob_sum( 'sbcapr', sf_apr(1)%fnow(:,:,1) * e1e2t(:,:) ) / tarea + ! + ! !* Patm related forcing at kt + ssh_ib(:,:) = - ( sf_apr(1)%fnow(:,:,1) - rn_pref ) * r1_grau ! equivalent ssh (inverse barometer) + apr (:,:) = sf_apr(1)%fnow(:,:,1) ! atmospheric pressure + ! + CALL iom_put( "ssh_ib", ssh_ib ) !* output the inverse barometer ssh + ENDIF + + ! ! ---------------------------------------- ! + IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! + ! ! ---------------------------------------- ! + ! !* Restart: read in restart file + IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN + IF(lwp) WRITE(numout,*) 'sbc_apr: ssh_ibb read in the restart file' + CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb ) ! before inv. barometer ssh + ! + ELSE !* no restart: set from nit000 values + IF(lwp) WRITE(numout,*) 'sbc_apr: ssh_ibb set to nit000 values' + ssh_ibb(:,:) = ssh_ib(:,:) + ENDIF + ENDIF + ! ! ---------------------------------------- ! + IF( lrst_oce ) THEN ! Write in the ocean restart file ! + ! ! ---------------------------------------- ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_apr : ssh_ib written in ocean restart file at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + CALL iom_rstput( kt, nitrst, numrow, 'ssh_ibb' , ssh_ib ) + ENDIF + ! + END SUBROUTINE sbc_apr + + !!====================================================================== +END MODULE sbcapr diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk.f90 new file mode 100644 index 0000000000000000000000000000000000000000..62742f5637aa499c457e0902c0d621a08956d6fc --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk.f90 @@ -0,0 +1,869 @@ + + + + + + + + + + + + + +MODULE sbcblk + !!====================================================================== + !! *** MODULE sbcblk *** + !! Ocean forcing: momentum, heat and freshwater flux formulation + !! Aerodynamic Bulk Formulas + !! SUCCESSOR OF "sbcblk_core" + !!===================================================================== + !! History : 1.0 ! 2004-08 (U. Schweckendiek) Original CORE code + !! 2.0 ! 2005-04 (L. Brodeau, A.M. Treguier) improved CORE bulk and its user interface + !! 3.0 ! 2006-06 (G. Madec) sbc rewritting + !! - ! 2006-12 (L. Brodeau) Original code for turb_core + !! 3.2 ! 2009-04 (B. Lemaire) Introduce iom_put + !! 3.3 ! 2010-10 (S. Masson) add diurnal cycle + !! 3.4 ! 2011-11 (C. Harris) Fill arrays required by CICE + !! 3.7 ! 2014-06 (L. Brodeau) simplification and optimization of CORE bulk + !! 4.0 ! 2016-06 (L. Brodeau) sbcblk_core becomes sbcblk and is not restricted to the CORE algorithm anymore + !! ! ==> based on AeroBulk (https://github.com/brodeau/aerobulk/) + !! 4.0 ! 2016-10 (G. Madec) introduce a sbc_blk_init routine + !! 4.0 ! 2016-10 (M. Vancoppenolle) Introduce conduction flux emulator (M. Vancoppenolle) + !! 4.0 ! 2019-03 (F. Lemarié & G. Samson) add ABL compatibility (ln_abl=TRUE) + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_blk_init : initialisation of the chosen bulk formulation as ocean surface boundary condition + !! sbc_blk : bulk formulation as ocean surface boundary condition + !! blk_oce_1 : computes pieces of momentum, heat and freshwater fluxes over ocean for ABL model (ln_abl=TRUE) + !! blk_oce_2 : finalizes momentum, heat and freshwater fluxes computation over ocean after the ABL step (ln_abl=TRUE) + !! sea-ice case only : + !! blk_ice_1 : provide the air-ice stress + !! blk_ice_2 : provide the heat and mass fluxes at air-ice interface + !! blk_ice_qcn : provide ice surface temperature and snow/ice conduction flux (emulating conduction flux) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE fldread ! read input fields + USE sbc_oce ! Surface boundary condition: ocean fields + USE trc_oce ! share SMS/Ocean variables + USE cyclone ! Cyclone 10m wind form trac of cyclone centres + USE sbcdcy ! surface boundary condition: diurnal cycle + USE sbcwave , ONLY : cdn_wave ! wave module + USE lib_fortran ! to use key_nosignedzero and glob_sum + ! + USE sbcblk_algo_ncar ! => turb_ncar : NCAR - (formerly known as CORE, Large & Yeager, 2009) + USE sbcblk_algo_coare3p0 ! => turb_coare3p0 : COAREv3.0 (Fairall et al. 2003) + USE sbcblk_algo_coare3p6 ! => turb_coare3p6 : COAREv3.6 (Fairall et al. 2018 + Edson et al. 2013) + USE sbcblk_algo_ecmwf ! => turb_ecmwf : ECMWF (IFS cycle 45r1) + USE sbcblk_algo_andreas ! => turb_andreas : Andreas et al. 2015 + ! + USE iom ! I/O manager library + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_blk_init ! called in sbcmod + PUBLIC sbc_blk ! called in sbcmod + PUBLIC blk_oce_1 ! called in sbcabl + PUBLIC blk_oce_2 ! called in sbcabl + + INTEGER , PUBLIC, PARAMETER :: jp_wndi = 1 ! index of 10m wind velocity (i-component) (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jp_wndj = 2 ! index of 10m wind velocity (j-component) (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jp_tair = 3 ! index of 10m air temperature (Kelvin) + INTEGER , PUBLIC, PARAMETER :: jp_humi = 4 ! index of specific humidity (kg/kg) + INTEGER , PUBLIC, PARAMETER :: jp_qsr = 5 ! index of solar heat (W/m2) + INTEGER , PUBLIC, PARAMETER :: jp_qlw = 6 ! index of Long wave (W/m2) + INTEGER , PUBLIC, PARAMETER :: jp_prec = 7 ! index of total precipitation (rain+snow) (Kg/m2/s) + INTEGER , PUBLIC, PARAMETER :: jp_snow = 8 ! index of snow (solid prcipitation) (kg/m2/s) + INTEGER , PUBLIC, PARAMETER :: jp_slp = 9 ! index of sea level pressure (Pa) + INTEGER , PUBLIC, PARAMETER :: jp_uoatm = 10 ! index of surface current (i-component) + ! ! seen by the atmospheric forcing (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jp_voatm = 11 ! index of surface current (j-component) + ! ! seen by the atmospheric forcing (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jp_cc = 12 ! index of cloud cover (-) range:0-1 + INTEGER , PUBLIC, PARAMETER :: jp_hpgi = 13 ! index of ABL geostrophic wind or hpg (i-component) (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jp_hpgj = 14 ! index of ABL geostrophic wind or hpg (j-component) (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jpfld = 14 ! maximum number of files to read + + ! Warning: keep this structure allocatable for Agrif... + TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) :: sf ! structure of input atmospheric fields (file informations, fields read) + + ! !!* Namelist namsbc_blk : bulk parameters + LOGICAL :: ln_NCAR ! "NCAR" algorithm (Large and Yeager 2008) + LOGICAL :: ln_COARE_3p0 ! "COARE 3.0" algorithm (Fairall et al. 2003) + LOGICAL :: ln_COARE_3p6 ! "COARE 3.6" algorithm (Edson et al. 2013) + LOGICAL :: ln_ECMWF ! "ECMWF" algorithm (IFS cycle 45r1) + LOGICAL :: ln_ANDREAS ! "ANDREAS" algorithm (Andreas et al. 2015) + ! + !#LB: + LOGICAL :: ln_Cx_ice_cst ! use constant air-ice bulk transfer coefficients (value given in namelist's rn_Cd_i, rn_Ce_i & rn_Ch_i) + REAL(wp) :: rn_Cd_i, rn_Ce_i, rn_Ch_i ! values for " " + LOGICAL :: ln_Cx_ice_AN05 ! air-ice bulk transfer coefficients based on Andreas et al., 2005 + LOGICAL :: ln_Cx_ice_LU12 ! air-ice bulk transfer coefficients based on Lupkes et al., 2012 + LOGICAL :: ln_Cx_ice_LG15 ! air-ice bulk transfer coefficients based on Lupkes & Gryanik, 2015 + !#LB. + ! + LOGICAL :: ln_crt_fbk ! Add surface current feedback to the wind stress computation (Renault et al. 2020) + REAL(wp) :: rn_stau_a ! Alpha and Beta coefficients of Renault et al. 2020, eq. 10: Stau = Alpha * Wnd + Beta + REAL(wp) :: rn_stau_b ! + ! + REAL(wp) :: rn_pfac ! multiplication factor for precipitation + REAL(wp), PUBLIC :: rn_efac ! multiplication factor for evaporation + REAL(wp) :: rn_zqt ! z(q,t) : height of humidity and temperature measurements + REAL(wp) :: rn_zu ! z(u) : height of wind measurements + ! + INTEGER :: nn_iter_algo ! Number of iterations in bulk param. algo ("stable ABL + weak wind" requires more) + + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: theta_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme) + + + + LOGICAL :: ln_skin_cs ! use the cool-skin (only available in ECMWF and COARE algorithms) !LB + LOGICAL :: ln_skin_wl ! use the warm-layer parameterization (only available in ECMWF and COARE algorithms) !LB + LOGICAL :: ln_humi_sph ! humidity read in files ("sn_humi") is specific humidity [kg/kg] if .true. !LB + LOGICAL :: ln_humi_dpt ! humidity read in files ("sn_humi") is dew-point temperature [K] if .true. !LB + LOGICAL :: ln_humi_rlh ! humidity read in files ("sn_humi") is relative humidity [%] if .true. !LB + LOGICAL :: ln_tair_pot ! temperature read in files ("sn_tair") is already potential temperature (not absolute) + ! + INTEGER :: nhumi ! choice of the bulk algorithm + ! ! associated indices: + INTEGER, PARAMETER :: np_humi_sph = 1 + INTEGER, PARAMETER :: np_humi_dpt = 2 + INTEGER, PARAMETER :: np_humi_rlh = 3 + + INTEGER :: nblk ! choice of the bulk algorithm + ! ! associated indices: + INTEGER, PARAMETER :: np_NCAR = 1 ! "NCAR" algorithm (Large and Yeager 2008) + INTEGER, PARAMETER :: np_COARE_3p0 = 2 ! "COARE 3.0" algorithm (Fairall et al. 2003) + INTEGER, PARAMETER :: np_COARE_3p6 = 3 ! "COARE 3.6" algorithm (Edson et al. 2013) + INTEGER, PARAMETER :: np_ECMWF = 4 ! "ECMWF" algorithm (IFS cycle 45r1) + INTEGER, PARAMETER :: np_ANDREAS = 5 ! "ANDREAS" algorithm (Andreas et al. 2015) + + !#LB: + !LB. + + + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcblk.F90 15551 2021-11-28 20:19:36Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_blk_alloc() + !!------------------------------------------------------------------- + !! *** ROUTINE sbc_blk_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( theta_zu(jpi,jpj), q_zu(jpi,jpj), STAT=sbc_blk_alloc ) + CALL mpp_sum ( 'sbcblk', sbc_blk_alloc ) + IF( sbc_blk_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_alloc: failed to allocate arrays' ) + END FUNCTION sbc_blk_alloc + + + + SUBROUTINE sbc_blk_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_blk_init *** + !! + !! ** Purpose : choose and initialize a bulk formulae formulation + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER :: jfpr ! dummy loop indice and argument + INTEGER :: ios, ierror, ioptio ! Local integer + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of atmospheric forcing files + TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_wndi, sn_wndj , sn_humi, sn_qsr ! informations about the fields to be read + TYPE(FLD_N) :: sn_qlw , sn_tair , sn_prec, sn_snow ! " " + TYPE(FLD_N) :: sn_slp , sn_uoatm, sn_voatm ! " " + TYPE(FLD_N) :: sn_cc, sn_hpgi, sn_hpgj ! " " + INTEGER :: ipka ! number of levels in the atmospheric variable + NAMELIST/namsbc_blk/ ln_NCAR, ln_COARE_3p0, ln_COARE_3p6, ln_ECMWF, ln_ANDREAS, & ! bulk algorithm + & rn_zqt, rn_zu, nn_iter_algo, ln_skin_cs, ln_skin_wl, & + & rn_pfac, rn_efac, & + & ln_crt_fbk, rn_stau_a, rn_stau_b, & ! current feedback + & ln_humi_sph, ln_humi_dpt, ln_humi_rlh, ln_tair_pot, & + & ln_Cx_ice_cst, rn_Cd_i, rn_Ce_i, rn_Ch_i, & + & ln_Cx_ice_AN05, ln_Cx_ice_LU12, ln_Cx_ice_LG15, & + & cn_dir, & + & sn_wndi, sn_wndj, sn_qsr, sn_qlw , & ! input fields + & sn_tair, sn_humi, sn_prec, sn_snow, sn_slp, & + & sn_uoatm, sn_voatm, sn_cc, sn_hpgi, sn_hpgj + + ! cool-skin / warm-layer !LB + !!--------------------------------------------------------------------- + ! + ! ! allocate sbc_blk_core array + IF( sbc_blk_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk : unable to allocate standard arrays' ) + ! + ! + ! !** read bulk namelist + READ ( numnam_ref, namsbc_blk, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_blk in reference namelist' ) + ! + READ ( numnam_cfg, namsbc_blk, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_blk in configuration namelist' ) + ! + IF(lwm) WRITE( numond, namsbc_blk ) + ! + ! !** initialization of the chosen bulk formulae (+ check) + ! !* select the bulk chosen in the namelist and check the choice + ioptio = 0 + IF( ln_NCAR ) THEN + nblk = np_NCAR ; ioptio = ioptio + 1 + ENDIF + IF( ln_COARE_3p0 ) THEN + nblk = np_COARE_3p0 ; ioptio = ioptio + 1 + ENDIF + IF( ln_COARE_3p6 ) THEN + nblk = np_COARE_3p6 ; ioptio = ioptio + 1 + ENDIF + IF( ln_ECMWF ) THEN + nblk = np_ECMWF ; ioptio = ioptio + 1 + ENDIF + IF( ln_ANDREAS ) THEN + nblk = np_ANDREAS ; ioptio = ioptio + 1 + ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'sbc_blk_init: Choose one and only one bulk algorithm' ) + + ! !** initialization of the cool-skin / warm-layer parametrization + IF( ln_skin_cs .OR. ln_skin_wl ) THEN + !! Some namelist sanity tests: + IF( ln_NCAR ) & + & CALL ctl_stop( 'sbc_blk_init: Cool-skin/warm-layer param. not compatible with NCAR algorithm' ) + IF( ln_ANDREAS ) & + & CALL ctl_stop( 'sbc_blk_init: Cool-skin/warm-layer param. not compatible with ANDREAS algorithm' ) + !IF( nn_fsbc /= 1 ) & + ! & CALL ctl_stop( 'sbc_blk_init: Please set "nn_fsbc" to 1 when using cool-skin/warm-layer param.') + END IF + + IF( ln_skin_wl ) THEN + !! Check if the frequency of downwelling solar flux input makes sense and if ln_dm2dc=T if it is daily! + IF( (sn_qsr%freqh < 0.).OR.(sn_qsr%freqh > 24.) ) & + & CALL ctl_stop( 'sbc_blk_init: Warm-layer param. (ln_skin_wl) not compatible with freq. of solar flux > daily' ) + IF( (sn_qsr%freqh == 24.).AND.(.NOT. ln_dm2dc) ) & + & CALL ctl_stop( 'sbc_blk_init: Please set ln_dm2dc=T for warm-layer param. (ln_skin_wl) to work properly' ) + END IF + + ioptio = 0 + IF( ln_humi_sph ) THEN + nhumi = np_humi_sph ; ioptio = ioptio + 1 + ENDIF + IF( ln_humi_dpt ) THEN + nhumi = np_humi_dpt ; ioptio = ioptio + 1 + ENDIF + IF( ln_humi_rlh ) THEN + nhumi = np_humi_rlh ; ioptio = ioptio + 1 + ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'sbc_blk_init: Choose one and only one type of air humidity' ) + ! + IF( ln_dm2dc ) THEN !* check: diurnal cycle on Qsr + IF( sn_qsr%freqh /= 24. ) CALL ctl_stop( 'sbc_blk_init: ln_dm2dc=T only with daily short-wave input' ) + IF( sn_qsr%ln_tint ) THEN + CALL ctl_warn( 'sbc_blk_init: ln_dm2dc=T daily qsr time interpolation done by sbcdcy module', & + & ' ==> We force time interpolation = .false. for qsr' ) + sn_qsr%ln_tint = .false. + ENDIF + ENDIF + + + + ! !* set the bulk structure + ! !- store namelist information in an array + ! + slf_i(jp_wndi ) = sn_wndi ; slf_i(jp_wndj ) = sn_wndj + slf_i(jp_qsr ) = sn_qsr ; slf_i(jp_qlw ) = sn_qlw + slf_i(jp_tair ) = sn_tair ; slf_i(jp_humi ) = sn_humi + slf_i(jp_prec ) = sn_prec ; slf_i(jp_snow ) = sn_snow + slf_i(jp_slp ) = sn_slp ; slf_i(jp_cc ) = sn_cc + slf_i(jp_uoatm) = sn_uoatm ; slf_i(jp_voatm) = sn_voatm + slf_i(jp_hpgi ) = sn_hpgi ; slf_i(jp_hpgj ) = sn_hpgj + ! + IF( .NOT. ln_abl ) THEN ! force to not use jp_hpgi and jp_hpgj, should already be done in namelist_* but we never know... + slf_i(jp_hpgi)%clname = 'NOT USED' + slf_i(jp_hpgj)%clname = 'NOT USED' + ENDIF + ! + ! !- allocate the bulk structure + ALLOCATE( sf(jpfld), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_init: unable to allocate sf structure' ) + ! + ! !- fill the bulk structure with namelist informations + CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_init', 'surface boundary condition -- bulk formulae', 'namsbc_blk' ) + sf(jp_wndi )%zsgn = -1._wp ; sf(jp_wndj )%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn + sf(jp_uoatm)%zsgn = -1._wp ; sf(jp_voatm)%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn + sf(jp_hpgi )%zsgn = -1._wp ; sf(jp_hpgj )%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn + ! + DO jfpr= 1, jpfld + ! + IF( ln_abl .AND. & + & ( jfpr == jp_wndi .OR. jfpr == jp_wndj .OR. jfpr == jp_humi .OR. & + & jfpr == jp_hpgi .OR. jfpr == jp_hpgj .OR. jfpr == jp_tair ) ) THEN + ipka = jpka ! ABL: some fields are 3D input + ELSE + ipka = 1 + ENDIF + ! + ALLOCATE( sf(jfpr)%fnow(jpi,jpj,ipka) ) + ! + IF( TRIM(sf(jfpr)%clrootname) == 'NOT USED' ) THEN !-- not used field --! (only now allocated and set to default) + IF( jfpr == jp_slp ) THEN + sf(jfpr)%fnow(:,:,1:ipka) = 101325._wp ! use standard pressure in Pa + ELSEIF( jfpr == jp_prec .OR. jfpr == jp_snow .OR. jfpr == jp_uoatm .OR. jfpr == jp_voatm ) THEN + sf(jfpr)%fnow(:,:,1:ipka) = 0._wp ! no precip or no snow or no surface currents + ELSEIF( jfpr == jp_hpgi .OR. jfpr == jp_hpgj ) THEN + IF( .NOT. ln_abl ) THEN + DEALLOCATE( sf(jfpr)%fnow ) ! deallocate as not used in this case + ELSE + sf(jfpr)%fnow(:,:,1:ipka) = 0._wp + ENDIF + ELSEIF( jfpr == jp_cc ) THEN + sf(jp_cc)%fnow(:,:,1:ipka) = pp_cldf + ELSE + WRITE(ctmp1,*) 'sbc_blk_init: no default value defined for field number', jfpr + CALL ctl_stop( ctmp1 ) + ENDIF + ELSE !-- used field --! + IF( sf(jfpr)%ln_tint ) ALLOCATE( sf(jfpr)%fdta(jpi,jpj,ipka,2) ) ! allocate array for temporal interpolation + ! + IF( sf(jfpr)%freqh > 0. .AND. MOD( NINT(3600. * sf(jfpr)%freqh), nn_fsbc * NINT(rn_Dt) ) /= 0 ) & + & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rn_Dt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', & + & ' This is not ideal. You should consider changing either rn_Dt or nn_fsbc value...' ) + ENDIF + END DO + ! + IF( ln_abl ) THEN ! ABL: read 3D fields for wind, temperature, humidity and pressure gradient + rn_zqt = ght_abl(2) ! set the bulk altitude to ABL first level + rn_zu = ght_abl(2) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ABL formulation: overwrite rn_zqt & rn_zu with ABL first level altitude' + ENDIF + ! + ! + IF(lwp) THEN !** Control print + ! + WRITE(numout,*) !* namelist + WRITE(numout,*) ' Namelist namsbc_blk (other than data information):' + WRITE(numout,*) ' "NCAR" algorithm (Large and Yeager 2008) ln_NCAR = ', ln_NCAR + WRITE(numout,*) ' "COARE 3.0" algorithm (Fairall et al. 2003) ln_COARE_3p0 = ', ln_COARE_3p0 + WRITE(numout,*) ' "COARE 3.6" algorithm (Fairall 2018 + Edson al 2013) ln_COARE_3p6 = ', ln_COARE_3p6 + WRITE(numout,*) ' "ECMWF" algorithm (IFS cycle 45r1) ln_ECMWF = ', ln_ECMWF + WRITE(numout,*) ' "ANDREAS" algorithm (Andreas et al. 2015) ln_ANDREAS = ', ln_ANDREAS + WRITE(numout,*) ' Air temperature and humidity reference height (m) rn_zqt = ', rn_zqt + WRITE(numout,*) ' Wind vector reference height (m) rn_zu = ', rn_zu + WRITE(numout,*) ' factor applied on precipitation (total & snow) rn_pfac = ', rn_pfac + WRITE(numout,*) ' factor applied on evaporation rn_efac = ', rn_efac + WRITE(numout,*) ' (form absolute (=0) to relative winds(=1))' + WRITE(numout,*) ' use surface current feedback on wind stress ln_crt_fbk = ', ln_crt_fbk + IF(ln_crt_fbk) THEN + WRITE(numout,*) ' Renault et al. 2020, eq. 10: Stau = Alpha * Wnd + Beta' + WRITE(numout,*) ' Alpha rn_stau_a = ', rn_stau_a + WRITE(numout,*) ' Beta rn_stau_b = ', rn_stau_b + ENDIF + ! + WRITE(numout,*) + SELECT CASE( nblk ) !* Print the choice of bulk algorithm + CASE( np_NCAR ) ; WRITE(numout,*) ' ==>>> "NCAR" algorithm (Large and Yeager 2008)' + CASE( np_COARE_3p0 ) ; WRITE(numout,*) ' ==>>> "COARE 3.0" algorithm (Fairall et al. 2003)' + CASE( np_COARE_3p6 ) ; WRITE(numout,*) ' ==>>> "COARE 3.6" algorithm (Fairall 2018+Edson et al. 2013)' + CASE( np_ECMWF ) ; WRITE(numout,*) ' ==>>> "ECMWF" algorithm (IFS cycle 45r1)' + CASE( np_ANDREAS ) ; WRITE(numout,*) ' ==>>> "ANDREAS" algorithm (Andreas et al. 2015)' + END SELECT + ! + WRITE(numout,*) + WRITE(numout,*) ' use cool-skin parameterization (SSST) ln_skin_cs = ', ln_skin_cs + WRITE(numout,*) ' use warm-layer parameterization (SSST) ln_skin_wl = ', ln_skin_wl + ! + WRITE(numout,*) + SELECT CASE( nhumi ) !* Print the choice of air humidity + CASE( np_humi_sph ) ; WRITE(numout,*) ' ==>>> air humidity is SPECIFIC HUMIDITY [kg/kg]' + CASE( np_humi_dpt ) ; WRITE(numout,*) ' ==>>> air humidity is DEW-POINT TEMPERATURE [K]' + CASE( np_humi_rlh ) ; WRITE(numout,*) ' ==>>> air humidity is RELATIVE HUMIDITY [%]' + END SELECT + ! + !#LB: + !#LB. + ! + ENDIF + ! + END SUBROUTINE sbc_blk_init + + + SUBROUTINE sbc_blk( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_blk *** + !! + !! ** Purpose : provide at each time step the surface ocean fluxes + !! (momentum, heat, freshwater and runoff) + !! + !! ** Method : + !! (1) READ each fluxes in NetCDF files: + !! the wind velocity (i-component) at z=rn_zu (m/s) at T-point + !! the wind velocity (j-component) at z=rn_zu (m/s) at T-point + !! the specific humidity at z=rn_zqt (kg/kg) + !! the air temperature at z=rn_zqt (Kelvin) + !! the solar heat (W/m2) + !! the Long wave (W/m2) + !! the total precipitation (rain+snow) (Kg/m2/s) + !! the snow (solid precipitation) (kg/m2/s) + !! ABL dynamical forcing (i/j-components of either hpg or geostrophic winds) + !! (2) CALL blk_oce_1 and blk_oce_2 + !! + !! C A U T I O N : never mask the surface stress fields + !! the stress is assumed to be in the (i,j) mesh referential + !! + !! ** Action : defined at each time-step at the air-sea interface + !! - utau, vtau i- and j-component of the wind stress + !! - taum wind stress module at T-point + !! - wndm wind speed module at T-point over free ocean or leads in presence of sea-ice + !! - qns, qsr non-solar and solar heat fluxes + !! - emp upward mass flux (evapo. - precip.) + !! - sfx salt flux due to freezing/melting (non-zero only if ice is present) + !! + !! ** References : Large & Yeager, 2004 / Large & Yeager, 2008 + !! Brodeau et al. Ocean Modelling 2010 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, zlat, zevp, zpre, ztheta + REAL(wp) :: ztst + LOGICAL :: llerr + !!---------------------------------------------------------------------- + ! + CALL fld_read( kt, nn_fsbc, sf ) ! input fields provided at the current time-step + + ! Sanity/consistence test on humidity at first time step to detect potential screw-up: + IF( kt == nit000 ) THEN + ! mean humidity over ocean on proc + ztst = glob_sum( 'sbcblk', sf(jp_humi)%fnow(:,:,1) * e1e2t(:,:) * tmask(:,:,1) ) / glob_sum( 'sbcblk', e1e2t(:,:) * tmask(:,:,1) ) + llerr = .FALSE. + SELECT CASE( nhumi ) + CASE( np_humi_sph ) ! specific humidity => expect: 0. <= something < 0.065 [kg/kg] (0.061 is saturation at 45degC !!!) + IF( (ztst < 0._wp) .OR. (ztst > 0.065_wp) ) llerr = .TRUE. + CASE( np_humi_dpt ) ! dew-point temperature => expect: 110. <= something < 320. [K] + IF( (ztst < 110._wp) .OR. (ztst > 320._wp) ) llerr = .TRUE. + CASE( np_humi_rlh ) ! relative humidity => expect: 0. <= something < 100. [%] + IF( (ztst < 0._wp) .OR. (ztst > 100._wp) ) llerr = .TRUE. + END SELECT + IF(llerr) THEN + WRITE(ctmp1,'(" Error on mean humidity value: ",f10.5)') ztst + CALL ctl_stop( 'STOP', ctmp1, 'Something is wrong with air humidity!!!', & + & ' ==> check the unit in your input files' , & + & ' ==> check consistence of namelist choice: specific? relative? dew-point?', & + & ' ==> ln_humi_sph -> [kg/kg] | ln_humi_rlh -> [%] | ln_humi_dpt -> [K] !!!' ) + ENDIF + IF(lwp) THEN + WRITE(numout,*) '' + WRITE(numout,*) ' Global mean humidity at kt = nit000: ', ztst + WRITE(numout,*) ' === Sanity/consistence test on air humidity sucessfuly passed! ===' + WRITE(numout,*) '' + ENDIF + ENDIF !IF( kt == nit000 ) + ! ! compute the surface ocean fluxes using bulk formulea + IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN + + ! Specific humidity of air at z=rn_zqt + SELECT CASE( nhumi ) + CASE( np_humi_sph ) + q_air_zt(:,:) = sf(jp_humi )%fnow(:,:,1) ! what we read in file is already a spec. humidity! + CASE( np_humi_dpt ) + IF((kt==nit000).AND.lwp) WRITE(numout,*) ' *** sbc_blk() => computing q_air out of dew-point and P !' + q_air_zt(:,:) = q_sat( sf(jp_humi )%fnow(:,:,1), sf(jp_slp )%fnow(:,:,1) ) + CASE( np_humi_rlh ) + IF((kt==nit000).AND.lwp) WRITE(numout,*) ' *** sbc_blk() => computing q_air out of RH, t_air and slp !' !LBrm + q_air_zt(:,:) = q_air_rh( 0.01_wp*sf(jp_humi )%fnow(:,:,1), & + & sf(jp_tair )%fnow(:,:,1), sf(jp_slp )%fnow(:,:,1) ) !#LB: 0.01 => RH is % percent in file + END SELECT + + ! Potential temperature of air at z=rn_zqt (most reanalysis products provide absolute temp., not potential temp.) + IF( ln_tair_pot ) THEN + ! temperature read into file is already potential temperature, do nothing... + theta_air_zt(:,:) = sf(jp_tair )%fnow(:,:,1) + ELSE + ! temperature read into file is ABSOLUTE temperature (that's the case for ECMWF products for example...) + IF((kt==nit000).AND.lwp) WRITE(numout,*) ' *** sbc_blk() => air temperature converted from ABSOLUTE to POTENTIAL!' + zpre(:,:) = pres_temp( q_air_zt(:,:), sf(jp_slp)%fnow(:,:,1), rn_zu, pta=sf(jp_tair)%fnow(:,:,1) ) + theta_air_zt(:,:) = theta_exner( sf(jp_tair)%fnow(:,:,1), zpre(:,:) ) + ENDIF + ! + CALL blk_oce_1( kt, sf(jp_wndi )%fnow(:,:,1), sf(jp_wndj )%fnow(:,:,1), & ! <<= in + & theta_air_zt(:,:), q_air_zt(:,:), & ! <<= in + & sf(jp_slp )%fnow(:,:,1), sst_m, ssu_m, ssv_m, & ! <<= in + & sf(jp_uoatm)%fnow(:,:,1), sf(jp_voatm)%fnow(:,:,1), & ! <<= in + & sf(jp_qsr )%fnow(:,:,1), sf(jp_qlw )%fnow(:,:,1), & ! <<= in (wl/cs) + & tsk_m, zssq, zcd_du, zsen, zlat, zevp ) ! =>> out + + CALL blk_oce_2( theta_air_zt(:,:), & ! <<= in + & sf(jp_qlw )%fnow(:,:,1), sf(jp_prec )%fnow(:,:,1), & ! <<= in + & sf(jp_snow )%fnow(:,:,1), tsk_m, & ! <<= in + & zsen, zlat, zevp ) ! <=> in out + ENDIF + ! + + ! + END SUBROUTINE sbc_blk + + + SUBROUTINE blk_oce_1( kt, pwndi, pwndj, ptair, pqair, & ! inp + & pslp , pst , pu , pv, & ! inp + & puatm, pvatm, pdqsr , pdqlw , & ! inp + & ptsk , pssq , pcd_du, psen, plat, pevp ) ! out + !!--------------------------------------------------------------------- + !! *** ROUTINE blk_oce_1 *** + !! + !! ** Purpose : if ln_blk=T, computes surface momentum, heat and freshwater fluxes + !! if ln_abl=T, computes Cd x |U|, Ch x |U|, Ce x |U| for ABL integration + !! + !! ** Method : bulk formulae using atmospheric fields from : + !! if ln_blk=T, atmospheric fields read in sbc_read + !! if ln_abl=T, the ABL model at previous time-step + !! + !! ** Outputs : - pssq : surface humidity used to compute latent heat flux (kg/kg) + !! - pcd_du : Cd x |dU| at T-points (m/s) + !! - psen : sensible heat flux (W/m^2) + !! - plat : latent heat flux (W/m^2) + !! - pevp : evaporation (mm/s) #lolo + !!--------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! time step index + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndi ! atmospheric wind at T-point [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndj ! atmospheric wind at T-point [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pqair ! specific humidity at T-points [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: ptair ! potential temperature at T-points [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pslp ! sea-level pressure [Pa] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pst ! surface temperature [Celsius] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pu ! surface current at U-point (i-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pv ! surface current at V-point (j-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: puatm ! surface current seen by the atm at T-point (i-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pvatm ! surface current seen by the atm at T-point (j-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqsr ! downwelling solar (shortwave) radiation at surface [W/m^2] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] + REAL(wp), INTENT( out), DIMENSION(:,:) :: ptsk ! skin temp. (or SST if CS & WL not used) [Celsius] + REAL(wp), INTENT( out), DIMENSION(:,:) :: pssq ! specific humidity at pst [kg/kg] + REAL(wp), INTENT( out), DIMENSION(:,:) :: pcd_du + REAL(wp), INTENT( out), DIMENSION(:,:) :: psen + REAL(wp), INTENT( out), DIMENSION(:,:) :: plat + REAL(wp), INTENT( out), DIMENSION(:,:) :: pevp + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zztmp ! local variable + REAL(wp) :: zstmax, zstau + REAL(wp), DIMENSION(jpi,jpj) :: ztau_i, ztau_j ! wind stress components at T-point + REAL(wp), DIMENSION(jpi,jpj) :: zU_zu ! bulk wind speed at height zu [m/s] + REAL(wp), DIMENSION(jpi,jpj) :: zcd_oce ! momentum transfert coefficient over ocean + REAL(wp), DIMENSION(jpi,jpj) :: zch_oce ! sensible heat transfert coefficient over ocean + REAL(wp), DIMENSION(jpi,jpj) :: zce_oce ! latent heat transfert coefficient over ocean + REAL(wp), DIMENSION(jpi,jpj) :: zsspt ! potential sea-surface temperature [K] + REAL(wp), DIMENSION(jpi,jpj) :: zpre, ztabs ! air pressure [Pa] & absolute temperature [K] + REAL(wp), DIMENSION(jpi,jpj) :: zztmp1, zztmp2 + !!--------------------------------------------------------------------- + ! + ! local scalars ( place there for vector optimisation purposes) + ! ! Temporary conversion from Celcius to Kelvin (and set minimum value far above 0 K) + ptsk(:,:) = pst(:,:) + rt0 ! by default: skin temperature = "bulk SST" (will remain this way if NCAR algorithm used!) + + ! sea surface potential temperature [K] + zsspt(:,:) = theta_exner( ptsk(:,:), pslp(:,:) ) + + ! --- cloud cover --- ! + cloud_fra(:,:) = sf(jp_cc)%fnow(:,:,1) + + ! ----------------------------------------------------------------------------- ! + ! 0 Wind components and module at T-point relative to the moving ocean ! + ! ----------------------------------------------------------------------------- ! + + ! ... components ( U10m - U_oce ) at T-point (unmasked) + ! ... scalar wind module at T-point (not masked) + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + wndm(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) ) + END DO ; END DO + ! ----------------------------------------------------------------------------- ! + ! I Solar FLUX ! + ! ----------------------------------------------------------------------------- ! + + ! ocean albedo assumed to be constant + modify now Qsr to include the diurnal cycle ! Short Wave + zztmp = 1. - albo + IF( ln_dm2dc ) THEN + qsr(:,:) = zztmp * sbc_dcy( pdqsr(:,:) ) * tmask(:,:,1) + ELSE + qsr(:,:) = zztmp * pdqsr(:,:) * tmask(:,:,1) + ENDIF + + + ! ----------------------------------------------------------------------------- ! + ! II Turbulent FLUXES ! + ! ----------------------------------------------------------------------------- ! + + ! specific humidity at SST + pssq(:,:) = rdct_qsat_salt * q_sat( ptsk(:,:), pslp(:,:) ) + + IF( ln_skin_cs .OR. ln_skin_wl ) THEN + !! Backup "bulk SST" and associated spec. hum. + zztmp1(:,:) = zsspt(:,:) + zztmp2(:,:) = pssq(:,:) + ENDIF + + !! Time to call the user-selected bulk parameterization for + !! == transfer coefficients ==! Cd, Ch, Ce at T-point, and more... + SELECT CASE( nblk ) + + CASE( np_NCAR ) + CALL turb_ncar ( rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, & + & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu , & + & nb_iter=nn_iter_algo ) + ! + CASE( np_COARE_3p0 ) + CALL turb_coare3p0( kt, rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, & + & ln_skin_cs, ln_skin_wl, & + & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, & + & nb_iter=nn_iter_algo, & + & Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) ) + ! + CASE( np_COARE_3p6 ) + CALL turb_coare3p6( kt, rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, & + & ln_skin_cs, ln_skin_wl, & + & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, & + & nb_iter=nn_iter_algo, & + & Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) ) + ! + CASE( np_ECMWF ) + CALL turb_ecmwf ( kt, rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, & + & ln_skin_cs, ln_skin_wl, & + & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, & + & nb_iter=nn_iter_algo, & + & Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) ) + ! + CASE( np_ANDREAS ) + CALL turb_andreas ( rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, & + & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu , & + & nb_iter=nn_iter_algo ) + ! + CASE DEFAULT + CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk parameterizaton selected' ) + ! + END SELECT + + IF( iom_use('Cd_oce') ) CALL iom_put("Cd_oce", zcd_oce * tmask(:,:,1)) + IF( iom_use('Ce_oce') ) CALL iom_put("Ce_oce", zce_oce * tmask(:,:,1)) + IF( iom_use('Ch_oce') ) CALL iom_put("Ch_oce", zch_oce * tmask(:,:,1)) + !! LB: mainly here for debugging purpose: + IF( iom_use('theta_zt') ) CALL iom_put("theta_zt", (ptair-rt0) * tmask(:,:,1)) ! potential temperature at z=zt + IF( iom_use('q_zt') ) CALL iom_put("q_zt", pqair * tmask(:,:,1)) ! specific humidity " + IF( iom_use('theta_zu') ) CALL iom_put("theta_zu", (theta_zu -rt0) * tmask(:,:,1)) ! potential temperature at z=zu + IF( iom_use('q_zu') ) CALL iom_put("q_zu", q_zu * tmask(:,:,1)) ! specific humidity " + IF( iom_use('ssq') ) CALL iom_put("ssq", pssq * tmask(:,:,1)) ! saturation specific humidity at z=0 + IF( iom_use('wspd_blk') ) CALL iom_put("wspd_blk", zU_zu * tmask(:,:,1)) ! bulk wind speed at z=zu + + IF( ln_skin_cs .OR. ln_skin_wl ) THEN + !! In the presence of sea-ice we forget about the cool-skin/warm-layer update of zsspt, pssq & ptsk: + WHERE ( fr_i(:,:) > 0.001_wp ) + ! sea-ice present, we forget about the update, using what we backed up before call to turb_*() + zsspt(:,:) = zztmp1(:,:) + pssq(:,:) = zztmp2(:,:) + END WHERE + ! apply potential temperature increment to abolute SST + ptsk(:,:) = ptsk(:,:) + ( zsspt(:,:) - zztmp1(:,:) ) + END IF + + ! Turbulent fluxes over ocean => BULK_FORMULA @ sbc_phy.F90 + ! ------------------------------------------------------------- + + IF( ln_abl ) THEN !== ABL formulation ==! multiplication by rho_air and turbulent fluxes computation done in ablstp + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zztmp = zU_zu(ji,jj) + wndm(ji,jj) = zztmp ! Store zU_zu in wndm to compute ustar2 in ablmod + pcd_du(ji,jj) = zztmp * zcd_oce(ji,jj) + psen(ji,jj) = zztmp * zch_oce(ji,jj) + pevp(ji,jj) = zztmp * zce_oce(ji,jj) + zpre(ji,jj) = pres_temp( pqair(ji,jj), pslp(ji,jj), rn_zu, ptpot=ptair(ji,jj), pta=ztabs(ji,jj) ) + rhoa(ji,jj) = rho_air( ztabs(ji,jj), pqair(ji,jj), zpre(ji,jj) ) + END DO ; END DO + + ELSE !== BLK formulation ==! turbulent fluxes computation + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zpre(ji,jj) = pres_temp( q_zu(ji,jj), pslp(ji,jj), rn_zu, ptpot=theta_zu(ji,jj), pta=ztabs(ji,jj) ) + rhoa(ji,jj) = rho_air( ztabs(ji,jj), q_zu(ji,jj), zpre(ji,jj) ) + END DO ; END DO + + CALL bulk_formula( rn_zu, zsspt(:,:), pssq(:,:), theta_zu(:,:), q_zu(:,:), & + & zcd_oce(:,:), zch_oce(:,:), zce_oce(:,:), & + & wndm(:,:), zU_zu(:,:), pslp(:,:), rhoa(:,:), & + & taum(:,:), psen(:,:), plat(:,:), & + & pEvap=pevp(:,:), pfact_evap=rn_efac ) + + psen(:,:) = psen(:,:) * tmask(:,:,1) + plat(:,:) = plat(:,:) * tmask(:,:,1) + taum(:,:) = taum(:,:) * tmask(:,:,1) + pevp(:,:) = pevp(:,:) * tmask(:,:,1) + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + IF( wndm(ji,jj) > 0._wp ) THEN + zztmp = taum(ji,jj) / wndm(ji,jj) + ztau_i(ji,jj) = zztmp * pwndi(ji,jj) + ztau_j(ji,jj) = zztmp * pwndj(ji,jj) + ELSE + ztau_i(ji,jj) = 0._wp + ztau_j(ji,jj) = 0._wp + ENDIF + END DO ; END DO + + IF( ln_crt_fbk ) THEN ! aply eq. 10 and 11 of Renault et al. 2020 (doi: 10.1029/2019MS001715) + zstmax = MIN( rn_stau_a * 3._wp + rn_stau_b, 0._wp ) ! set the max value of Stau corresponding to a wind of 3 m/s (<0) + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) ! end at jpj and jpi, as ztau_j(ji,jj+1) ztau_i(ji+1,jj) used in the next loop + zstau = MIN( rn_stau_a * wndm(ji,jj) + rn_stau_b, zstmax ) ! stau (<0) must be smaller than zstmax + ztau_i(ji,jj) = ztau_i(ji,jj) + zstau * ( 0.5_wp * ( pu(ji-1,jj ) + pu(ji,jj) ) - puatm(ji,jj) ) + ztau_j(ji,jj) = ztau_j(ji,jj) + zstau * ( 0.5_wp * ( pv(ji ,jj-1) + pv(ji,jj) ) - pvatm(ji,jj) ) + taum(ji,jj) = SQRT( ztau_i(ji,jj) * ztau_i(ji,jj) + ztau_j(ji,jj) * ztau_j(ji,jj) ) + END DO ; END DO + ENDIF + + ! ... utau, vtau at U- and V_points, resp. + ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines + ! Note that coastal wind stress is not used in the code... so this extra care has no effect + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! start loop at 2, in case ln_crt_fbk = T + utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( ztau_i(ji,jj) + ztau_i(ji+1,jj ) ) & + & * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1)) + vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( ztau_j(ji,jj) + ztau_j(ji ,jj+1) ) & + & * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1)) + END DO ; END DO + + IF( ln_crt_fbk ) THEN + CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp, taum, 'T', 1._wp ) + ELSE + CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp ) + ENDIF + + ! Saving open-ocean wind-stress (module and components) on T-points: + CALL iom_put( "taum_oce", taum(:,:)*tmask(:,:,1) ) ! output wind stress module + !#LB: These 2 lines below mostly here for 'STATION_ASF' test-case, otherwize "utau" (U-grid) and vtau" (V-grid) does the job in: [DYN/dynatf.F90]) + CALL iom_put( "utau_oce", ztau_i(:,:)*tmask(:,:,1) ) ! utau at T-points! + CALL iom_put( "vtau_oce", ztau_j(:,:)*tmask(:,:,1) ) ! vtau at T-points! + + ! IF(sn_cfctl%l_prtctl) THEN + !CALL prt_ctl( tab2d_1=pssq , clinfo1=' blk_oce_1: pssq : ') + !CALL prt_ctl( tab2d_1=wndm , clinfo1=' blk_oce_1: wndm : ') + !CALL prt_ctl( tab2d_1=utau , clinfo1=' blk_oce_1: utau : ', mask1=umask, & + ! & tab2d_2=vtau , clinfo2=' vtau : ', mask2=vmask ) + !CALL prt_ctl( tab2d_1=zcd_oce, clinfo1=' blk_oce_1: Cd : ') + ! ENDIF + ! + ENDIF ! ln_blk / ln_abl + + ptsk(:,:) = ( ptsk(:,:) - rt0 ) * tmask(:,:,1) ! Back to Celsius + + IF( ln_skin_cs .OR. ln_skin_wl ) THEN + CALL iom_put( "t_skin" , ptsk ) ! T_skin in Celsius + CALL iom_put( "dt_skin" , ptsk - pst ) ! T_skin - SST temperature difference + ENDIF + ! + END SUBROUTINE blk_oce_1 + + + SUBROUTINE blk_oce_2( ptair, pdqlw, pprec, psnow, & ! <<= in + & ptsk, psen, plat, pevp ) ! <<= in + !!--------------------------------------------------------------------- + !! *** ROUTINE blk_oce_2 *** + !! + !! ** Purpose : finalize the momentum, heat and freshwater fluxes computation + !! at the ocean surface at each time step knowing Cd, Ch, Ce and + !! atmospheric variables (from ABL or external data) + !! + !! ** Outputs : - utau : i-component of the stress at U-point (N/m2) + !! - vtau : j-component of the stress at V-point (N/m2) + !! - taum : Wind stress module at T-point (N/m2) + !! - wndm : Wind speed module at T-point (m/s) + !! - qsr : Solar heat flux over the ocean (W/m2) + !! - qns : Non Solar heat flux over the ocean (W/m2) + !! - emp : evaporation minus precipitation (kg/m2/s) + !!--------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptair ! potential temperature of air #LB: confirm! + REAL(wp), INTENT(in), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] + REAL(wp), INTENT(in), DIMENSION(:,:) :: pprec + REAL(wp), INTENT(in), DIMENSION(:,:) :: psnow + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptsk ! SKIN surface temperature [Celsius] + REAL(wp), INTENT(in), DIMENSION(:,:) :: psen + REAL(wp), INTENT(in), DIMENSION(:,:) :: plat + REAL(wp), INTENT(in), DIMENSION(:,:) :: pevp + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zztmp,zz1,zz2,zz3 ! local variable + REAL(wp), DIMENSION(jpi,jpj) :: zqlw ! net long wave radiative heat flux + REAL(wp), DIMENSION(jpi,jpj) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg) + !!--------------------------------------------------------------------- + ! + ! Heat content per unit mass (J/kg) + zcptrain(:,:) = ( ptair - rt0 ) * rcp * tmask(:,:,1) + zcptsnw (:,:) = ( MIN( ptair, rt0 ) - rt0 ) * rcpi * tmask(:,:,1) + zcptn (:,:) = ptsk * rcp * tmask(:,:,1) + ! + ! ----------------------------------------------------------------------------- ! + ! III Net longwave radiative FLUX ! + ! ----------------------------------------------------------------------------- ! + !! #LB: now moved after Turbulent fluxes because must use the skin temperature rather than bulk SST + !! (ptsk is skin temperature if ln_skin_cs==.TRUE. .OR. ln_skin_wl==.TRUE.) + zqlw(:,:) = qlw_net( pdqlw(:,:), ptsk(:,:)+rt0 ) + + ! ----------------------------------------------------------------------------- ! + ! IV Total FLUXES ! + ! ----------------------------------------------------------------------------- ! + ! + emp (:,:) = ( pevp(:,:) - pprec(:,:) * rn_pfac ) * tmask(:,:,1) ! mass flux (evap. - precip.) + ! + qns(:,:) = zqlw(:,:) + psen(:,:) + plat(:,:) & ! Downward Non Solar + & - psnow(:,:) * rn_pfac * rLfus & ! remove latent melting heat for solid precip + & - pevp(:,:) * zcptn(:,:) & ! remove evap heat content at SST + & + ( pprec(:,:) - psnow(:,:) ) * rn_pfac * zcptrain(:,:) & ! add liquid precip heat content at Tair + & + psnow(:,:) * rn_pfac * zcptsnw(:,:) ! add solid precip heat content at min(Tair,Tsnow) + qns(:,:) = qns(:,:) * tmask(:,:,1) + ! + ! + CALL iom_put( "rho_air" , rhoa*tmask(:,:,1) ) ! output air density [kg/m^3] + CALL iom_put( "evap_oce" , pevp ) ! evaporation + CALL iom_put( "qlw_oce" , zqlw ) ! output downward longwave heat over the ocean + CALL iom_put( "qsb_oce" , psen ) ! output downward sensible heat over the ocean + CALL iom_put( "qla_oce" , plat ) ! output downward latent heat over the ocean + tprecip(:,:) = pprec(:,:) * rn_pfac * tmask(:,:,1) ! output total precipitation [kg/m2/s] + sprecip(:,:) = psnow(:,:) * rn_pfac * tmask(:,:,1) ! output solid precipitation [kg/m2/s] + CALL iom_put( 'snowpre', sprecip ) ! Snow + CALL iom_put( 'precip' , tprecip ) ! Total precipitation + ! + IF ( nn_ice == 0 ) THEN + CALL iom_put( "qemp_oce" , qns-zqlw-psen-plat ) ! output downward heat content of E-P over the ocean + CALL iom_put( "qns_oce" , qns ) ! output downward non solar heat over the ocean + CALL iom_put( "qsr_oce" , qsr ) ! output downward solar heat over the ocean + CALL iom_put( "qt_oce" , qns+qsr ) ! output total downward heat over the ocean + ENDIF + ! + ! IF(sn_cfctl%l_prtctl) THEN + !CALL prt_ctl(tab2d_1=zqlw , clinfo1=' blk_oce_2: zqlw : ') + !CALL prt_ctl(tab2d_1=psen , clinfo1=' blk_oce_2: psen : ' ) + !CALL prt_ctl(tab2d_1=plat , clinfo1=' blk_oce_2: plat : ' ) + !CALL prt_ctl(tab2d_1=qns , clinfo1=' blk_oce_2: qns : ' ) + !CALL prt_ctl(tab2d_1=emp , clinfo1=' blk_oce_2: emp : ') + ! ENDIF + ! + END SUBROUTINE blk_oce_2 + + + + !!====================================================================== +END MODULE sbcblk diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_andreas.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_andreas.f90 new file mode 100644 index 0000000000000000000000000000000000000000..930e3d8bd0a01c65fb51aa1f3027202069f9196e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_andreas.f90 @@ -0,0 +1,353 @@ + + + + + + + + + + + + + +!!! TO DO: consistent psi_m and psi_h needed!!! For now is those of NCAR !!! +!! +MODULE sbcblk_algo_andreas + !!====================================================================== + !! *** MODULE sbcblk_algo_andreas *** + !! Computes: + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at 10m Ubzu + !! according to Andreas et al. (2015) + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !! Andreas, E.L., Mahrt, L. and Vickers, D. (2015), + !! An improved bulk air–sea surface flux algorithm, + !! including spray‐mediated transfer. + !! Q.J.R. Meteorol. Soc., 141: 642-654. doi:10.1002/qj.2424 + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !! + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at z=zu: Ubzu + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Using the bulk formulation/param. of Large & Yeager 2008 + !! + !! Routine turb_andreas maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !! + !! ** Author: L. Brodeau, August 2020 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.x ! 2020-08 (L.Brodeau) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + IMPLICIT NONE + PRIVATE + + !! Important (Brodeau fix): + REAL(wp), PARAMETER :: rRi_max = 0.15_wp ! Bulk Ri above which the algorithm fucks up! + ! ! (increasing (>0) Ri means that surface layer increasingly stable and/or wind increasingly weak) + REAL(wp), PARAMETER :: rCs_min = 0.35E-3_wp ! minimum value to tolarate for CE and CH ! Must be larger than "Cx_min" !!! + + PUBLIC :: TURB_ANDREAS, psi_m_andreas, psi_h_andreas + + !! * Substitutions + + + + + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_andreas( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & + & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & + & nb_iter, CdN, ChN, CeN ) + !!---------------------------------------------------------------------------------- + !! *** ROUTINE turb_andreas *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to Large & Yeager (2004) and Large & Yeager (2008) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * sst : bulk SST [K] + !! * t_zt : potential air temperature at zt [K] + !! * ssq : specific humidity at saturation at SST [kg/kg] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! + !! OUTPUT : + !! -------- + !! * Cd : drag coefficient + !! * Ch : sensible heat coefficient + !! * Ce : evaporation coefficient + !! * t_zu : pot. air temperature adjusted at wind height zu [K] + !! * q_zu : specific humidity of air // [kg/kg] + !! * Ubzu : bulk wind speed at zu [m/s] + !! + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + ! + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN + ! + INTEGER :: nbit, jit ! iterations... + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + !! + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: z0 ! roughness length (momentum) [m] + REAL(wp), DIMENSION(jpi,jpj) :: UN10 ! Neutral wind speed at zu [m/s] + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: RiB ! square root of Cd + !! + !!---------------------------------------------------------------------------------- + nbit = nb_iter0 + IF( PRESENT(nb_iter) ) nbit = nb_iter + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision + + Ubzu = MAX( 0.25_wp , U_zu ) ! relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s + + !! First guess: + UN10 = Ubzu + Cd = 1.1E-3_wp + Ch = 1.1E-3_wp + Ce = 1.1E-3_wp + t_zu = t_zt + q_zu = q_zt + + !! First guess of turbulent scales for scalars: + ztmp0 = SQRT(Cd) + t_star = Ch/ztmp0*(t_zu - sst) ! theta* + q_star = Ce/ztmp0*(q_zu - ssq) ! q* + + ! Bulk Richardson number: + RiB(:,:) = Ri_bulk( zu, sst, t_zu, ssq, q_zu, Ubzu ) + + + !! ITERATION BLOCK + DO jit = 1, nbit + + WHERE ( RiB < rRi_max ) + !! Normal condition case: + u_star = U_STAR_ANDREAS( UN10 ) + ELSEWHERE + !! Extremely stable + weak wind !!! + !! => for we force u* to be consistent with minimum value for CD: + !! (otherwize algorithm becomes nonsense...) + u_star = SQRT(Cx_min) * Ubzu ! Cd does not go below Cx_min ! + ENDWHERE + + !! Stability parameter : + zeta_u = zu*One_on_L( t_zu, q_zu, u_star, t_star, q_star ) ! zu * 1/L + + !! Drag coefficient: + ztmp0 = u_star/Ubzu + + Cd = MAX( ztmp0*ztmp0 , Cx_min ) + + !! Roughness length: + z0 = MIN( z0_from_Cd( zu, Cd, ppsi=psi_m_andreas(zeta_u) ) , z0_sea_max ) + + !! z0t and z0q, based on LKB, just like into COARE 2.5: + ztmp0 = z0 * u_star / visc_air(t_zu) ! Re_r + ztmp1 = z0tq_LKB( 1, ztmp0, z0 ) ! z0t + ztmp2 = z0tq_LKB( 2, ztmp0, z0 ) ! z0q + + !! Turbulent scales at zu : + ztmp0 = psi_h_andreas(zeta_u) ! lolo: zeta_u for scalars??? + t_star = (t_zu - sst)*vkarmn/(LOG(zu) - LOG(ztmp1) - ztmp0) ! theta* (ztmp1 == z0t in rhs term) + q_star = (q_zu - ssq)*vkarmn/(LOG(zu) - LOG(ztmp2) - ztmp0) ! q* (ztmp2 == z0q in rhs term) + + IF( (.NOT. l_zt_equal_zu).AND.( jit > 1 ) ) THEN + !! Re-updating temperature and humidity at zu if zt /= zu: + ztmp0 = zeta_u/zu*zt ! zeta_t + ztmp0 = LOG(zt/zu) + psi_h_andreas(zeta_u) - psi_h_andreas(ztmp0) + t_zu = t_zt - t_star/vkarmn*ztmp0 + q_zu = q_zt - q_star/vkarmn*ztmp0 + RiB = Ri_bulk( zu, sst, t_zu, ssq, q_zu, Ubzu ) !LOLO + ENDIF + + !! Update neutral-stability wind at zu: + UN10 = MAX( 0.1_wp , UN10_from_ustar( zu, Ubzu, u_star, psi_m_andreas(zeta_u) ) ) ! UN10 + + END DO !DO jit = 1, nbit + + ! Compute transfer coefficients at zu: + ztmp0 = u_star/Ubzu + + Cd = MAX( ztmp0*ztmp0 , Cx_min ) ! the earlier use of Cx_min on u* should make use of Cx_min here unnecessary! + + ztmp1 = t_zu - sst ; ztmp1 = SIGN( MAX(ABS(ztmp1),1.E-6_wp), ztmp1 ) ! dt_zu + ztmp2 = q_zu - ssq ; ztmp2 = SIGN( MAX(ABS(ztmp2),1.E-9_wp), ztmp2 ) ! dq_zu + Ch = MAX( ztmp0*t_star/ztmp1 , rCs_min ) + Ce = MAX( ztmp0*q_star/ztmp2 , rCs_min ) + + !! Neutral-stability coefficients: + ztmp0 = 1._wp/LOG(zu/z0) + ztmp1 = z0 * u_star / visc_air(t_zu) ! Re_r + + IF(PRESENT(CdN)) CdN = vkarmn2*ztmp0*ztmp0 + IF(PRESENT(ChN)) ChN = vkarmn2*ztmp0/LOG(zu/z0tq_LKB( 1, ztmp1, z0 )) + IF(PRESENT(CeN)) CeN = vkarmn2*ztmp0/LOG(zu/z0tq_LKB( 2, ztmp1, z0 )) + + END SUBROUTINE turb_andreas + + + FUNCTION U_STAR_ANDREAS( pun10 ) + !!---------------------------------------------------------------------------------- + !! Estimate of the friction velocity as a function of the neutral-stability wind + !! speed at at 10m + !! + !! Origin: Eq.(2.2) of Andreas et al. (2015) + !! + !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pun10 !: neutral-stability scalar wind speed at 10m (m/s) + REAL(wp), DIMENSION(jpi,jpj) :: u_star_andreas !: friction velocity [m/s] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: za, zt, zw ! local scalars + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zw = pun10(ji,jj) + za = zw - 8.271_wp + zt = za + SQRT( 0.12_wp*za*za + 0.181_wp ) + u_star_andreas(ji,jj) = 0.239_wp + 0.0433_wp * zt + END DO ; END DO + END FUNCTION U_STAR_ANDREAS + + + FUNCTION psi_m_andreas( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for momentum + !! TO DO !!!!!!!!!!!!!!!!!!!!! + !! LOLO: paper says Paulson 1970 when unstable and Grachev et al 2007 for STABLE + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_andreas + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + REAL(wp), PARAMETER :: zam = 5._wp ! a_m (just below Eq.(9b) + REAL(wp), PARAMETER :: zbm = zam/6.5_wp ! b_m (just below Eq.(9b) + ! + REAL(wp), PARAMETER :: z1o3 = 1._wp/3._wp + REAL(wp), PARAMETER :: zsr3 = SQRT(3._wp) + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zx, zpsi_unst, zbbm, zpsi_stab, zstab ! local scalars + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zta = MIN( pzeta(ji,jj) , 15._wp ) !! Very stable conditions (L positif and big!) + ! + !! *** Unstable: Paulson (1970): #LOLO: DOUBLE CHECK IT IS PAULSON!!!!! + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 - 16z)^0.5 + zx2 = MAX( zx2 , 1._wp ) + zx = SQRT(zx2) ! (1 - 16z)^0.25 + zpsi_unst = 2._wp*LOG(ABS( (1._wp + zx )*0.5_wp )) & + & + LOG(ABS( (1._wp + zx2)*0.5_wp )) & + & - 2._wp*ATAN(zx) + rpi*0.5_wp + ! + !! *** Stable: Grachev et al 2007 (SHEBA) [Eq.(12) Grachev et al 2007]: + zx = ABS(1._wp + zta)**z1o3 + zbbm = ABS( (1._wp - zbm)/zbm )**z1o3 ! B_m + ! + zpsi_stab = -3.*zam/zbm*(zx - 1._wp) + zam*zbbm/(2.*zbm) * ( & + & 2.*LOG(ABS( ( zx + zbbm )/(1._wp + zbbm ) )) & + & - LOG(ABS( (zx*zx - zx*zbbm + zbbm*zbbm)/(1._wp - zbbm + zbbm*zbbm) )) & + & + 2.*zsr3*( ATAN( (2.*zx - zbbm)/(zsr3*zbbm) ) - ATAN( (2._wp - zbbm)/(zsr3*zbbm) ) ) ) + ! + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_m_andreas(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END DO ; END DO + END FUNCTION psi_m_andreas + + + FUNCTION psi_h_andreas( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! + !! TO DO + !! !! LOLO: paper says Paulson 1970 when unstable and Grachev et al 2007 for STABLE + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_andreas + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + REAL(wp), PARAMETER :: zah = 5._wp ! a_h (just below Eq.(9b) + REAL(wp), PARAMETER :: zbh = 5._wp ! b_h (just below Eq.(9b) + REAL(wp), PARAMETER :: zch = 3._wp ! c_h (just below Eq.(9b) + REAL(wp), PARAMETER :: zbbh = SQRT(5._wp) ! B_h (just below Eq.(13) + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zz, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zta = MIN( pzeta(ji,jj) , 15._wp ) !! Very stable conditions (L positif and large!) + ! + !! *** Unstable: Paulson (1970): #LOLO: DOUBLE CHECK IT IS PAULSON!!!!! + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 -16z)^0.5 + zx2 = MAX( zx2 , 1._wp ) + zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) + ! + !! *** Stable: Grachev et al 2007 (SHEBA) [Eq.(13) Grachev et al 2007]: + zz = 2.*zta + zch + zpsi_stab = - 0.5*zbh*LOG(ABS(1._wp + zch*zta + zta*zta)) & + & + (-zah/zbbh + 0.5*zbh*zch/zbbh) & + & *( LOG(ABS((zz - zbbh)/(zz + zbbh))) & + & - LOG(ABS((zch - zbbh)/(zch + zbbh))) ) + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_h_andreas(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END DO ; END DO + END FUNCTION psi_h_andreas + + !!====================================================================== +END MODULE sbcblk_algo_andreas diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_coare3p0.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_coare3p0.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8799300d81535a16306cb1a614b92696fee1bcca --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_coare3p0.f90 @@ -0,0 +1,521 @@ + + + + + + + + + + + + + +MODULE sbcblk_algo_coare3p0 + !!====================================================================== + !! *** MODULE sbcblk_algo_coare3p0 *** + !! + !! After Fairall et al, 2003 + !! Computes: + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at 10m Ubzu + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Routine turb_coare3p0 maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk) + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2016-02 (L.Brodeau) Original code + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! turb_coare3p0 : computes the bulk turbulent transfer coefficients + !! adjusts t_air and q_air from zt to zu m + !! returns the effective bulk wind speed at 10m + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE iom ! I/O manager library + USE lib_mpp ! distribued memory computing library + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE sbcwave, ONLY : cdn_wave ! wave module + USE lib_fortran ! to use key_nosignedzero + + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE sbcblk_skin_coare ! cool-skin/warm layer scheme (CSWL_ECMWF) !LB + + IMPLICIT NONE + PRIVATE + + PUBLIC :: SBCBLK_ALGO_COARE3P0_INIT, TURB_COARE3P0 + !! * Substitutions + + + + + + !! COARE own values for given constants: + REAL(wp), PARAMETER :: zi0 = 600._wp ! scale height of the atmospheric boundary layer... + REAL(wp), PARAMETER :: Beta0 = 1.25_wp ! gustiness parameter + REAL(wp), PARAMETER :: zeta_abs_max = 50._wp + + !!---------------------------------------------------------------------- +CONTAINS + + + SUBROUTINE sbcblk_algo_coare3p0_init(l_use_cs, l_use_wl) + !!--------------------------------------------------------------------- + !! *** FUNCTION sbcblk_algo_coare3p0_init *** + !! + !! INPUT : + !! ------- + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !!--------------------------------------------------------------------- + LOGICAL , INTENT(in) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in) :: l_use_wl ! use the warm-layer parameterization + INTEGER :: ierr + !!--------------------------------------------------------------------- + IF( l_use_wl ) THEN + ierr = 0 + ALLOCATE ( Tau_ac(jpi,jpj) , Qnt_ac(jpi,jpj), dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P0_INIT => allocation of Tau_ac, Qnt_ac, dT_wl & Hz_wl failed!' ) + Tau_ac(:,:) = 0._wp + Qnt_ac(:,:) = 0._wp + dT_wl(:,:) = 0._wp + Hz_wl(:,:) = Hwl_max + ENDIF + IF( l_use_cs ) THEN + ierr = 0 + ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P0_INIT => allocation of dT_cs failed!' ) + dT_cs(:,:) = -0.25_wp ! First guess of skin correction + ENDIF + END SUBROUTINE sbcblk_algo_coare3p0_init + + + + SUBROUTINE turb_coare3p0( kt, zt, zu, T_s, t_zt, q_s, q_zt, U_zu, l_use_cs, l_use_wl, & + & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & + & nb_iter, Cdn, Chn, Cen, & ! optional output + & Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer) + & pdT_wl, pHz_wl ) ! optionals for warm-layer only + !!---------------------------------------------------------------------- + !! *** ROUTINE turb_coare3p0 *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to Fairall et al. (2003) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! Applies the cool-skin warm-layer correction of the SST to T_s + !! if the net shortwave flux at the surface (Qsw), the downwelling longwave + !! radiative fluxes at the surface (rad_lw), and the sea-leve pressure (slp) + !! are provided as (optional) arguments! + !! + !! INPUT : + !! ------- + !! * kt : current time step (starts at 1) + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * t_zt : potential air temperature at zt [K] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !! + !! INPUT/OUTPUT: + !! ------------- + !! * T_s : always "bulk SST" as input [K] + !! -> unchanged "bulk SST" as output if CSWL not used [K] + !! -> skin temperature as output if CSWL used [K] + !! + !! * q_s : SSQ aka saturation specific humidity at temp. T_s [kg/kg] + !! -> doesn't need to be given a value if skin temp computed (in case l_use_cs=True or l_use_wl=True) + !! -> MUST be given the correct value if not computing skint temp. (in case l_use_cs=False or l_use_wl=False) + !! + !! OPTIONAL INPUT: + !! --------------- + !! * Qsw : net solar flux (after albedo) at the surface (>0) [W/m^2] + !! * rad_lw : downwelling longwave radiation at the surface (>0) [W/m^2] + !! * slp : sea-level pressure [Pa] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * pdT_cs : SST increment "dT" for cool-skin correction [K] + !! * pdT_wl : SST increment "dT" for warm-layer correction [K] + !! * pHz_wl : thickness of warm-layer [m] + !! + !! OUTPUT : + !! -------- + !! * Cd : drag coefficient + !! * Ch : sensible heat coefficient + !! * Ce : evaporation coefficient + !! * t_zu : pot. air temperature adjusted at wind height zu [K] + !! * q_zu : specific humidity of air // [kg/kg] + !! * Ubzu : bulk wind speed at zu [m/s] + !! + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! current time step + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + ! + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + ! + INTEGER :: nbit, jit + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + ! + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu + REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + ! + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST + ! + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_coare3p0@sbcblk_algo_coare3p0' + !!---------------------------------------------------------------------------------- + IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P0_INIT(l_use_cs, l_use_wl) + + nbit = nb_iter0 + IF( PRESENT(nb_iter) ) nbit = nb_iter + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision + IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) + + !! Initializations for cool skin and warm layer: + IF( l_use_cs .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use cool-skin param!' ) + + IF( l_use_wl .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' ) + + IF( l_use_cs .OR. l_use_wl ) THEN + ALLOCATE ( zsst(jpi,jpj) ) + zsst = T_s ! backing up the bulk SST + IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction + q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s + ENDIF + + !! First guess of temperature and humidity at height zu: + t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... + q_zu = MAX( q_zt , 1.e-6_wp ) ! " + + !! Pot. temp. difference (and we don't want it to be 0!) + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + znu_a = visc_air(t_zu) ! Air viscosity (m^2/s) at zt given from temperature in (K) + + Ubzu = SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution + + ztmp0 = LOG( zu*10000._wp) ! optimization: 10000. == 1/z0 (with z0 first guess == 0.0001) + ztmp1 = LOG(10._wp*10000._wp) ! " " " + u_star = 0.035_wp*Ubzu*ztmp1/ztmp0 ! (u* = 0.035*Un10) + + z0 = charn_coare3p0(U_zu)*u_star*u_star/grav + 0.11_wp*znu_a/u_star + z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + z0t = 1._wp / ( 0.1_wp*EXP(vkarmn/(0.00115/(vkarmn/ztmp1))) ) + z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + Cd = MAX( (vkarmn/ztmp0)**2 , Cx_min ) ! first guess of Cd + + ztmp0 = vkarmn2/LOG(zt/z0t)/Cd + + ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) + + !! First estimate of zeta_u, depending on the stability, ie sign of BRN (ztmp2): + ztmp1 = 0.5 + SIGN( 0.5_wp , ztmp2 ) + zeta_u = (1._wp - ztmp1) * ztmp0*ztmp2 / (1._wp - ztmp2*zi0*0.004_wp*Beta0**3/zu) & ! BRN < 0 + & + ztmp1 * ( ztmp0*ztmp2 + 27._wp/9._wp*ztmp2*ztmp2 ) ! BRN > 0 + + !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L + ztmp0 = vkarmn/(LOG(zu/z0t) - psi_h_coare(zeta_u)) + + u_star = MAX ( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) + t_star = dt_zu*ztmp0 + q_star = dq_zu*ztmp0 + + ! What needs to be done if zt /= zu: + IF( .NOT. l_zt_equal_zu ) THEN + !! First update of values at zu (or zt for wind) + zeta_t = zt*zeta_u/zu + ztmp0 = psi_h_coare(zeta_u) - psi_h_coare(zeta_t) + ztmp1 = LOG(zt/zu) + ztmp0 + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + q_zu = (0.5_wp + SIGN(0.5_wp,q_zu))*q_zu !Makes it impossible to have negative humidity : + ! + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + !! ITERATION BLOCK + DO jit = 1, nbit + + !!Inverse of Obukov length (1/L) : + ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star) ! 1/L == 1/[Obukhov length] + ztmp0 = SIGN( MIN(ABS(ztmp0),200._wp), ztmp0 ) ! 1/L (prevents FPE from stupid values from masked region later on...) + + ztmp1 = u_star*u_star ! u*^2 + + !! Update wind at zu with convection-related wind gustiness in unstable conditions (Fairall et al. 2003, Eq.8): + ztmp2 = Beta0*Beta0*ztmp1*(MAX(-zi0*ztmp0/vkarmn,0._wp))**(2._wp/3._wp) ! square of wind gustiness contribution, ztmp2 == Ug^2 + !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before zi0 + Ubzu = MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed + ! => 0.2 prevents Ubzu to be 0 in stable case when U_zu=0. + + !! Stability parameters: + zeta_u = zu*ztmp0 + zeta_u = SIGN( MIN(ABS(zeta_u),zeta_abs_max), zeta_u ) + IF( .NOT. l_zt_equal_zu ) THEN + zeta_t = zt*ztmp0 + zeta_t = SIGN( MIN(ABS(zeta_t),zeta_abs_max), zeta_t ) + ENDIF + + !! Adjustment the wind at 10m (not needed in the current algo form): + !IF( zu \= 10._wp ) U10 = U_zu + u_star/vkarmn*(LOG(10._wp/zu) - psi_m_coare(10._wp*ztmp0) + psi_m_coare(zeta_u)) + + !! Roughness lengthes z0, z0t (z0q = z0t) : + ztmp2 = u_star/vkarmn*LOG(10./z0) ! Neutral wind speed at 10m + z0 = charn_coare3p0(ztmp2)*ztmp1/grav + 0.11_wp*znu_a/u_star ! Roughness length (eq.6) [ ztmp1==u*^2 ] + z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + ztmp1 = ( znu_a / (z0*u_star) )**0.6_wp ! (1./Re_r)^0.72 (Re_r: roughness Reynolds number) COARE3.6-specific! + z0t = MIN( 1.1E-4_wp , 5.5E-5_wp*ztmp1 ) ! Scalar roughness for both theta and q (eq.28) #LB: some use 1.15 not 1.1 !!! + z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + !! Turbulent scales at zu : + ztmp0 = psi_h_coare(zeta_u) + ztmp1 = vkarmn/(LOG(zu) - LOG(z0t) - ztmp0) ! #LB: in ztmp0, some use psi_h_coare(zeta_t) rather than psi_h_coare(zeta_t) ??? + + t_star = dt_zu*ztmp1 + q_star = dq_zu*ztmp1 + u_star = MAX( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) + + IF( .NOT. l_zt_equal_zu ) THEN + !! Re-updating temperature and humidity at zu if zt /= zu : + ztmp1 = LOG(zt/zu) + ztmp0 - psi_h_coare(zeta_t) + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + ENDIF + + IF(( l_use_cs ).OR.( l_use_wl )) THEN + zpre(:,:) = pres_temp( q_zu(:,:), slp(:,:), zu, ptpot=t_zu(:,:), pta=zta(:,:) ) + zrhoa(:,:) = rho_air( zta(:,:), q_zu(:,:), zpre(:,:) ) + ENDIF + + IF( l_use_cs ) THEN + !! Cool-skin contribution + + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, zeta_u, Qlat=ztmp2) ! Qnsol -> ztmp1 / Tau -> zeta_u + + CALL CS_COARE( Qsw, ztmp1, u_star, zsst, ztmp2 ) ! ! Qnsol -> ztmp1 / Qlat -> ztmp2 + + T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1) + IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + ENDIF + + IF( l_use_wl ) THEN + !! Warm-layer contribution + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, zeta_u) ! Qnsol -> ztmp1 / Tau -> zeta_u + !! In WL_COARE or , Tau_ac and Qnt_ac must be updated at the final itteration step => add a flag to do this! + CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nbit,jit) ) + + !! Updating T_s and q_s !!! + T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1) + IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + ENDIF + + IF( l_use_cs .OR. l_use_wl .OR. (.NOT. l_zt_equal_zu) ) THEN + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + END DO !DO jit = 1, nbit + + ! compute transfer coefficients at zu : + ztmp0 = u_star/Ubzu + Cd = MAX( ztmp0*ztmp0 , Cx_min ) + Ch = MAX( ztmp0*t_star/dt_zu , Cx_min ) + Ce = MAX( ztmp0*q_star/dq_zu , Cx_min ) + + IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t ) + + IF(PRESENT(Cdn)) Cdn = MAX( vkarmn2 / (LOG(zu/z0 )*LOG(zu/z0 )) , Cx_min ) + IF(PRESENT(Chn)) Chn = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) + IF(PRESENT(Cen)) Cen = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) + + IF( l_use_cs .AND. PRESENT(pdT_cs) ) pdT_cs = dT_cs + IF( l_use_wl .AND. PRESENT(pdT_wl) ) pdT_wl = dT_wl + IF( l_use_wl .AND. PRESENT(pHz_wl) ) pHz_wl = Hz_wl + + IF( l_use_cs .OR. l_use_wl ) DEALLOCATE ( zsst ) + + END SUBROUTINE turb_coare3p0 + + + FUNCTION charn_coare3p0( pwnd ) + !!------------------------------------------------------------------- + !! Compute the Charnock parameter as a function of the wind speed + !! + !! (Fairall et al., 2003 p.577-578) + !! + !! Wind below 10 m/s : alfa = 0.011 + !! Wind between 10 and 18 m/s : linear increase from 0.011 to 0.018 + !! Wind greater than 18 m/s : alfa = 0.018 + !! + !! Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p0 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zw, zgt10, zgt18 + !!------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zw = pwnd(ji,jj) ! wind speed + ! + ! Charnock's constant, increases with the wind : + zgt10 = 0.5 + SIGN(0.5_wp,(zw - 10)) ! If zw<10. --> 0, else --> 1 + zgt18 = 0.5 + SIGN(0.5_wp,(zw - 18.)) ! If zw<18. --> 0, else --> 1 + ! + charn_coare3p0(ji,jj) = (1. - zgt10)*0.011 & ! wind is lower than 10 m/s + & + zgt10*((1. - zgt18)*(0.011 + (0.018 - 0.011) & + & *(zw - 10.)/(18. - 10.)) + zgt18*( 0.018 ) ) ! Hare et al. (1999) + ! + END DO ; END DO + END FUNCTION charn_coare3p0 + + FUNCTION psi_m_coare( pzeta ) + !!---------------------------------------------------------------------------------- + !! ** Purpose: compute the universal profile stability function for momentum + !! COARE 3.0, Fairall et al. 2003 + !! pzeta : stability paramenter, z/L where z is altitude + !! measurement and L is M-O length + !! Stability function for wind speed and scalars matching Kansas and free + !! convection forms with weighting f convective form, follows Fairall et + !! al (1996) with profile constants from Grachev et al (2000) BLM stable + !! form from Beljaars and Holtslag (1991) + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zta = pzeta(ji,jj) + ! + zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable + ! + zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) & + & - 2.*ATAN(zphi_m) + 0.5*rpi + ! + zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective + ! + zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & + & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 + ! + zf = zta*zta + zf = zf/(1. + zf) + zc = MIN(50._wp, 0.35_wp*zta) + zstab = 0.5 + SIGN(0.5_wp, zta) + ! + psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) + & - zstab * ( 1. + 1.*zta & ! (zta > 0) + & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " + END DO ; END DO + END FUNCTION psi_m_coare + + + FUNCTION psi_h_coare( pzeta ) + !!--------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! COARE 3.0, Fairall et al. 2003 + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! Stability function for wind speed and scalars matching Kansas and free + !! convection forms with weighting f convective form, follows Fairall et + !! al (1996) with profile constants from Grachev et al (2000) BLM stable + !! form from Beljaars and Holtslag (1991) + !! + !! Author: L. Brodeau, June 2016 / AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + !!---------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zta = pzeta(ji,jj) + ! + zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable) + ! + zpsi_k = 2.*LOG((1. + zphi_h)/2.) + ! + zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective + ! + zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & + & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 + ! + zf = zta*zta + zf = zf/(1. + zf) + zc = MIN(50._wp,0.35_wp*zta) + zstab = 0.5 + SIGN(0.5_wp, zta) + ! + psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & + & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & + & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) + END DO ; END DO + END FUNCTION psi_h_coare + + !!====================================================================== +END MODULE sbcblk_algo_coare3p0 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_coare3p6.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_coare3p6.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3c17f212b4f435259657812eebcb736c14d1f30c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_coare3p6.f90 @@ -0,0 +1,516 @@ + + + + + + + + + + + + + +MODULE sbcblk_algo_coare3p6 + !!====================================================================== + !! *** MODULE sbcblk_algo_coare3p6 *** + !! + !! After Fairall et al 2018 & Edson et al 2013 + !! Computes: + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at 10m Ubzu + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Routine turb_coare3p6 maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk) + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2016-02 (L.Brodeau) Original code + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! turb_coare3p6 : computes the bulk turbulent transfer coefficients + !! adjusts t_air and q_air from zt to zu m + !! returns the effective bulk wind speed at 10m + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE lib_mpp, ONLY: ctl_stop ! distribued memory computing library + USE in_out_manager, ONLY: nit000 ! I/O manager + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE sbcblk_skin_coare ! cool-skin/warm layer scheme (CSWL_ECMWF) !LB + + IMPLICIT NONE + PRIVATE + + PUBLIC :: SBCBLK_ALGO_COARE3P6_INIT, TURB_COARE3P6 + !! * Substitutions + + + + + + !! COARE own values for given constants: + REAL(wp), PARAMETER :: zi0 = 600._wp ! scale height of the atmospheric boundary layer... + REAL(wp), PARAMETER :: Beta0 = 1.2_wp ! gustiness parameter + REAL(wp), PARAMETER :: zeta_abs_max = 50._wp + + !!---------------------------------------------------------------------- +CONTAINS + + + SUBROUTINE sbcblk_algo_coare3p6_init(l_use_cs, l_use_wl) + !!--------------------------------------------------------------------- + !! *** FUNCTION sbcblk_algo_coare3p6_init *** + !! + !! INPUT : + !! ------- + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !!--------------------------------------------------------------------- + LOGICAL , INTENT(in) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in) :: l_use_wl ! use the warm-layer parameterization + INTEGER :: ierr + !!--------------------------------------------------------------------- + IF( l_use_wl ) THEN + ierr = 0 + ALLOCATE ( Tau_ac(jpi,jpj) , Qnt_ac(jpi,jpj), dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P6_INIT => allocation of Tau_ac, Qnt_ac, dT_wl & Hz_wl failed!' ) + Tau_ac(:,:) = 0._wp + Qnt_ac(:,:) = 0._wp + dT_wl(:,:) = 0._wp + Hz_wl(:,:) = Hwl_max + ENDIF + IF( l_use_cs ) THEN + ierr = 0 + ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P6_INIT => allocation of dT_cs failed!' ) + dT_cs(:,:) = -0.25_wp ! First guess of skin correction + ENDIF + END SUBROUTINE sbcblk_algo_coare3p6_init + + + + SUBROUTINE turb_coare3p6( kt, zt, zu, T_s, t_zt, q_s, q_zt, U_zu, l_use_cs, l_use_wl, & + & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & + & nb_iter, Cdn, Chn, Cen, & ! optional output + & Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer) + & pdT_wl, pHz_wl ) ! optionals for warm-layer only + !!---------------------------------------------------------------------- + !! *** ROUTINE turb_coare3p6 *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to Fairall et al. (2003) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! Applies the cool-skin warm-layer correction of the SST to T_s + !! if the net shortwave flux at the surface (Qsw), the downwelling longwave + !! radiative fluxes at the surface (rad_lw), and the sea-leve pressure (slp) + !! are provided as (optional) arguments! + !! + !! INPUT : + !! ------- + !! * kt : current time step (starts at 1) + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * t_zt : potential air temperature at zt [K] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !! + !! INPUT/OUTPUT: + !! ------------- + !! * T_s : always "bulk SST" as input [K] + !! -> unchanged "bulk SST" as output if CSWL not used [K] + !! -> skin temperature as output if CSWL used [K] + !! + !! * q_s : SSQ aka saturation specific humidity at temp. T_s [kg/kg] + !! -> doesn't need to be given a value if skin temp computed (in case l_use_cs=True or l_use_wl=True) + !! -> MUST be given the correct value if not computing skint temp. (in case l_use_cs=False or l_use_wl=False) + !! + !! OPTIONAL INPUT: + !! --------------- + !! * Qsw : net solar flux (after albedo) at the surface (>0) [W/m^2] + !! * rad_lw : downwelling longwave radiation at the surface (>0) [W/m^2] + !! * slp : sea-level pressure [Pa] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * pdT_cs : SST increment "dT" for cool-skin correction [K] + !! * pdT_wl : SST increment "dT" for warm-layer correction [K] + !! * pHz_wl : thickness of warm-layer [m] + !! + !! OUTPUT : + !! -------- + !! * Cd : drag coefficient + !! * Ch : sensible heat coefficient + !! * Ce : evaporation coefficient + !! * t_zu : pot. air temperature adjusted at wind height zu [K] + !! * q_zu : specific humidity of air // [kg/kg] + !! * Ubzu : bulk wind speed at zu [m/s] + !! + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! current time step + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + ! + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + ! + INTEGER :: nbit, jit + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + ! + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu + REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + ! + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST + ! + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_coare3p6@sbcblk_algo_coare3p6' + !!---------------------------------------------------------------------------------- + IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P6_INIT(l_use_cs, l_use_wl) + + nbit = nb_iter0 + IF( PRESENT(nb_iter) ) nbit = nb_iter + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision + IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) + + !! Initializations for cool skin and warm layer: + IF( l_use_cs .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use cool-skin param!' ) + + IF( l_use_wl .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' ) + + IF( l_use_cs .OR. l_use_wl ) THEN + ALLOCATE ( zsst(jpi,jpj) ) + zsst = T_s ! backing up the bulk SST + IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction + q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s + ENDIF + + !! First guess of temperature and humidity at height zu: + t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... + q_zu = MAX( q_zt , 1.e-6_wp ) ! " + + !! Pot. temp. difference (and we don't want it to be 0!) + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + znu_a = visc_air(t_zu) ! Air viscosity (m^2/s) at zt given from temperature in (K) + + Ubzu = SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution + + ztmp0 = LOG( zu*10000._wp) ! optimization: 10000. == 1/z0 (with z0 first guess == 0.0001) + ztmp1 = LOG(10._wp*10000._wp) ! " " " + u_star = 0.035_wp*Ubzu*ztmp1/ztmp0 ! (u* = 0.035*Un10) + + z0 = charn_coare3p6(U_zu)*u_star*u_star/grav + 0.11_wp*znu_a/u_star + z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + z0t = 1._wp / ( 0.1_wp*EXP(vkarmn/(0.00115/(vkarmn/ztmp1))) ) + z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + Cd = MAX( (vkarmn/ztmp0)**2 , Cx_min ) ! first guess of Cd + + ztmp0 = vkarmn2/LOG(zt/z0t)/Cd + + ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) + + !! First estimate of zeta_u, depending on the stability, ie sign of BRN (ztmp2): + ztmp1 = 0.5 + SIGN( 0.5_wp , ztmp2 ) + zeta_u = (1._wp - ztmp1) * ztmp0*ztmp2 / (1._wp - ztmp2*zi0*0.004_wp*Beta0**3/zu) & ! BRN < 0 + & + ztmp1 * ( ztmp0*ztmp2 + 27._wp/9._wp*ztmp2*ztmp2 ) ! BRN > 0 + + !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L + ztmp0 = vkarmn/(LOG(zu/z0t) - psi_h_coare(zeta_u)) + + u_star = MAX ( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) + t_star = dt_zu*ztmp0 + q_star = dq_zu*ztmp0 + + ! What needs to be done if zt /= zu: + IF( .NOT. l_zt_equal_zu ) THEN + !! First update of values at zu (or zt for wind) + zeta_t = zt*zeta_u/zu + ztmp0 = psi_h_coare(zeta_u) - psi_h_coare(zeta_t) + ztmp1 = LOG(zt/zu) + ztmp0 + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + q_zu = (0.5_wp + SIGN(0.5_wp,q_zu))*q_zu !Makes it impossible to have negative humidity : + ! + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + !! ITERATION BLOCK + DO jit = 1, nbit + + !!Inverse of Obukov length (1/L) : + ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star) ! 1/L == 1/[Obukhov length] + ztmp0 = SIGN( MIN(ABS(ztmp0),200._wp), ztmp0 ) ! 1/L (prevents FPE from stupid values from masked region later on...) + + ztmp1 = u_star*u_star ! u*^2 + + !! Update wind at zu with convection-related wind gustiness in unstable conditions (Fairall et al. 2003, Eq.8): + ztmp2 = Beta0*Beta0*ztmp1*(MAX(-zi0*ztmp0/vkarmn,0._wp))**(2._wp/3._wp) ! square of wind gustiness contribution, ztmp2 == Ug^2 + !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before zi0 + Ubzu = MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed + ! => 0.2 prevents Ubzu to be 0 in stable case when U_zu=0. + + !! Stability parameters: + zeta_u = zu*ztmp0 + zeta_u = SIGN( MIN(ABS(zeta_u),zeta_abs_max), zeta_u ) + IF( .NOT. l_zt_equal_zu ) THEN + zeta_t = zt*ztmp0 + zeta_t = SIGN( MIN(ABS(zeta_t),zeta_abs_max), zeta_t ) + ENDIF + + !! Adjustment the wind at 10m (not needed in the current algo form): + !IF( zu \= 10._wp ) U10 = U_zu + u_star/vkarmn*(LOG(10._wp/zu) - psi_m_coare(10._wp*ztmp0) + psi_m_coare(zeta_u)) + + !! Roughness lengthes z0, z0t (z0q = z0t) : + ztmp2 = u_star/vkarmn*LOG(10./z0) ! Neutral wind speed at 10m + z0 = charn_coare3p6(ztmp2)*ztmp1/grav + 0.11_wp*znu_a/u_star ! Roughness length (eq.6) [ ztmp1==u*^2 ] + z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + ztmp1 = ( znu_a / (z0*u_star) )**0.72_wp ! COARE3.6-specific! (1./Re_r)^0.72 (Re_r: roughness Reynolds number) COARE3.6-specific! + z0t = MIN( 1.6E-4_wp , 5.8E-5_wp*ztmp1 ) ! COARE3.6-specific! + z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + !! Turbulent scales at zu : + ztmp0 = psi_h_coare(zeta_u) + ztmp1 = vkarmn/(LOG(zu) - LOG(z0t) - ztmp0) ! #LB: in ztmp0, some use psi_h_coare(zeta_t) rather than psi_h_coare(zeta_t) ??? + + t_star = dt_zu*ztmp1 + q_star = dq_zu*ztmp1 + u_star = MAX( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) + + IF( .NOT. l_zt_equal_zu ) THEN + !! Re-updating temperature and humidity at zu if zt /= zu : + ztmp1 = LOG(zt/zu) + ztmp0 - psi_h_coare(zeta_t) + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + ENDIF + + IF(( l_use_cs ).OR.( l_use_wl )) THEN + zpre(:,:) = pres_temp( q_zu(:,:), slp(:,:), zu, ptpot=t_zu(:,:), pta=zta(:,:) ) + zrhoa(:,:) = rho_air( zta(:,:), q_zu(:,:), zpre(:,:) ) + ENDIF + + IF( l_use_cs ) THEN + !! Cool-skin contribution + + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, zeta_u, Qlat=ztmp2) ! Qnsol -> ztmp1 / Tau -> zeta_u + + CALL CS_COARE( Qsw, ztmp1, u_star, zsst, ztmp2 ) ! ! Qnsol -> ztmp1 / Qlat -> ztmp2 + + T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1) + IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + ENDIF + + IF( l_use_wl ) THEN + !! Warm-layer contribution + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, zeta_u) ! Qnsol -> ztmp1 / Tau -> zeta_u + !! In WL_COARE or , Tau_ac and Qnt_ac must be updated at the final itteration step => add a flag to do this! + CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nbit,jit) ) + + !! Updating T_s and q_s !!! + T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1) + IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + ENDIF + + IF( l_use_cs .OR. l_use_wl .OR. (.NOT. l_zt_equal_zu) ) THEN + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + END DO !DO jit = 1, nbit + + ! compute transfer coefficients at zu : + ztmp0 = u_star/Ubzu + Cd = MAX( ztmp0*ztmp0 , Cx_min ) + Ch = MAX( ztmp0*t_star/dt_zu , Cx_min ) + Ce = MAX( ztmp0*q_star/dq_zu , Cx_min ) + + IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t ) + + IF(PRESENT(Cdn)) Cdn = MAX( vkarmn2 / (LOG(zu/z0 )*LOG(zu/z0 )) , Cx_min ) + IF(PRESENT(Chn)) Chn = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) + IF(PRESENT(Cen)) Cen = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) + + IF( l_use_cs .AND. PRESENT(pdT_cs) ) pdT_cs = dT_cs + IF( l_use_wl .AND. PRESENT(pdT_wl) ) pdT_wl = dT_wl + IF( l_use_wl .AND. PRESENT(pHz_wl) ) pHz_wl = Hz_wl + + IF( l_use_cs .OR. l_use_wl ) DEALLOCATE ( zsst ) + + END SUBROUTINE turb_coare3p6 + + + FUNCTION charn_coare3p6( pwnd ) + !!------------------------------------------------------------------- + !! Computes the Charnock parameter as a function of the Neutral wind speed at 10m + !! "wind speed dependent formulation" + !! (Eq. 13 in Edson et al., 2013) + !! + !! Author: L. Brodeau, July 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! neutral wind speed at 10m + ! + REAL(wp), PARAMETER :: charn0_max = 0.028 !: value above which the Charnock parameter levels off for winds > 18 m/s + !!------------------------------------------------------------------- + charn_coare3p6 = MAX( MIN( 0.0017_wp*pwnd - 0.005_wp , charn0_max) , 0._wp ) + !! + END FUNCTION charn_coare3p6 + + FUNCTION charn_coare3p6_wave( pus, pwsh, pwps ) + !!------------------------------------------------------------------- + !! Computes the Charnock parameter as a function of wave information and u* + !! + !! (COARE 3.6, Fairall et al., 2018) + !! + !! Author: L. Brodeau, October 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6_wave + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwsh ! significant wave height [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwps ! phase speed of dominant waves [m/s] + !!------------------------------------------------------------------- + charn_coare3p6_wave = ( pwsh*0.2_wp*(pus/pwps)**2.2_wp ) * grav/(pus*pus) + !! + END FUNCTION charn_coare3p6_wave + + + FUNCTION psi_m_coare( pzeta ) + !!---------------------------------------------------------------------------------- + !! ** Purpose: compute the universal profile stability function for momentum + !! COARE 3.0, Fairall et al. 2003 + !! pzeta : stability paramenter, z/L where z is altitude + !! measurement and L is M-O length + !! Stability function for wind speed and scalars matching Kansas and free + !! convection forms with weighting f convective form, follows Fairall et + !! al (1996) with profile constants from Grachev et al (2000) BLM stable + !! form from Beljaars and Holtslag (1991) + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zta = pzeta(ji,jj) + ! + zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable + ! + zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) & + & - 2.*ATAN(zphi_m) + 0.5*rpi + ! + zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective + ! + zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & + & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 + ! + zf = zta*zta + zf = zf/(1. + zf) + zc = MIN(50._wp, 0.35_wp*zta) + zstab = 0.5 + SIGN(0.5_wp, zta) + ! + psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) + & - zstab * ( 1. + 1.*zta & ! (zta > 0) + & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " + END DO ; END DO + END FUNCTION psi_m_coare + + + FUNCTION psi_h_coare( pzeta ) + !!--------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! COARE 3.0, Fairall et al. 2003 + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! Stability function for wind speed and scalars matching Kansas and free + !! convection forms with weighting f convective form, follows Fairall et + !! al (1996) with profile constants from Grachev et al (2000) BLM stable + !! form from Beljaars and Holtslag (1991) + !! + !! Author: L. Brodeau, June 2016 / AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + !!---------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zta = pzeta(ji,jj) + ! + zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable) + ! + zpsi_k = 2.*LOG((1. + zphi_h)/2.) + ! + zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective + ! + zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & + & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 + ! + zf = zta*zta + zf = zf/(1. + zf) + zc = MIN(50._wp,0.35_wp*zta) + zstab = 0.5 + SIGN(0.5_wp, zta) + ! + psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & + & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & + & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) + END DO ; END DO + END FUNCTION psi_h_coare + + !!====================================================================== +END MODULE sbcblk_algo_coare3p6 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ecmwf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ecmwf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e11d13ac0ed8d0211e58d418d02d8dcee2887180 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ecmwf.f90 @@ -0,0 +1,505 @@ + + + + + + + + + + + + + +MODULE sbcblk_algo_ecmwf + !!====================================================================== + !! *** MODULE sbcblk_algo_ecmwf *** + !! Computes: + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at 10m Ubzu + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Using the bulk formulation/param. of IFS of ECMWF (cycle 40r1) + !! based on IFS doc (avaible online on the ECMWF's website) + !! + !! Routine turb_ecmwf maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk) + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2016-02 (L.Brodeau) Original code + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! turb_ecmwf : computes the bulk turbulent transfer coefficients + !! adjusts t_air and q_air from zt to zu m + !! returns the effective bulk wind speed at 10m + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE lib_mpp, ONLY: ctl_stop ! distribued memory computing library + USE in_out_manager, ONLY: nit000 ! I/O manager + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE sbcblk_skin_ecmwf ! cool-skin/warm layer scheme !LB + USE sbcwave, ONLY : charn + USE sbc_oce, ONLY : ln_charn ! wave module + + IMPLICIT NONE + PRIVATE + + PUBLIC :: SBCBLK_ALGO_ECMWF_INIT, TURB_ECMWF + + !! ECMWF own values for given constants, taken form IFS documentation... + REAL(wp), PARAMETER, PUBLIC :: charn0_ecmwf = 0.018_wp ! Charnock constant (pretty high value here !!! + ! ! => Usually 0.011 for moderate winds) + REAL(wp), PARAMETER :: zi0 = 1000. ! scale height of the atmospheric boundary layer...1 + REAL(wp), PARAMETER :: Beta0 = 1. ! gustiness parameter ( = 1.25 in COAREv3) + REAL(wp), PARAMETER :: alpha_M = 0.11 ! For roughness length (smooth surface term) + REAL(wp), PARAMETER :: alpha_H = 0.40 ! (Chapter 3, p.34, IFS doc Cy31r1) + REAL(wp), PARAMETER :: alpha_Q = 0.62 ! + + !! * Substitutions + + + + + + !!---------------------------------------------------------------------- +CONTAINS + + + SUBROUTINE sbcblk_algo_ecmwf_init(l_use_cs, l_use_wl) + !!--------------------------------------------------------------------- + !! *** FUNCTION sbcblk_algo_ecmwf_init *** + !! + !! INPUT : + !! ------- + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !!--------------------------------------------------------------------- + LOGICAL , INTENT(in) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in) :: l_use_wl ! use the warm-layer parameterization + INTEGER :: ierr + !!--------------------------------------------------------------------- + IF( l_use_wl ) THEN + ierr = 0 + ALLOCATE ( dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_ECMWF_INIT => allocation of dT_wl & Hz_wl failed!' ) + dT_wl(:,:) = 0._wp + Hz_wl(:,:) = rd0 ! (rd0, constant, = 3m is default for Zeng & Beljaars) + ENDIF + IF( l_use_cs ) THEN + ierr = 0 + ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_ECMWF_INIT => allocation of dT_cs failed!' ) + dT_cs(:,:) = -0.25_wp ! First guess of skin correction + ENDIF + END SUBROUTINE sbcblk_algo_ecmwf_init + + + + SUBROUTINE turb_ecmwf( kt, zt, zu, T_s, t_zt, q_s, q_zt, U_zu, l_use_cs, l_use_wl, & + & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & + & nb_iter, Cdn, Chn, Cen, & ! optional output + & Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer) + & pdT_wl, pHz_wl ) ! optionals for warm-layer only + !!---------------------------------------------------------------------------------- + !! *** ROUTINE turb_ecmwf *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to IFS doc. (cycle 45r1) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! Applies the cool-skin warm-layer correction of the SST to T_s + !! if the net shortwave flux at the surface (Qsw), the downwelling longwave + !! radiative fluxes at the surface (rad_lw), and the sea-leve pressure (slp) + !! are provided as (optional) arguments! + !! + !! INPUT : + !! ------- + !! * kt : current time step (starts at 1) + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * t_zt : potential air temperature at zt [K] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !! + !! INPUT/OUTPUT: + !! ------------- + !! * T_s : always "bulk SST" as input [K] + !! -> unchanged "bulk SST" as output if CSWL not used [K] + !! -> skin temperature as output if CSWL used [K] + !! + !! * q_s : SSQ aka saturation specific humidity at temp. T_s [kg/kg] + !! -> doesn't need to be given a value if skin temp computed (in case l_use_cs=True or l_use_wl=True) + !! -> MUST be given the correct value if not computing skint temp. (in case l_use_cs=False or l_use_wl=False) + !! + !! OPTIONAL INPUT: + !! --------------- + !! * Qsw : net solar flux (after albedo) at the surface (>0) [W/m^2] + !! * rad_lw : downwelling longwave radiation at the surface (>0) [W/m^2] + !! * slp : sea-level pressure [Pa] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * pdT_cs : SST increment "dT" for cool-skin correction [K] + !! * pdT_wl : SST increment "dT" for warm-layer correction [K] + !! * pHz_wl : thickness of warm-layer [m] + !! + !! OUTPUT : + !! -------- + !! * Cd : drag coefficient + !! * Ch : sensible heat coefficient + !! * Ce : evaporation coefficient + !! * t_zu : pot. air temperature adjusted at wind height zu [K] + !! * q_zu : specific humidity of air // [kg/kg] + !! * Ubzu : bulk wind speed at zu [m/s] + !! + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! current time step + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + ! + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + ! + INTEGER :: nbit, jit + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + ! + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu + REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(jpi,jpj) :: Linv !: 1/L (inverse of Monin Obukhov length... + REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t, z0q + REAL(wp), DIMENSION(jpi,jpj) :: zrhoa, zpre, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + ! + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST + ! + REAL(wp), DIMENSION(jpi,jpj) :: func_m, func_h + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ecmwf@sbcblk_algo_ecmwf.F90' + !!---------------------------------------------------------------------------------- + IF( kt == nit000 ) CALL SBCBLK_ALGO_ECMWF_INIT(l_use_cs, l_use_wl) + + nbit = nb_iter0 + IF( PRESENT(nb_iter) ) nbit = nb_iter + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision + + !! Initializations for cool skin and warm layer: + IF( l_use_cs .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use cool-skin param!' ) + + IF( l_use_wl .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' ) + + IF( l_use_cs .OR. l_use_wl ) THEN + ALLOCATE ( zsst(jpi,jpj) ) + zsst = T_s ! backing up the bulk SST + IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction + q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s + ENDIF + + + ! Identical first gess as in COARE, with IFS parameter values though... + ! + !! First guess of temperature and humidity at height zu: + t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... + q_zu = MAX( q_zt , 1.e-6_wp ) ! " + + !! Pot. temp. difference (and we don't want it to be 0!) + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + znu_a = visc_air(t_zu) ! Air viscosity (m^2/s) at zt given from temperature in (K) + + Ubzu = SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution + + ztmp0 = LOG( zu*10000._wp) ! optimization: 10000. == 1/z0 (with z0 first guess == 0.0001) + ztmp1 = LOG(10._wp*10000._wp) ! " " " + u_star = 0.035_wp*Ubzu*ztmp1/ztmp0 ! (u* = 0.035*Un10) + + IF (ln_charn) THEN ! Charnock value if wave coupling + z0 = charn*u_star*u_star/grav + 0.11_wp*znu_a/u_star + ELSE + z0 = charn0_ecmwf*u_star*u_star/grav + 0.11_wp*znu_a/u_star + ENDIF + z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + z0t = 1._wp / ( 0.1_wp*EXP(vkarmn/(0.00115/(vkarmn/ztmp1))) ) + z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + Cd = MAX( (vkarmn/ztmp0)**2 , Cx_min ) ! first guess of Cd + + ztmp0 = vkarmn2/LOG(zt/z0t)/Cd + + ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) + + !! First estimate of zeta_u, depending on the stability, ie sign of BRN (ztmp2): + ztmp1 = 0.5 + SIGN( 0.5_wp , ztmp2 ) + func_h = (1._wp - ztmp1) * ztmp0*ztmp2 / (1._wp - ztmp2*zi0*0.004_wp*Beta0**3/zu) & ! BRN < 0 + & + ztmp1 * ( ztmp0*ztmp2 + 27._wp/9._wp*ztmp2*ztmp2 ) ! BRN > 0 + + !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L + ztmp0 = vkarmn/(LOG(zu/z0t) - psi_h_ecmwf(func_h)) + + u_star = MAX ( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_ecmwf(func_h)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) + t_star = dt_zu*ztmp0 + q_star = dq_zu*ztmp0 + + ! What needs to be done if zt /= zu: + IF( .NOT. l_zt_equal_zu ) THEN + !! First update of values at zu (or zt for wind) + ztmp0 = psi_h_ecmwf(func_h) - psi_h_ecmwf(zt*func_h/zu) ! zt*func_h/zu == zeta_t + ztmp1 = LOG(zt/zu) + ztmp0 + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + q_zu = (0.5_wp + SIGN(0.5_wp,q_zu))*q_zu !Makes it impossible to have negative humidity : + ! + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + + !! => that was same first guess as in COARE... + + + !! First guess of inverse of Obukov length (1/L) : + Linv = One_on_L( t_zu, q_zu, u_star, t_star, q_star ) + + !! Functions such as u* = Ubzu*vkarmn/func_m + ztmp0 = zu*Linv + func_m = LOG(zu) - LOG(z0) - psi_m_ecmwf(ztmp0) + psi_m_ecmwf( z0*Linv) + func_h = LOG(zu) - LOG(z0t) - psi_h_ecmwf(ztmp0) + psi_h_ecmwf(z0t*Linv) + + !! ITERATION BLOCK + DO jit = 1, nbit + + !! Bulk Richardson Number at z=zu (Eq. 3.25) + ztmp0 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) + + !! New estimate of the inverse of the Obukhon length (Linv == zeta/zu) : + Linv = ztmp0*func_m*func_m/func_h / zu ! From Eq. 3.23, Chap.3.2.3, IFS doc - Cy40r1 + !! Note: it is slightly different that the L we would get with the usual + Linv = SIGN( MIN(ABS(Linv),200._wp), Linv ) ! (prevent FPE from stupid values from masked region later on...) + + !! Update func_m with new Linv: + func_m = LOG(zu) -LOG(z0) - psi_m_ecmwf(zu*Linv) + psi_m_ecmwf(z0*Linv) ! LB: should be "zu+z0" rather than "zu" alone, but z0 is tiny wrt zu! + + !! Need to update roughness lengthes: + u_star = Ubzu*vkarmn/func_m + ztmp2 = u_star*u_star + ztmp1 = znu_a/u_star + IF (ln_charn) THEN ! Charnock value if wave coupling + z0 = MIN( ABS( alpha_M*ztmp1 + charn*ztmp2/grav ) , 0.001_wp) + ELSE + z0 = MIN( ABS( alpha_M*ztmp1 + charn0_ecmwf*ztmp2/grav ) , 0.001_wp) + ENDIF + z0 = MIN( ABS( alpha_M*ztmp1 + charn0_ecmwf*ztmp2/grav ) , 0.001_wp) + z0t = MIN( ABS( alpha_H*ztmp1 ) , 0.001_wp) ! eq.3.26, Chap.3, p.34, IFS doc - Cy31r1 + z0q = MIN( ABS( alpha_Q*ztmp1 ) , 0.001_wp) + + !! Update wind at zu with convection-related wind gustiness in unstable conditions (Chap. 3.2, IFS doc - Cy40r1, Eq.3.17 and Eq.3.18 + Eq.3.8) + ztmp2 = Beta0*Beta0*ztmp2*(MAX(-zi0*Linv/vkarmn,0._wp))**(2._wp/3._wp) ! square of wind gustiness contribution (combining Eq. 3.8 and 3.18, hap.3, IFS doc - Cy31r1) + !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before zi0 + Ubzu = MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed + ! => 0.2 prevents Ubzu to be 0 in stable case when U_zu=0. + + + !! Need to update "theta" and "q" at zu in case they are given at different heights + !! as well the air-sea differences: + IF( .NOT. l_zt_equal_zu ) THEN + !! Arrays func_m and func_h are free for a while so using them as temporary arrays... + func_h = psi_h_ecmwf(zu*Linv) ! temporary array !!! + func_m = psi_h_ecmwf(zt*Linv) ! temporary array !!! + + ztmp2 = psi_h_ecmwf(z0t*Linv) + ztmp0 = func_h - ztmp2 + ztmp1 = vkarmn/(LOG(zu) - LOG(z0t) - ztmp0) + t_star = dt_zu*ztmp1 + ztmp2 = ztmp0 - func_m + ztmp2 + ztmp1 = LOG(zt/zu) + ztmp2 + t_zu = t_zt - t_star/vkarmn*ztmp1 + + ztmp2 = psi_h_ecmwf(z0q*Linv) + ztmp0 = func_h - ztmp2 + ztmp1 = vkarmn/(LOG(zu) - LOG(z0q) - ztmp0) + q_star = dq_zu*ztmp1 + ztmp2 = ztmp0 - func_m + ztmp2 + ztmp1 = LOG(zt/zu) + ztmp2 + q_zu = q_zt - q_star/vkarmn*ztmp1 + ENDIF + + !! Updating because of updated z0 and z0t and new Linv... + ztmp0 = zu*Linv + func_m = log(zu) - LOG(z0 ) - psi_m_ecmwf(ztmp0) + psi_m_ecmwf(z0 *Linv) + func_h = log(zu) - LOG(z0t) - psi_h_ecmwf(ztmp0) + psi_h_ecmwf(z0t*Linv) + + IF(( l_use_cs ).OR.( l_use_wl )) THEN + zpre(:,:) = pres_temp( q_zu(:,:), slp(:,:), zu, ptpot=t_zu(:,:), pta=zta(:,:) ) + zrhoa(:,:) = rho_air( zta(:,:), q_zu(:,:), zpre(:,:) ) + ENDIF + + IF( l_use_cs ) THEN + !! Cool-skin contribution + + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, ztmp0, Qlat=ztmp2) ! Qnsol -> ztmp1 / Tau -> ztmp0 + + CALL CS_ECMWF( Qsw, ztmp1, u_star, zsst ) ! Qnsol -> ztmp1 + + T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1) + IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + + ENDIF + + IF( l_use_wl ) THEN + !! Warm-layer contribution + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, ztmp2) ! Qnsol -> ztmp1 / Tau -> ztmp2 + CALL WL_ECMWF( Qsw, ztmp1, u_star, zsst ) + !! Updating T_s and q_s !!! + T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1) ! + IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + ENDIF + + IF( l_use_cs .OR. l_use_wl .OR. (.NOT. l_zt_equal_zu) ) THEN + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + END DO !DO jit = 1, nbit + + Cd = MAX( vkarmn2/(func_m*func_m) , Cx_min ) + Ch = MAX( vkarmn2/(func_m*func_h) , Cx_min ) + ztmp2 = LOG(zu/z0q) - psi_h_ecmwf(zu*Linv) + psi_h_ecmwf(z0q*Linv) ! func_q + Ce = MAX( vkarmn2/(func_m*ztmp2) , Cx_min ) + + IF(PRESENT(Cdn)) Cdn = MAX( vkarmn2 / (LOG(zu/z0 )*LOG(zu/z0 )) , Cx_min ) + IF(PRESENT(Chn)) Chn = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) + IF(PRESENT(Cen)) Cen = MAX( vkarmn2 / (LOG(zu/z0q)*LOG(zu/z0q)) , Cx_min ) + + IF( l_use_cs .AND. PRESENT(pdT_cs) ) pdT_cs = dT_cs + IF( l_use_wl .AND. PRESENT(pdT_wl) ) pdT_wl = dT_wl + IF( l_use_wl .AND. PRESENT(pHz_wl) ) pHz_wl = Hz_wl + + IF( l_use_cs .OR. l_use_wl ) DEALLOCATE ( zsst ) + + END SUBROUTINE turb_ecmwf + + + FUNCTION psi_m_ecmwf( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for momentum + !! ECMWF / as in IFS cy31r1 documentation, available online + !! at ecmwf.int + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ecmwf + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zx, ztmp, zpsi_unst, zpsi_stab, zstab, zc + !!---------------------------------------------------------------------------------- + zc = 5._wp/0.35_wp + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!): + + ! *** Unstable (Paulson 1970) [eq.3.20, Chap.3, p.33, IFS doc - Cy31r1] : + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 - 16z)^0.5 + zx = SQRT(zx2) ! (1 - 16z)^0.25 + ztmp = 1._wp + zx + zpsi_unst = LOG( 0.125_wp*ztmp*ztmp*(1._wp + zx2) ) - 2._wp*ATAN( zx ) + 0.5_wp*rpi + + ! *** Stable [eq.3.22, Chap.3, p.33, IFS doc - Cy31r1] : + zpsi_stab = -2._wp/3._wp*(zta - zc)*EXP(-0.35_wp*zta) & + & - zta - 2._wp/3._wp*zc + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_m_ecmwf(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END DO ; END DO + END FUNCTION psi_m_ecmwf + + + FUNCTION psi_h_ecmwf( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! ECMWF / as in IFS cy31r1 documentation, available online + !! at ecmwf.int + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ecmwf + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab, zc + !!---------------------------------------------------------------------------------- + zc = 5._wp/0.35_wp + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zta = MIN(pzeta(ji,jj) , 5._wp) ! Very stable conditions (L positif and big!): + ! + ! *** Unstable (Paulson 1970) [eq.3.20, Chap.3, p.33, IFS doc - Cy31r1] : + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 -16z)^0.5 + zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) + ! + ! *** Stable [eq.3.22, Chap.3, p.33, IFS doc - Cy31r1] : + zpsi_stab = -2._wp/3._wp*(zta - zc)*EXP(-0.35_wp*zta) & + & - ABS(1._wp + 2._wp/3._wp*zta)**1.5_wp - 2._wp/3._wp*zc + 1._wp + ! + ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution... + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_h_ecmwf(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END DO ; END DO + END FUNCTION psi_h_ecmwf + + + !!====================================================================== +END MODULE sbcblk_algo_ecmwf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_an05.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_an05.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b9a428c7bbb5567e14f8be985ba9ee81b9a37307 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_an05.f90 @@ -0,0 +1,405 @@ + + + + + + + + + + + + + +MODULE sbcblk_algo_ice_an05 + !!====================================================================== + !! *** MODULE sbcblk_algo_ice_an05 *** + !! Computes turbulent components of surface fluxes over sea-ice + !! + !! Andreas, E.L., Jordan, R.E. & Makshtas, A.P. Parameterizing turbulent exchange over sea ice: the ice station weddell results. + !! Boundary-Layer Meteorology 114, 439–460 (2005). https://doi.org/10.1007/s10546-004-1414-7 + !! + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (usually 2m) to zu (usually 10m) if needed + !! * the "effective" bulk wind speed at zu: Ub (including gustiness contribution in unstable conditions) + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Routine turb_ice_an05 maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !! + !! Author: Laurent Brodeau, Summer 2020 + !! + !!---------------------------------------------------------------------- + USE par_kind, ONLY: wp + USE par_oce, ONLY: jpi, jpj, Nis0, Nie0, Njs0, Nje0, nn_hls, ntsi, ntsj, ntei, ntej + USE lib_mpp, ONLY: ctl_stop ! distribued memory computing library + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + IMPLICIT NONE + PRIVATE + + PUBLIC :: turb_ice_an05 + + INTEGER , PARAMETER :: nbit = 8 ! number of itterations + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_ice_an05( zt, zu, Ts_i, t_zt, qs_i, q_zt, U_zu, & + & Cd_i, Ch_i, Ce_i, t_zu_i, q_zu_i, & + & CdN, ChN, CeN, xz0, xu_star, xL, xUN10 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE turb_ice_an05 *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to: + !! Andreas, E.L., Jordan, R.E. & Makshtas, A.P. Parameterizing turbulent exchange over sea ice: the ice station weddell results. + !! Boundary-Layer Meteorology 114, 439–460 (2005). https://doi.org/10.1007/s10546-004-1414-7 + !! + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * Ts_i : surface temperature of sea-ice [K] + !! * t_zt : potential air temperature at zt [K] + !! * qs_i : saturation specific humidity at temp. Ts_i over ice [kg/kg] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! + !! OUTPUT : + !! -------- + !! * Cd_i : drag coefficient over sea-ice + !! * Ch_i : sensible heat coefficient over sea-ice + !! * Ce_i : sublimation coefficient over sea-ice + !! * t_zu_i : pot. air temp. adjusted at zu over sea-ice [K] + !! * q_zu_i : spec. hum. of air adjusted at zu over sea-ice [kg/kg] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * CdN : neutral-stability drag coefficient + !! * ChN : neutral-stability sensible heat coefficient + !! * CeN : neutral-stability evaporation coefficient + !! * xz0 : return the aerodynamic roughness length (integration constant for wind stress) [m] + !! * xu_star : return u* the friction velocity [m/s] + !! * xL : return the Obukhov length [m] + !! * xUN10 : neutral wind speed at 10m [m/s] + !! + !! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp0, ztmp1, ztmp2 ! temporary stuff + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: z0, dt_zu, dq_zu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: u_star, t_star, q_star + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: znu_a !: Nu_air = kinematic viscosity of air + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_u, zeta_t ! stability parameter at height zu + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: z0tq + !! + INTEGER :: jit + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + !! + LOGICAL :: lreturn_cdn=.FALSE., lreturn_chn=.FALSE., lreturn_cen=.FALSE. + LOGICAL :: lreturn_z0=.FALSE., lreturn_ustar=.FALSE., lreturn_L=.FALSE., lreturn_UN10=.FALSE. + !! + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_an05@sbcblk_algo_ice_an05.f90' + !!---------------------------------------------------------------------------------- + ALLOCATE ( Ubzu(jpi,jpj), u_star(jpi,jpj), t_star(jpi,jpj), q_star(jpi,jpj), & + & zeta_u(jpi,jpj), dt_zu(jpi,jpj), dq_zu(jpi,jpj), & + & znu_a(jpi,jpj), ztmp1(jpi,jpj), ztmp2(jpi,jpj), & + & z0(jpi,jpj), z0tq(jpi,jpj,2), ztmp0(jpi,jpj) ) + + lreturn_cdn = PRESENT(CdN) + lreturn_chn = PRESENT(ChN) + lreturn_cen = PRESENT(CeN) + lreturn_z0 = PRESENT(xz0) + lreturn_ustar = PRESENT(xu_star) + lreturn_L = PRESENT(xL) + lreturn_UN10 = PRESENT(xUN10) + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) + IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) + + !! Scalar wind speed cannot be below 0.2 m/s + Ubzu = MAX( U_zu, wspd_thrshld_ice ) + + !! First guess of temperature and humidity at height zu: + t_zu_i = MAX( t_zt , 100._wp ) ! who knows what's given on masked-continental regions... + q_zu_i = MAX( q_zt , 0.1e-6_wp ) ! " + + !! Air-Ice differences (and we don't want it to be 0!) + dt_zu = t_zu_i - Ts_i ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu_i - qs_i ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + znu_a = visc_air(t_zu_i) ! Air viscosity (m^2/s) at zt given from temperature in (K) + + !! Very crude first guesses of z0: + z0 = 8.0E-4_wp + + !! Crude first guess of turbulent scales + u_star = 0.035_wp*Ubzu*LOG( 10._wp/z0 )/LOG( zu/z0 ) + z0 = rough_leng_m( u_star , znu_a ) + + DO jit = 1, 2 + u_star = MAX ( Ubzu*vkarmn/(LOG(zu) - LOG(z0)) , 1.E-9 ) + z0 = rough_leng_m( u_star , znu_a ) + END DO + + z0tq = rough_leng_tq( z0, u_star , znu_a ) + t_star = dt_zu*vkarmn/(LOG(zu/z0tq(:,:,1))) + q_star = dq_zu*vkarmn/(LOG(zu/z0tq(:,:,2))) + + + !! ITERATION BLOCK + DO jit = 1, nbit + + !!Inverse of Obukov length (1/L) : + ztmp0 = One_on_L(t_zu_i, q_zu_i, u_star, t_star, q_star) ! 1/L == 1/[Obukhov length] + ztmp0 = SIGN( MIN(ABS(ztmp0),200._wp), ztmp0 ) ! (prevents FPE from stupid values from masked region later on...) + + !! Stability parameters "zeta" : + zeta_u = zu*ztmp0 + zeta_u = SIGN( MIN(ABS(zeta_u),50.0_wp), zeta_u ) + IF( .NOT. l_zt_equal_zu ) THEN + zeta_t = zt*ztmp0 + zeta_t = SIGN( MIN(ABS(zeta_t),50.0_wp), zeta_t ) + END IF + + !! Roughness lengthes z0, z0t, & z0q : + z0 = rough_leng_m ( u_star , znu_a ) + z0tq = rough_leng_tq( z0, u_star , znu_a ) + + !! Turbulent scales at zu : + ztmp0 = psi_h_ice(zeta_u) + t_star = dt_zu*vkarmn/(LOG(zu) - LOG(z0tq(:,:,1)) - ztmp0) + q_star = dq_zu*vkarmn/(LOG(zu) - LOG(z0tq(:,:,2)) - ztmp0) + u_star = MAX( Ubzu*vkarmn/(LOG(zu) - LOG(z0(:,:)) - psi_m_ice(zeta_u)) , 1.E-9 ) + + IF( .NOT. l_zt_equal_zu ) THEN + !! Re-updating temperature and humidity at zu if zt /= zu : + ztmp1 = LOG(zt/zu) + ztmp0 - psi_h_ice(zeta_t) + t_zu_i = t_zt - t_star/vkarmn*ztmp1 + q_zu_i = q_zt - q_star/vkarmn*ztmp1 + dt_zu = t_zu_i - Ts_i ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu_i - qs_i ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + END IF + + END DO !DO jit = 1, nbit + + ! compute transfer coefficients at zu : + ztmp0 = u_star/Ubzu + Cd_i = ztmp0*ztmp0 + Ch_i = ztmp0*t_star/dt_zu + Ce_i = ztmp0*q_star/dq_zu + + IF( lreturn_cdn .OR. lreturn_chn .OR. lreturn_cen ) ztmp0 = 1._wp/LOG( zu/z0(:,:) ) + IF( lreturn_cdn ) CdN = vkarmn2*ztmp0*ztmp0 + IF( lreturn_chn ) ChN = vkarmn2*ztmp0/LOG(zu/z0tq(:,:,1)) + IF( lreturn_cen ) CeN = vkarmn2*ztmp0/LOG(zu/z0tq(:,:,2)) + + IF( lreturn_z0 ) xz0 = z0 + IF( lreturn_ustar ) xu_star = u_star + IF( lreturn_L ) xL = 1./One_on_L(t_zu_i, q_zu_i, u_star, t_star, q_star) + IF( lreturn_UN10 ) xUN10 = u_star/vkarmn*LOG(10./z0) + + DEALLOCATE ( Ubzu, u_star, t_star, q_star, zeta_u, dt_zu, dq_zu, z0, z0tq, znu_a, ztmp0, ztmp1, ztmp2 ) + IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t ) + + END SUBROUTINE turb_ice_an05 + + + + FUNCTION rough_leng_m( pus , pnua ) + !!---------------------------------------------------------------------------------- + !! Computes the roughness length of sea-ice according to Andreas et al. 2005, (eq. 19) + !! + !! Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: rough_leng_m ! roughness length over sea-ice [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] + !! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zus, zz + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zus = MAX( pus(ji,jj) , 1.E-9_wp ) + + zz = (zus - 0.18_wp) / 0.1_wp + + rough_leng_m(ji,jj) = 0.135*pnua(ji,jj)/zus + 0.035*zus*zus/grav*( 5.*EXP(-zz*zz) + 1._wp ) ! Eq.(19) Andreas et al., 2005 + END DO ; END DO + !! + END FUNCTION rough_leng_m + + FUNCTION rough_leng_tq( pz0, pus , pnua ) + !!---------------------------------------------------------------------------------- + !! Computes the roughness length of sea-ice according to Andreas et al. 2005, (eq. 22) + !! => which still relies on Andreas 1987 ! + !! + !! Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,2) :: rough_leng_tq ! temp.,hum. roughness lengthes over sea-ice [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 ! roughness length [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] + !! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zz0, zus, zre, zsmoot, ztrans, zrough + REAL(wp) :: zb0, zb1, zb2, zlog, zlog2, zlog_z0s_on_z0 + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zz0 = pz0(ji,jj) + zus = MAX( pus(ji,jj) , 1.E-9_wp ) + zre = MAX( zus*zz0/pnua(ji,jj) , 0._wp ) ! Roughness Reynolds number + + !! *** TABLE 1 of Andreas et al. 2005 *** + zsmoot = 0._wp ; ztrans = 0._wp ; zrough = 0._wp + IF ( zre <= 0.135_wp ) THEN ! Smooth flow condition (R* <= 0.135): + zsmoot = 1._wp + ELSEIF( zre < 2.5_wp ) THEN ! Transition (0.135 < R* < 2.5) + ztrans = 1._wp + ELSE ! Rough ( R* > 2.5) + zrough = 1._wp + ENDIF + + zlog = LOG(zre) + zlog2 = zlog*zlog + + !! z0t: + zb0 = zsmoot*1.25_wp + ztrans*0.149_wp + zrough*0.317_wp + zb1 = - ztrans*0.550_wp - zrough*0.565_wp + zb2 = - zrough*0.183_wp + zlog_z0s_on_z0 = zb0 + zb1*zlog + zb2*zlog2 + rough_leng_tq(ji,jj,1) = zz0 * EXP( zlog_z0s_on_z0 ) + + !! z0q: + zb0 = zsmoot*1.61_wp + ztrans*0.351_wp + zrough*0.396_wp + zb1 = - ztrans*0.628_wp - zrough*0.512_wp + zb2 = - zrough*0.180_wp + zlog = LOG(zre) + zlog_z0s_on_z0 = zb0 + zb1*zlog + zb2*zlog2 + rough_leng_tq(ji,jj,2) = zz0 * EXP( zlog_z0s_on_z0 ) + + END DO ; END DO + !! + END FUNCTION rough_leng_tq + + + + FUNCTION psi_m_ice( pzeta ) + !!---------------------------------------------------------------------------------- + !! ** Purpose: compute the universal profile stability function for momentum + !! + !! + !! Andreas et al 2005 == Jordan et al. 1999 + !! + !! Psi: + !! Unstable => Paulson 1970 + !! Stable => Holtslag & De Bruin 1988 + !! + !! pzeta : stability paramenter, z/L where z is altitude + !! measurement and L is M-O length + !! + !! ** Author: L. Brodeau, 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ice + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx, zpsi_u, zpsi_s, zstab + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! + zta = pzeta(ji,jj) + ! + ! Unstable stratification: + zx = ABS(1._wp - 16._wp*zta)**.25 ! (16 here, not 15!) + + zpsi_u = LOG( (1._wp + zx*zx)/2. ) & ! Eq.(30) Jordan et al. 1999 + & + 2.*LOG( (1._wp + zx )/2. ) & + & - 2.*ATAN( zx ) + 0.5*rpi + + ! Stable stratification: + zpsi_s = - ( 0.7_wp*zta + 0.75_wp*(zta - 14.3_wp)*EXP( -0.35*zta) + 10.7_wp ) ! Eq.(33) Jordan et al. 1999 + + !! Combine: + zstab = 0.5 + SIGN(0.5_wp, zta) + psi_m_ice(ji,jj) = (1._wp - zstab) * zpsi_u & ! Unstable (zta < 0) + & + zstab * zpsi_s ! Stable (zta > 0) + ! + END DO ; END DO + END FUNCTION psi_m_ice + + + FUNCTION psi_h_ice( pzeta ) + !!---------------------------------------------------------------------------------- + !! ** Purpose: compute the universal profile stability function for + !! temperature and humidity + !! + !! + !! Andreas et al 2005 == Jordan et al. 1999 + !! + !! Psi: + !! Unstable => Paulson 1970 + !! Stable => Holtslag & De Bruin 1988 + !! + !! pzeta : stability paramenter, z/L where z is altitude + !! measurement and L is M-O length + !! + !! ** Author: L. Brodeau, 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ice + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx, zpsi_u, zpsi_s, zstab + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! + zta = pzeta(ji,jj) + ! + ! Unstable stratification: + zx = ABS(1._wp - 16._wp*zta)**.25 ! (16 here, not 15!) + + zpsi_u = 2.*LOG( (1._wp + zx*zx)/2. ) ! Eq.(31) Jordan et al. 1999 + + ! Stable stratification (identical to Psi_m!): + zpsi_s = - ( 0.7_wp*zta + 0.75_wp*(zta - 14.3_wp)*EXP( -0.35*zta) + 10.7_wp ) ! Eq.(33) Jordan et al. 1999 + + !! Combine: + zstab = 0.5 + SIGN(0.5_wp, zta) + psi_h_ice(ji,jj) = (1._wp - zstab) * zpsi_u & ! Unstable (zta < 0) + & + zstab * zpsi_s ! Stable (zta > 0) + ! + END DO ; END DO + END FUNCTION psi_h_ice + + !!====================================================================== +END MODULE sbcblk_algo_ice_an05 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_cdn.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_cdn.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f66b7d64cc60024f1dc18d4fa294e4f4e6116e91 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_cdn.f90 @@ -0,0 +1,311 @@ + + + + + + + + + + + + + +! AeroBulk / 2020 / L. Brodeau +! +! When using AeroBulk to produce scientific work, please acknowledge with the following citation: +! +! Brodeau, L., B. Barnier, S. Gulev, and C. Woods, 2016: Climatologically +! significant effects of some approximations in the bulk parameterizations of +! turbulent air-sea fluxes. J. Phys. Oceanogr., doi:10.1175/JPO-D-16-0169.1. +! +! +MODULE sbcblk_algo_ice_cdn + !!==================================================================================== + !! Author: Laurent Brodeau, January 2020 + !!==================================================================================== + USE par_kind, ONLY: wp + USE par_oce, ONLY: jpi, jpj, Nis0, Nie0, Njs0, Nje0, nn_hls, ntsi, ntsj, ntei, ntej + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + IMPLICIT NONE + PRIVATE + + PUBLIC :: CdN10_f_LU12, CdN_f_LU12_eq36, CdN10_f_LU13, CdN_f_LG15, CdN_f_LG15_light + + REAL(wp), PARAMETER :: rCe_0 = 2.23E-3_wp !LOLO: this one can be more accurate when sea-ice data => Lupkes et al (2013), Eq.(1) + REAL(wp), PARAMETER :: rNu_0 = 1._wp + REAL(wp), PARAMETER :: rMu_0 = 1._wp + REAL(wp), PARAMETER :: rbeta_0 = 1.4_wp ! (Eq.47) MIZ + + REAL(wp), PARAMETER :: rhmin_0 = 0.286_wp ! Eq.(25) + REAL(wp), PARAMETER :: rhmax_0 = 0.534_wp ! Eq.(25) + REAL(wp), PARAMETER :: rDmin_0 = 8._wp ! Eq.(27) + REAL(wp), PARAMETER :: rDmax_0 = 300._wp ! Eq.(27) + REAL(wp), PARAMETER :: rz0_w_0 = 3.27E-4 ! fixed roughness length over water (paragraph below Eq.36) + + !!============================================================ + REAL(wp), PARAMETER :: rce10_i_0 = 3.46e-3_wp ! (Eq.48) MIZ + REAL(wp), PARAMETER :: ralpha_0 = 0.2_wp ! (Eq.12) (ECHAM6 value) + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- +CONTAINS + + + FUNCTION CdN10_f_LU12( pfrice, pz0w, pSc, phf, pDi ) + !!---------------------------------------------------------------------- + !! *** ROUTINE CdN10_f_LU12 *** + !! + !! GENERAL FORM OF EQUATION 22 of Lupkes et al. 2012 + !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !! + !! ** Purpose : Computes the "form" contribution of the neutral air-ice + !! drag referenced at 10m to make it dependent on edges at + !! leads, melt ponds and flows (to be added to the "skin" + !! contribution. After some + !! approximations, this can be resumed to a dependency on + !! ice concentration. + !! + !! ** References : Lupkes et al. JGR 2012 (theory) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: CdN10_f_LU12 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc, phf and pDi all provided... + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0w ! roughness length over water [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pSc ! shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m] + !!---------------------------------------------------------------------- + LOGICAL :: l_known_Sc=.FALSE., l_known_hf=.FALSE., l_known_Di=.FALSE. + REAL(wp) :: ztmp, zrlog, zfri, zfrw, zSc, zhf, zDi + INTEGER :: ji, jj + !!---------------------------------------------------------------------- + l_known_Sc = PRESENT(pSc) + l_known_hf = PRESENT(phf) + l_known_Di = PRESENT(pDi) + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + + zfri = pfrice(ji,jj) + zfrw = (1._wp - zfri) + + IF(l_known_Sc) THEN + zSc = pSc(ji,jj) + ELSE + !! Sc parameterized in terms of A (ice fraction): + zSc = zfrw**(1._wp / ( 10._wp * rBeta_0 )) ! Eq.(31) + END IF + + IF(l_known_hf) THEN + zhf = phf(ji,jj) + ELSE + !! hf parameterized in terms of A (ice fraction): + zhf = rhmax_0*zfri + rhmin_0*zfrw ! Eq.(25) + END IF + + IF(l_known_Di) THEN + zDi = pDi(ji,jj) + ELSE + !! Di parameterized in terms of A (ice fraction): + ztmp = 1._wp / ( 1._wp - (rDmin_0/rDmax_0)**(1._wp/rBeta_0) ) ! A* Eq.(27) + zDi = rDmin_0 * ( ztmp/(ztmp - zfri) )**rBeta_0 ! Eq.(26) + END IF + + ztmp = 1._wp/pz0w(ji,jj) + zrlog = LOG(zhf*ztmp) / LOG(10._wp*ztmp) + + CdN10_f_LU12(ji,jj) = 0.5_wp* 0.3_wp * zrlog*zrlog * zSc*zSc * zhf/zDi * zfri ! Eq.(22) + !! 1/2 Ce + + END DO ; END DO + END FUNCTION CdN10_f_LU12 + + + FUNCTION CdN_f_LU12_eq36( pzu, pfrice ) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LU12_eq36 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), INTENT(in) :: pzu ! reference height [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc, phf and pDi all provided... + !!---------------------------------------------------------------------- + REAL(wp) :: ztmp, zrlog, zfri, zhf, zDi + INTEGER :: ji, jj + !!---------------------------------------------------------------------- + !zhf = 0.28 ! h_fc + zhf = 0.41 ! h_fc + zDi = rDmin_0 + + ztmp = 1._wp/rz0_w_0 + zrlog = LOG(zhf*ztmp) / LOG(pzu*ztmp) + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zfri = pfrice(ji,jj) + CdN_f_LU12_eq36(ji,jj) = 0.5_wp* 0.3_wp * zrlog*zrlog * zhf/zDi * (1._wp - zfri)**rBeta_0 ! Eq.(35) & (36) + !! 1/2 Ce + END DO ; END DO + END FUNCTION CdN_f_LU12_eq36 + + + FUNCTION CdN10_f_LU13( pfrice ) + !!---------------------------------------------------------------------- + !! *** ROUTINE CdN10_f_LU13 *** + !! + !! ** Purpose : Computes the "form" contribution of the neutral air-ice + !! drag referenced at 10m to make it dependent on edges at + !! leads, melt ponds and flows (to be added to the "skin" + !! contribution. After some + !! approximations, this can be resumed to a dependency on + !! ice concentration. + !! + !! ** Method : The parameterization is taken from Lupkes et al. (2012) eq.(50) + !! with the highest level of approximation: level4, eq.(59) + !! The generic drag over a cell partly covered by ice can be re-written as follows: + !! + !! Cd = Cdw * (1-A) + Cdi * A + Ce * (1-A)**(nu+1/(10*beta)) * A**mu + !! + !! Ce = 2.23e-3 , as suggested by Lupkes (eq. 59) + !! nu = mu = beta = 1 , as suggested by Lupkes (eq. 59) + !! A is the concentration of ice minus melt ponds (if any) + !! + !! This new drag has a parabolic shape (as a function of A) starting at + !! Cdw(say 1.5e-3) for A=0, reaching 1.97e-3 for A~0.5 + !! and going down to Cdi(say 1.4e-3) for A=1 + !! + !! It is theoretically applicable to all ice conditions (not only MIZ) + !! => see Lupkes et al (2013) + !! + !! ** References : Lupkes et al. JGR 2012 (theory) + !! Lupkes et al. GRL 2013 (application to GCM) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: CdN10_f_LU13 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b + !!---------------------------------------------------------------------- + INTEGER :: ji, jj + REAL(wp) :: zcoef + !!---------------------------------------------------------------------- + zcoef = rNu_0 + 1._wp / ( 10._wp * rBeta_0 ) + + !! We are not an AGCM, we are an OGCM!!! => we drop term "(1 - A)*Cd_w" + !! => so we keep only the last rhs terms of Eq.(1) of Lupkes et al, 2013 that we divide by "A": + !! (we multiply Cd_i_s and Cd_i_f by A later, when applying ocean-ice partitioning... + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + CdN10_f_LU13(ji,jj) = rCe_0 * pfrice(ji,jj)**(rMu_0 - 1._wp) * (1._wp - pfrice(ji,jj))**zcoef + END DO ; END DO + !! => seems okay for winter 100% sea-ice as second rhs term vanishes as pfrice == 1.... + + END FUNCTION CdN10_f_LU13 + + + FUNCTION CdN_f_LG15( pzu, pfrice, pz0i, pSc, phf, pDi ) + !!---------------------------------------------------------------------- + !! *** ROUTINE CdN_f_LG15 *** + !! + !! GENERAL FORM OF EQUATION 21 of Lupkes & Gryanik (2015) + !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !! + !! ** Purpose : Computes the "form" contribution of the neutral air-ice + !! drag referenced at 10m to make it dependent on edges at + !! leads, melt ponds and flows (to be added to the "skin" + !! contribution. After some + !! approximations, this can be resumed to a dependency on + !! ice concentration. + !! + !! ** References : Lupkes & Gryanik (2015) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LG15 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), INTENT(in ) :: pzu ! reference height [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc, phf and pDi all provided... + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0i ! roughness length over ICE [m] (in LU12, it's over water ???) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pSc ! shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m] + !!---------------------------------------------------------------------- + LOGICAL :: l_known_Sc=.FALSE., l_known_hf=.FALSE., l_known_Di=.FALSE. + REAL(wp) :: ztmp, zrlog, zfri, zfrw, zSc, zhf, zDi + INTEGER :: ji, jj + !!---------------------------------------------------------------------- + l_known_Sc = PRESENT(pSc) + l_known_hf = PRESENT(phf) + l_known_Di = PRESENT(pDi) + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + + zfri = pfrice(ji,jj) + zfrw = (1._wp - zfri) + + IF(l_known_Sc) THEN + zSc = pSc(ji,jj) + ELSE + !! Sc parameterized in terms of A (ice fraction): + zSc = zfrw**(1._wp / ( 10._wp * rBeta_0 )) ! Eq.(31) + END IF + + IF(l_known_hf) THEN + zhf = phf(ji,jj) + ELSE + !! hf parameterized in terms of A (ice fraction): + zhf = rhmax_0*zfri + rhmin_0*zfrw ! Eq.(25) + END IF + + IF(l_known_Di) THEN + zDi = pDi(ji,jj) + ELSE + !! Di parameterized in terms of A (ice fraction): + ztmp = 1._wp / ( 1._wp - (rDmin_0/rDmax_0)**(1._wp/rBeta_0) ) ! A* Eq.(27) + zDi = rDmin_0 * ( ztmp/(ztmp - zfri) )**rBeta_0 ! Eq.(26) + END IF + + ztmp = 1._wp/pz0i(ji,jj) + zrlog = LOG(zhf*ztmp/2.718_wp) / LOG(pzu*ztmp) !LOLO: adding number "e" !!! + + CdN_f_LG15(ji,jj) = 0.5_wp* 0.4_wp * zrlog*zrlog * zSc*zSc * zhf/zDi * zfri ! Eq.(21) Lukes & Gryanik (2015) + !! 1/2 Ce + + END DO ; END DO + END FUNCTION CdN_f_LG15 + + + FUNCTION CdN_f_LG15_light( pzu, pfrice, pz0w ) + !!---------------------------------------------------------------------- + !! *** ROUTINE CdN_f_LG15_light *** + !! + !! ** Purpose : Computes the "form" contribution of the neutral air-ice + !! drag referenced at 10m to make it dependent on edges at + !! leads, melt ponds and flows (to be added to the "skin" + !! contribution. After some + !! approximations, this can be resumed to a dependency on + !! ice concentration. + !! + !! ** References : Lupkes & Gryanik (2015) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LG15_light ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), INTENT(in) :: pzu ! reference height [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0w ! roughness length over water [m] + !!---------------------------------------------------------------------- + REAL(wp) :: ztmp, zrlog, zfri + INTEGER :: ji, jj + !!---------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + + zfri = pfrice(ji,jj) + + ztmp = 1._wp / pz0w(ji,jj) + zrlog = LOG( 10._wp * ztmp ) / LOG( pzu * ztmp ) ! part of (Eq.46) + + CdN_f_LG15_light(ji,jj) = rce10_i_0 *zrlog*zrlog * zfri * (1._wp - zfri)**rbeta_0 ! (Eq.46) [ index 1 is for ice, 2 for water ] + + END DO ; END DO + END FUNCTION CdN_f_LG15_light + + + !!====================================================================== +END MODULE sbcblk_algo_ice_cdn diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_lg15.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_lg15.f90 new file mode 100644 index 0000000000000000000000000000000000000000..190dcbd914a202f881b14bd7252f5e990e0ae3e6 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_lg15.f90 @@ -0,0 +1,302 @@ + + + + + + + + + + + + + +MODULE sbcblk_algo_ice_lg15 + !!====================================================================== + !! *** MODULE sbcblk_algo_ice_lg15 *** + !! Computes turbulent components of surface fluxes over sea-ice + !! + !! + !! Lüpkes, C., and Gryanik, V. M. ( 2015), A stability‐dependent parametrization + !! of transfer coefficients for momentum and heat over polar sea ice to be used in climate models, + !! J. Geophys. Res. Atmos., 120, 552– 581, doi:10.1002/2014JD022418. + !! + !! => Despite the fact that the sea-ice concentration (frice) must be provided, + !! only transfer coefficients, and air temp. + hum. height adjustement + !! over ice are returned/performed. + !! ==> 'frice' is only here to estimate the form drag caused by sea-ice... + !! + !! Routine turb_ice_lg15 maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !! + !! Author: Laurent Brodeau, Summer 2020 + !! + !!---------------------------------------------------------------------- + USE par_kind, ONLY: wp + USE par_oce, ONLY: jpi, jpj + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE sbcblk_algo_ice_cdn + + IMPLICIT NONE + PRIVATE + + PUBLIC :: turb_ice_lg15 + + REAL(wp), PARAMETER :: ralpha_0 = 0.2_wp ! (Eq.12) (ECHAM6 value) + + !! To be namelist parameters in NEMO: + REAL(wp), PARAMETER :: rz0_i_s_0 = 0.69e-3_wp ! Eq. 43 [m] + REAL(wp), PARAMETER :: rz0_i_f_0 = 4.54e-4_wp ! bottom p.562 MIZ [m] + + LOGICAL, PARAMETER :: l_add_form_drag = .TRUE. + LOGICAL, PARAMETER :: l_use_pond_info = .FALSE. + LOGICAL, PARAMETER :: l_dbg_print = .FALSE. + + INTEGER , PARAMETER :: nbit = 8 ! number of itterations + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_ice_lg15( zt, zu, Ts_i, t_zt, qs_i, q_zt, U_zu, frice, & + & Cd_i, Ch_i, Ce_i, t_zu_i, q_zu_i, & + & CdN, ChN, CeN, xz0, xu_star, xL, xUN10 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE turb_ice_lg15 *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to: + !! Lüpkes, C., and Gryanik, V. M. ( 2015), A stability‐dependent + !! parametrization of transfer coefficients for momentum and heat + !! over polar sea ice to be used in climate models, + !! J. Geophys. Res. Atmos., 120, 552– 581, doi:10.1002/2014JD022418. + !! + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * Ts_i : surface temperature of sea-ice [K] + !! * t_zt : potential air temperature at zt [K] + !! * qs_i : saturation specific humidity at temp. Ts_i over ice [kg/kg] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! * frice : sea-ice concentration (fraction) + !! + !! OUTPUT : + !! -------- + !! * Cd_i : drag coefficient over sea-ice + !! * Ch_i : sensible heat coefficient over sea-ice + !! * Ce_i : sublimation coefficient over sea-ice + !! * t_zu_i : pot. air temp. adjusted at zu over sea-ice [K] + !! * q_zu_i : spec. hum. of air adjusted at zu over sea-ice [kg/kg] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * CdN : neutral-stability drag coefficient + !! * ChN : neutral-stability sensible heat coefficient + !! * CeN : neutral-stability evaporation coefficient + !! * xz0 : return the aerodynamic roughness length (integration constant for wind stress) [m] + !! * xu_star : return u* the friction velocity [m/s] + !! * xL : return the Obukhov length [m] + !! * xUN10 : neutral wind speed at 10m [m/s] + !! + !! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: frice ! sea-ice concentration (fraction) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp1, ztmp2 ! temporary stuff + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dt_zu, dq_zu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zz0_s, zz0_f, RiB ! third dimensions (size=2): + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zCdN_s, zChN_s, zCdN_f, zChN_f + !! + INTEGER :: jit + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + !! + LOGICAL :: lreturn_cdn=.FALSE., lreturn_chn=.FALSE., lreturn_cen=.FALSE. + LOGICAL :: lreturn_z0=.FALSE., lreturn_ustar=.FALSE., lreturn_L=.FALSE., lreturn_UN10=.FALSE. + !! + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_lg15@sbcblk_algo_ice_lg15.f90' + !!---------------------------------------------------------------------------------- + ALLOCATE ( Ubzu(jpi,jpj) ) + ALLOCATE ( ztmp1(jpi,jpj), ztmp2(jpi,jpj) ) + ALLOCATE ( dt_zu(jpi,jpj), dq_zu(jpi,jpj) ) + ALLOCATE ( zz0_s(jpi,jpj), zz0_f(jpi,jpj), RiB(jpi,jpj), & + & zCdN_s(jpi,jpj), zChN_s(jpi,jpj), zCdN_f(jpi,jpj), zChN_f(jpi,jpj) ) + + lreturn_cdn = PRESENT(CdN) + lreturn_chn = PRESENT(ChN) + lreturn_cen = PRESENT(CeN) + lreturn_z0 = PRESENT(xz0) + lreturn_ustar = PRESENT(xu_star) + lreturn_L = PRESENT(xL) + lreturn_UN10 = PRESENT(xUN10) + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) + + !! Scalar wind speed cannot be below 0.2 m/s + Ubzu = MAX( U_zu, wspd_thrshld_ice ) + + !! First guess of temperature and humidity at height zu: + t_zu_i = MAX( t_zt , 100._wp ) ! who knows what's given on masked-continental regions... + q_zu_i = MAX( q_zt , 0.1e-6_wp ) ! " + + !! Air-Ice & Air-Sea differences (and we don't want them to be 0!) + dt_zu = t_zu_i - Ts_i ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu_i - qs_i ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + !! Very crude first guess: + Cd_i(:,:) = 1.4e-3_wp + Ch_i(:,:) = 1.4e-3_wp + Ce_i(:,:) = 1.4e-3_wp + + !! For skin drag : + zz0_s(:,:) = rz0_i_s_0 !#LB/RFI! ! Room for improvement. We use the same z0_skin everywhere (= rz0_i_s_0)... + zCdN_s(:,:) = Cd_from_z0( zu, zz0_s(:,:) ) + zChN_s(:,:) = vkarmn2 / ( LOG( zu / zz0_s(:,:) ) * LOG( zu / (ralpha_0*zz0_s(:,:)) ) ) ! (Eq.11,12) [ "" ] + + !! For form drag in MIZ: + zz0_f(:,:) = 0._wp + zCdN_f(:,:) = 0._wp + zChN_f(:,:) = 0._wp + IF ( l_add_form_drag ) THEN + zz0_f(:,:) = rz0_i_f_0 !#LB/RFI! ! Room for improvement. We use the same z0_form everywhere !!! + zCdN_f(:,:) = CdN_f_LG15_light( zu, frice(:,:), zz0_f(:,:) ) + zChN_f(:,:) = zCdN_f(:,:)/( 1._wp + LOG(1._wp/ralpha_0)/vkarmn*SQRT(zCdN_f(:,:)) ) ! (Eq.60,61) [ "" ] + END IF + + !! Some other first guess values, needed to compute wind at zt: + Cd_i(:,:) = zCdN_s(:,:) + zCdN_f(:,:) + Ch_i(:,:) = zChN_s(:,:) + zChN_f(:,:) + RiB(:,:) = Ri_bulk( zt, Ts_i(:,:), t_zt(:,:), qs_i(:,:), q_zt(:,:), Ubzu(:,:) ) ! over ice (index=1) + + + !! ITERATION BLOCK + DO jit = 1, nbit + + IF(l_dbg_print) PRINT *, 'LOLO: LOOP #', INT(jit,1) + IF(l_dbg_print) PRINT *, 'LOLO: theta_zu, Ts_i, Ubzu =', REAL(t_zu_i(:,:),4), REAL(Ts_i(:,:),4), REAL(Ubzu(:,:),4) + IF(l_dbg_print) PRINT *, 'LOLO: q_zu =', REAL(q_zu_i(:,:),4) + IF(l_dbg_print) PRINT *, 'LOLO: CdN_s, zCdN_f =', REAL(zCdN_s(:,:),4), REAL(zCdN_f(:,:),4) + + + !! Bulk Richardson Number + !! ====================== + !! PROBLEM: when computed at z=zu, with adjusted theta and q, it is numerically unstable in some rare events (unstable) + !! => fix: compute RiB at zt, with ajusted wind at zt... => seems to be more stable + IF( .NOT. l_zt_equal_zu ) THEN + ! U_zt = U_zu + u_star/vkarmn*(LOG(zt/zu) + psi_m_coare(zu/L) - psi_m_coare(zt/L)) + ztmp1(:,:) = zCdN_s(:,:) + zCdN_f(:,:) ! total neutral drag coeff! + ztmp2(:,:) = zz0_s(:,:) + zz0_f(:,:) ! total roughness length z0 + ztmp1 = LOG(zt/zu) + f_h_louis( zu, RiB(:,:), ztmp1(:,:), ztmp2(:,:) ) & + & - f_h_louis( zt, RiB(:,:), ztmp1(:,:), ztmp2(:,:) ) + ztmp2(:,:) = MAX( Ubzu(:,:) + (SQRT(Cd_i(:,:))*Ubzu)*ztmp1 , wspd_thrshld_ice ) ! wind at zt ( SQRT(Cd_i(:,:))*Ubzu == u* !) + ztmp2(:,:) = MIN( ztmp2(:,:) , Ubzu(:,:) ) + IF(l_dbg_print) PRINT *, 'LOLO: ADJUSTED WIND AT ZT =', ztmp2 + ELSE + ztmp2(:,:) = Ubzu(:,:) + END IF + RiB(:,:) = Ri_bulk( zt, Ts_i(:,:), t_zt(:,:), qs_i(:,:), q_zt(:,:), ztmp2(:,:) ) ! over ice (index=1) + IF(l_dbg_print) PRINT *, 'LOLO: RiB_zt =', RiB(:,:) + + + ! Momentum and Heat transfer coefficients WITHOUT FORM DRAG / (Eq.6) and (Eq.10): + Cd_i(:,:) = zCdN_s(:,:) * f_m_louis( zu, RiB(:,:), zCdN_s(:,:), zz0_s(:,:) ) ! (Eq.6) + Ch_i(:,:) = zChN_s(:,:) * f_h_louis( zu, RiB(:,:), zCdN_s(:,:), zz0_s(:,:) ) ! (Eq.10) / LOLO: why "zCdN_s" (ztmp1) and not "zChn" ??? + IF(l_dbg_print) PRINT *, 'LOLO: f_m_louis_s =', f_m_louis( zu, RiB(:,:), zCdN_s(:,:), zz0_s(:,:) ) + IF(l_dbg_print) PRINT *, 'LOLO: f_h_louis_s =', f_h_louis( zu, RiB(:,:), zCdN_s(:,:), zz0_s(:,:) ) + IF(l_dbg_print) PRINT *, 'LOLO: Cd / skin only / ice =', REAL(Cd_i(:,:),4) + + + IF ( l_add_form_drag ) THEN + !! Form-drag-related NEUTRAL momentum and Heat transfer coefficients: + !! MIZ: + Cd_i(:,:) = Cd_i(:,:) + zCdN_f(:,:) * f_m_louis( zu, RiB(:,:), zCdN_f(:,:), zz0_f(:,:) ) ! (Eq.6) + Ch_i(:,:) = Ch_i(:,:) + zChN_f(:,:) * f_h_louis( zu, RiB(:,:), zCdN_f(:,:), zz0_f(:,:) ) ! (Eq.10) / LOLO: why "zCdN_f" and not "zChn" ??? + IF(l_dbg_print) PRINT *, 'LOLO: f_m_louis_f =', f_m_louis( zu, RiB(:,:), zCdN_f(:,:), zz0_f(:,:) ) + IF(l_dbg_print) PRINT *, 'LOLO: f_h_louis_f =', f_h_louis( zu, RiB(:,:), zCdN_f(:,:), zz0_f(:,:) ) + + IF(l_dbg_print) PRINT *, 'LOLO: Cd / form only / ice =', REAL(zCdN_f(:,:) * f_m_louis( zu, RiB(:,:), zCdN_f(:,:), zz0_f(:,:) ),4) + + END IF + + IF(l_dbg_print) PRINT *, 'LOLO: Cd, Ch / TOTAL / ice =', REAL(Cd_i(:,:),4), REAL(Ch_i(:,:),4) + + + !! Adjusting temperature and humidity from zt to zu: + IF( .NOT. l_zt_equal_zu ) THEN + + !! Over ice: + ztmp1(:,:) = zCdN_s(:,:) + zCdN_f(:,:) ! total neutral drag coeff! + ztmp2(:,:) = zz0_s(:,:) + zz0_f(:,:) ! total roughness length z0 + ztmp1 = LOG(zt/zu) + f_h_louis( zu, RiB(:,:), ztmp1(:,:), ztmp2(:,:) ) & + & - f_h_louis( zt, RiB(:,:), ztmp1(:,:), ztmp2(:,:) ) + ztmp2 = 1._wp/SQRT(Cd_i(:,:)) + + t_zu_i(:,:) = t_zt - (Ch_i(:,:) * dt_zu(:,:) * ztmp2) / vkarmn * ztmp1 ! t_star = Ch * dt_zu / SQRT(Cd) + q_zu_i(:,:) = q_zt - (Ch_i(:,:) * dq_zu(:,:) * ztmp2) / vkarmn * ztmp1 ! q_star = Ce * dq_zu / SQRT(Cd) + q_zu_i(:,:) = MAX(0._wp, q_zu_i(:,:)) + + dt_zu(:,:) = t_zu_i(:,:) - Ts_i + dq_zu(:,:) = q_zu_i(:,:) - qs_i + + dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + END IF + + IF(l_dbg_print) PRINT *, ''!LOLO + + END DO !DO jit = 1, nbit + + Ce_i(:,:) = Ch_i(:,:) + + IF( lreturn_cdn ) CdN = zCdN_s(:,:)+zCdN_f(:,:) + IF( lreturn_chn ) ChN = zChN_s(:,:)+zChN_f(:,:) + IF( lreturn_cen ) CeN = zChN_s(:,:)+zChN_f(:,:) + + IF( lreturn_z0 ) xz0 = z0_from_Cd( zu, zCdN_s(:,:)+zCdN_f(:,:) ) + + IF( lreturn_ustar ) xu_star = SQRT(Cd_i) * Ubzu + + IF( lreturn_L ) THEN + ztmp1 = SQRT(Cd_i) + xL = 1./One_on_L( t_zu_i, q_zu_i, ztmp1*Ubzu, Ch_i*dt_zu(:,:)/ztmp1, Ce_i*dq_zu(:,:)/ztmp1 ) + END IF + + IF( lreturn_UN10 ) THEN + ztmp1 = zCdN_s(:,:) + zCdN_f(:,:) ! => CdN + xUN10 = SQRT(Cd_i) * Ubzu/vkarmn * LOG( 10._wp / z0_from_Cd(zu, ztmp1) ) + END IF + + DEALLOCATE ( Ubzu ) + DEALLOCATE ( ztmp1, ztmp2 ) + DEALLOCATE ( dt_zu, dq_zu ) + DEALLOCATE ( zz0_s, zz0_f, RiB, zCdN_s, zChN_s, zCdN_f, zChN_f ) + + END SUBROUTINE turb_ice_lg15 + + !!====================================================================== +END MODULE sbcblk_algo_ice_lg15 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_lu12.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_lu12.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a3bd668d67ad01555932dbab2c9a3daf35103d19 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ice_lu12.f90 @@ -0,0 +1,198 @@ + + + + + + + + + + + + + +MODULE sbcblk_algo_ice_lu12 + !!====================================================================== + !! *** MODULE sbcblk_algo_ice_lu12 *** + !! Computes turbulent components of surface fluxes over sea-ice + !! + !! Lüpkes, C., Gryanik, V. M., Hartmann, J., and Andreas, E. L. ( 2012), A parametrization, based on sea ice morphology, + !! of the neutral atmospheric drag coefficients for weather prediction and climate models, J. Geophys. Res., 117, D13112, + !! doi:10.1029/2012JD017630. + !! + !! => Despite the fact that the sea-ice concentration (frice) must be provided, + !! only transfer coefficients, and air temp. + hum. height adjustement + !! over ice are returned/performed. + !! ==> 'frice' is only here to estimate the form drag caused by sea-ice... + !! + !! Routine turb_ice_lu12 maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !! + !! Author: Laurent Brodeau, Summer 2020 + !! + !!---------------------------------------------------------------------- + USE par_kind, ONLY: wp + USE par_oce, ONLY: jpi, jpj + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE sbcblk_algo_ice_cdn + + IMPLICIT NONE + PRIVATE + + PUBLIC :: turb_ice_lu12 + + REAL(wp), PARAMETER :: rz0_i_s_0 = 0.69e-3_wp ! Eq.(43) of Lupkes & Gryanik (2015) [m] => to estimate CdN10 for skin drag! + REAL(wp), PARAMETER :: rz0_i_f_0 = 4.54e-4_wp ! bottom p.562 MIZ [m] (LG15) + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_ice_lu12( zt, zu, Ts_i, t_zt, qs_i, q_zt, U_zu, frice, & + & Cd_i, Ch_i, Ce_i, t_zu_i, q_zu_i, & + & CdN, ChN, CeN, xz0, xu_star, xL, xUN10 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE turb_ice_lu12 *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to: + !! Lüpkes, C., Gryanik, V. M., Hartmann, J., and Andreas, E. L. ( 2012), + !! A parametrization, based on sea ice morphology, of the neutral + !! atmospheric drag coefficients for weather prediction and climate models, + !! J. Geophys. Res., 117, D13112, doi:10.1029/2012JD017630. + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * Ts_i : surface temperature of sea-ice [K] + !! * t_zt : potential air temperature at zt [K] + !! * qs_i : saturation specific humidity at temp. Ts_i over ice [kg/kg] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! * frice : sea-ice concentration (fraction) + !! + !! OUTPUT : + !! -------- + !! * Cd_i : drag coefficient over sea-ice + !! * Ch_i : sensible heat coefficient over sea-ice + !! * Ce_i : sublimation coefficient over sea-ice + !! * t_zu_i : pot. air temp. adjusted at zu over sea-ice [K] + !! * q_zu_i : spec. hum. of air adjusted at zu over sea-ice [kg/kg] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * CdN : neutral-stability drag coefficient + !! * ChN : neutral-stability sensible heat coefficient + !! * CeN : neutral-stability evaporation coefficient + !! * xz0 : return the aerodynamic roughness length (integration constant for wind stress) [m] + !! * xu_star : return u* the friction velocity [m/s] + !! * xL : return the Obukhov length [m] + !! * xUN10 : neutral wind speed at 10m [m/s] + !! + !! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: frice ! sea-ice concentration (fraction) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dt_zu, dq_zu, z0 + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu + !! + LOGICAL :: lreturn_cdn=.FALSE., lreturn_chn=.FALSE., lreturn_cen=.FALSE. + LOGICAL :: lreturn_z0=.FALSE., lreturn_ustar=.FALSE., lreturn_L=.FALSE., lreturn_UN10=.FALSE. + !! + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_lu12@sbcblk_algo_ice_lu12.f90' + !!---------------------------------------------------------------------------------- + ALLOCATE ( Ubzu(jpi,jpj) ) + ALLOCATE ( dt_zu(jpi,jpj), dq_zu(jpi,jpj), z0(jpi,jpj) ) + + lreturn_cdn = PRESENT(CdN) + lreturn_chn = PRESENT(ChN) + lreturn_cen = PRESENT(CeN) + lreturn_z0 = PRESENT(xz0) + lreturn_ustar = PRESENT(xu_star) + lreturn_L = PRESENT(xL) + lreturn_UN10 = PRESENT(xUN10) + + !! Scalar wind speed cannot be below 0.2 m/s + Ubzu = MAX( U_zu, wspd_thrshld_ice ) + + !! First guess of temperature and humidity at height zu: + t_zu_i = MAX( t_zt , 100._wp ) ! who knows what's given on masked-continental regions... + q_zu_i = MAX( q_zt , 0.1e-6_wp ) ! " + + !! Air-Ice & Air-Sea differences (and we don't want them to be 0!) + dt_zu = t_zu_i - Ts_i ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu_i - qs_i ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + !! To estimate CDN10_skin: + !! we use the method that comes in LG15, i.e. by starting from a default roughness length z0 for skin drag: + + Ce_i(:,:) = rz0_i_s_0 !! temporary array to contain roughness length for skin drag ! + + + !! Method #1: + !Cd_i(:,:) = Cd_from_z0( zu, Ce_i(:,:) ) + CdN10_f_LU13( frice(:,:) ) + !IF( lreturn_cdfrm ) CdN_frm = CdN10_f_LU13( frice(:,:) ) + !PRINT *, 'LOLO: estimate of Cd_f_i method #1 =>', CdN10_f_LU13( frice(:,:) ); PRINT *, '' + + !! Method #2: + !! We need an estimate of z0 over water: + !z0_w(:,:) = z0_from_Cd( zu, CD_N10_NCAR(Ubzu) ) + !!PRINT *, 'LOLO: estimate of z0_w =>', z0_w + !Cd_i(:,:) = Cd_from_z0( zu, Ce_i(:,:) ) + CdN10_f_LU12( frice(:,:), z0_w(:,:) ) + !IF( lreturn_cdfrm ) CdN_frm = CdN10_f_LU12( frice(:,:), z0_w(:,:) ) + !! N10 skin drag N10 form drag + + !! Method #3: + !Cd_i(:,:) = Cd_from_z0( zu, Ce_i(:,:) ) + CdN10_f_LU12_eq36( frice(:,:) ) + !IF( lreturn_cdfrm ) CdN_frm = CdN10_f_LU12_eq36( frice(:,:) ) + !PRINT *, 'LOLO: estimate of Cd_f_i method #2 =>', CdN10_f_LU12( frice(:,:), z0_w(:,:) ) + + !! Method #4: + !! using eq.21 of LG15 instead: + z0(:,:) = rz0_i_f_0 + !Cd_i(:,:) = Cd_from_z0( zu, Ce_i(:,:) ) + CdN_f_LG15( zu, frice(:,:), z0(:,:) ) / frice(:,:) + Cd_i(:,:) = Cd_from_z0( zu, Ce_i(:,:) ) + CdN_f_LG15( zu, frice(:,:), z0(:,:) ) !/ frice(:,:) + !IF( lreturn_cdfrm ) CdN_frm = CdN_f_LG15( zu, frice(:,:), z0(:,:) ) + + + Ch_i(:,:) = Cd_i(:,:) + Ce_i(:,:) = Cd_i(:,:) + + IF( lreturn_cdn ) CdN = Cd_i(:,:) + IF( lreturn_chn ) ChN = Ch_i(:,:) + IF( lreturn_cen ) CeN = Ce_i(:,:) + + IF( lreturn_z0 ) xz0 = z0_from_Cd( zu, Cd_i ) + IF( lreturn_ustar ) xu_star = SQRT(Cd_i)*Ubzu + IF( lreturn_L ) xL = 1./One_on_L(t_zu_i, q_zu_i, SQRT(Cd_i)*Ubzu, & + & Cd_i/SQRT(Cd_i)*dt_zu, Cd_i/SQRT(Cd_i)*dq_zu) + IF( lreturn_UN10 ) xUN10 = SQRT(Cd_i)*Ubzu/vkarmn * LOG( 10._wp / z0_from_Cd( zu, Cd_i ) ) + + DEALLOCATE ( dt_zu, dq_zu, z0 ) + DEALLOCATE ( Ubzu ) + + END SUBROUTINE turb_ice_lu12 + + !!====================================================================== +END MODULE sbcblk_algo_ice_lu12 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ncar.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ncar.f90 new file mode 100644 index 0000000000000000000000000000000000000000..683583f03150a144801b613d6bfedeb8c47b8d3a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_algo_ncar.f90 @@ -0,0 +1,384 @@ + + + + + + + + + + + + + +MODULE sbcblk_algo_ncar + !!====================================================================== + !! *** MODULE sbcblk_algo_ncar *** + !! Computes: + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at 10m Ubzu + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Using the bulk formulation/param. of Large & Yeager 2008 + !! + !! Routine turb_ncar maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !! + !! L. Brodeau, 2015 + !!===================================================================== + !! History : 3.6 ! 2016-02 (L.Brodeau) successor of old turb_ncar of former sbcblk_core.F90 + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! turb_ncar : computes the bulk turbulent transfer coefficients + !! adjusts t_air and q_air from zt to zu m + !! returns the effective bulk wind speed at 10m + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE sbc_oce, ONLY: ln_cdgw + USE sbcwave, ONLY: cdn_wave ! wave module + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + IMPLICIT NONE + PRIVATE + + PUBLIC :: TURB_NCAR ! called by sbcblk.F90 + + !! * Substitutions + + + + + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_ncar( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & + & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & + & nb_iter, CdN, ChN, CeN ) + !!---------------------------------------------------------------------------------- + !! *** ROUTINE turb_ncar *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to Large & Yeager (2004) and Large & Yeager (2008) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * sst : bulk SST [K] + !! * t_zt : potential air temperature at zt [K] + !! * ssq : specific humidity at saturation at SST [kg/kg] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! + !! + !! OUTPUT : + !! -------- + !! * Cd : drag coefficient + !! * Ch : sensible heat coefficient + !! * Ce : evaporation coefficient + !! * t_zu : pot. air temperature adjusted at wind height zu [K] + !! * q_zu : specific humidity of air // [kg/kg] + !! * Ubzu : bulk wind speed at zu [m/s] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * CdN : neutral-stability drag coefficient + !! * ChN : neutral-stability sensible heat coefficient + !! * CeN : neutral-stability evaporation coefficient + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + ! + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN + ! + INTEGER :: nbit, jit ! iterations... + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + ! + REAL(wp), DIMENSION(jpi,jpj) :: zCdN, zCeN, zChN ! 10m neutral latent/sensible coefficient + REAL(wp), DIMENSION(jpi,jpj) :: zsqrt_Cd, zsqrt_CdN ! root square of Cd and Cd_neutral + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + !!---------------------------------------------------------------------------------- + nbit = nb_iter0 + IF( PRESENT(nb_iter) ) nbit = nb_iter + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision + + Ubzu = MAX( 0.5_wp , U_zu ) ! relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s + + !! First guess of stability: + ztmp0 = virt_temp(t_zt, q_zt) - virt_temp(sst, ssq) ! air-sea difference of virtual pot. temp. at zt + ztmp1 = 0.5_wp + SIGN(0.5_wp,ztmp0) ! ztmp1 = 1 if dTv > 0 => STABLE, 0 if unstable + + !! Neutral coefficients at 10m: + IF( ln_cdgw ) THEN ! wave drag case + cdn_wave(:,:) = cdn_wave(:,:) + rsmall * ( 1._wp - tmask(:,:,1) ) + zCdN (:,:) = cdn_wave(:,:) + ELSE + zCdN = cd_n10_ncar( Ubzu ) + ENDIF + + zsqrt_CdN = SQRT( zCdN ) + + !! Initializing transf. coeff. with their first guess neutral equivalents : + Cd = zCdN + Ce = ce_n10_ncar( zsqrt_CdN ) + Ch = ch_n10_ncar( zsqrt_CdN , ztmp1 ) ! ztmp1 is stability (1/0) + zsqrt_Cd = zsqrt_CdN + + IF( ln_cdgw ) THEN + zCeN = Ce + zChN = Ch + ENDIF + + !! Initializing values at z_u with z_t values: + t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... + q_zu = MAX( q_zt , 1.e-6_wp ) ! " + + + !! ITERATION BLOCK + DO jit = 1, nbit + ! + ztmp1 = t_zu - sst ! Updating air/sea differences + ztmp2 = q_zu - ssq + + ! Updating turbulent scales : (L&Y 2004 Eq. (7)) + ztmp0 = zsqrt_Cd*Ubzu ! u* + ztmp1 = Ch/zsqrt_Cd*ztmp1 ! theta* + ztmp2 = Ce/zsqrt_Cd*ztmp2 ! q* + + ! Estimate the inverse of Obukov length (1/L) at height zu: + ztmp0 = One_on_L( t_zu, q_zu, ztmp0, ztmp1, ztmp2 ) + + !! Stability parameters : + zeta_u = zu*ztmp0 + zeta_u = sign( min(abs(zeta_u),10._wp), zeta_u ) + + !! Shifting temperature and humidity at zu (L&Y 2004 Eq. (9b-9c)) + IF( .NOT. l_zt_equal_zu ) THEN + ztmp0 = zt*ztmp0 ! zeta_t ! + ztmp0 = SIGN( MIN(ABS(ztmp0),10._wp), ztmp0 ) ! Temporaty array ztmp0 == zeta_t !!! + ztmp0 = LOG(zt/zu) + psi_h_ncar(zeta_u) - psi_h_ncar(ztmp0) ! ztmp0 just used as temp array again! + t_zu = t_zt - ztmp1/vkarmn*ztmp0 ! ztmp1 is still theta* L&Y 2004 Eq. (9b) + !! + q_zu = q_zt - ztmp2/vkarmn*ztmp0 ! ztmp2 is still q* L&Y 2004 Eq. (9c) + q_zu = MAX(0._wp, q_zu) + END IF + + ! Update neutral wind speed at 10m and neutral Cd at 10m (L&Y 2004 Eq. 9a)... + ! In very rare low-wind conditions, the old way of estimating the + ! neutral wind speed at 10m leads to a negative value that causes the code + ! to crash. To prevent this a threshold of 0.25m/s is imposed. + ztmp2 = psi_m_ncar(zeta_u) + IF( ln_cdgw ) THEN ! surface wave case + zsqrt_Cd = vkarmn / ( vkarmn / zsqrt_CdN - ztmp2 ) + Cd = zsqrt_Cd * zsqrt_Cd + ztmp0 = (LOG(zu/10._wp) - psi_h_ncar(zeta_u)) / vkarmn / zsqrt_CdN + ztmp2 = zsqrt_Cd / zsqrt_CdN + ztmp1 = 1._wp + zChN * ztmp0 + Ch = zChN * ztmp2 / ztmp1 ! L&Y 2004 eq. (10b) + ztmp1 = 1._wp + zCeN * ztmp0 + Ce = zCeN * ztmp2 / ztmp1 ! L&Y 2004 eq. (10c) + + ELSE + ztmp0 = MAX( 0.25_wp , UN10_from_CD(zu, Ubzu, Cd, ppsi=ztmp2) ) ! U_n10 (ztmp2 == psi_m_ncar(zeta_u)) + + zCdN = cd_n10_ncar(ztmp0) + zsqrt_CdN = sqrt(zCdN) + + !! Update of transfer coefficients: + + !! C_D + ztmp1 = 1._wp + zsqrt_CdN/vkarmn*(LOG(zu/10._wp) - ztmp2) ! L&Y 2004 Eq. (10a) (ztmp2 == psi_m(zeta_u)) + Cd = MAX( zCdN / ( ztmp1*ztmp1 ), Cx_min ) + + !! C_H and C_E + zsqrt_Cd = SQRT( Cd ) + ztmp0 = ( LOG(zu/10._wp) - psi_h_ncar(zeta_u) ) / vkarmn / zsqrt_CdN + ztmp2 = zsqrt_Cd / zsqrt_CdN + + ztmp1 = 0.5_wp + SIGN(0.5_wp,zeta_u) ! update stability + zChN = 1.e-3_wp * zsqrt_CdN*(18._wp*ztmp1 + 32.7_wp*(1._wp - ztmp1)) ! L&Y 2004 eq. (6c-6d) + zCeN = 1.e-3_wp * (34.6_wp * zsqrt_CdN) ! L&Y 2004 eq. (6b) + + Ch = MAX( zChN*ztmp2 / ( 1._wp + zChN*ztmp0 ) , Cx_min ) ! L&Y 2004 eq. (10b) + Ce = MAX( zCeN*ztmp2 / ( 1._wp + zCeN*ztmp0 ) , Cx_min ) ! L&Y 2004 eq. (10c) + + ENDIF + + END DO !DO jit = 1, nbit + + IF(PRESENT(CdN)) CdN(:,:) = zCdN(:,:) + IF(PRESENT(CeN)) CeN(:,:) = zCeN(:,:) + IF(PRESENT(ChN)) ChN(:,:) = zChN(:,:) + + END SUBROUTINE turb_ncar + + + FUNCTION cd_n10_ncar( pw10 ) + !!---------------------------------------------------------------------------------- + !! Estimate of the neutral drag coefficient at 10m as a function + !! of neutral wind speed at 10m + !! + !! Origin: Large & Yeager 2008, Eq. (11) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pw10 ! scalar wind speed at 10m (m/s) + REAL(wp), DIMENSION(jpi,jpj) :: cd_n10_ncar + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zgt33, zw, zw6 ! local scalars + !!---------------------------------------------------------------------------------- + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zw = pw10(ji,jj) + zw6 = zw*zw*zw + zw6 = zw6*zw6 + ! + ! When wind speed > 33 m/s => Cyclone conditions => special treatment + zgt33 = 0.5_wp + SIGN( 0.5_wp, (zw - 33._wp) ) ! If pw10 < 33. => 0, else => 1 + ! + cd_n10_ncar(ji,jj) = 1.e-3_wp * ( & + & (1._wp - zgt33)*( 2.7_wp/zw + 0.142_wp + zw/13.09_wp - 3.14807E-10_wp*zw6) & ! wind < 33 m/s + & + zgt33 * 2.34_wp ) ! wind >= 33 m/s + ! + cd_n10_ncar(ji,jj) = MAX( cd_n10_ncar(ji,jj), Cx_min ) + ! + END DO ; END DO + ! + END FUNCTION cd_n10_ncar + + + FUNCTION ch_n10_ncar( psqrtcdn10 , pstab ) + !!---------------------------------------------------------------------------------- + !! Estimate of the neutral heat transfer coefficient at 10m !! + !! Origin: Large & Yeager 2008, Eq. (9) and (12) + + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: ch_n10_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pstab ! stable ABL => 1 / unstable ABL => 0 + !!---------------------------------------------------------------------------------- + IF( ANY(pstab < -0.00001) .OR. ANY(pstab > 1.00001) ) THEN + PRINT *, 'ERROR: ch_n10_ncar@mod_blk_ncar.f90: pstab =' + PRINT *, pstab + STOP + END IF + ! + ch_n10_ncar = MAX( 1.e-3_wp * psqrtcdn10*( 18._wp*pstab + 32.7_wp*(1._wp - pstab) ) , Cx_min ) ! Eq. (9) & (12) Large & Yeager, 2008 + ! + END FUNCTION ch_n10_ncar + + FUNCTION ce_n10_ncar( psqrtcdn10 ) + !!---------------------------------------------------------------------------------- + !! Estimate of the neutral heat transfer coefficient at 10m !! + !! Origin: Large & Yeager 2008, Eq. (9) and (13) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: ce_n10_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) + !!---------------------------------------------------------------------------------- + ce_n10_ncar = MAX( 1.e-3_wp * ( 34.6_wp * psqrtcdn10 ) , Cx_min ) + ! + END FUNCTION ce_n10_ncar + + + FUNCTION psi_m_ncar( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for momentum + !! !! Psis, L&Y 2004, Eq. (8c), (8d), (8e) + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zx, zpsi_unst, zpsi_stab, zstab ! local scalars + !!---------------------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zta = pzeta(ji,jj) + ! + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 - 16z)^0.5 + zx2 = MAX( zx2 , 1._wp ) + zx = SQRT(zx2) ! (1 - 16z)^0.25 + zpsi_unst = 2._wp*LOG( (1._wp + zx )*0.5_wp ) & + & + LOG( (1._wp + zx2)*0.5_wp ) & + & - 2._wp*ATAN(zx) + rpi*0.5_wp + ! + zpsi_stab = -5._wp*zta + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_m_ncar(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + ! + END DO ; END DO + END FUNCTION psi_m_ncar + + + FUNCTION psi_h_ncar( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! !! Psis, L&Y 2004, Eq. (8c), (8d), (8e) + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars + !!---------------------------------------------------------------------------------- + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ! + zta = pzeta(ji,jj) + ! + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 -16z)^0.5 + zx2 = MAX( zx2 , 1._wp ) + zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) + ! + zpsi_stab = -5._wp*zta + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_h_ncar(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END DO ; END DO + END FUNCTION psi_h_ncar + + !!====================================================================== +END MODULE sbcblk_algo_ncar diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_skin_coare.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_skin_coare.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0d5860ac81b45c02c33eaaaad4bd81a47c82cfd4 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_skin_coare.f90 @@ -0,0 +1,329 @@ + + + + + + + + + + + + + +MODULE sbcblk_skin_coare + !!====================================================================== + !! *** MODULE sbcblk_skin_coare *** + !! + !! Module that gathers the cool-skin and warm-layer parameterization used + !! in the COARE family of bulk parameterizations. + !! + !! Based on the last update for version COARE 3.6 (Fairall et al., 2019) + !! + !! Module 'sbcblk_skin_coare' also maintained and developed in AeroBulk (as + !! 'mod_skin_coare') + !! (https://github.com/brodeau/aerobulk) !! + !! ** Author: L. Brodeau, November 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2019-11 (L.Brodeau) Original code + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce ! Surface boundary condition: ocean fields + + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + USE sbcdcy !#LB: to know hour of dawn and dusk: rdawn_dcy and rdusk_dcy (needed in WL_COARE) + + USE lib_mpp ! distribued memory computing library + USE in_out_manager ! I/O manager + USE lib_fortran ! to use key_nosignedzero + + IMPLICIT NONE + PRIVATE + + PUBLIC :: CS_COARE, WL_COARE + !! * Substitutions + + + + + + !! Cool-skin related parameters: + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_cs !: dT due to cool-skin effect + ! ! => temperature difference between air-sea interface (z=0) + ! ! and right below viscous layer (z=delta) + + !! Warm-layer related parameters: + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_wl !: dT due to warm-layer effect + ! ! => difference between "almost surface (right below + ! ! viscous layer, z=delta) and depth of bulk SST (z=gdept_1d(1)) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Hz_wl !: depth (aka thickness) of warm-layer [m] + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Qnt_ac !: time integral / accumulated heat stored by the warm layer + ! ! Qxdt => [J/m^2] (reset to zero every midnight) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Tau_ac !: time integral / accumulated momentum + ! ! Tauxdt => [N.s/m^2] (reset to zero every midnight) + + REAL(wp), PARAMETER, PUBLIC :: Hwl_max = 20._wp !: maximum depth of warm layer (adjustable) + ! + REAL(wp), PARAMETER :: rich = 0.65_wp !: critical Richardson number + ! + REAL(wp), PARAMETER :: zfr0 = 0.5_wp !: initial value of solar flux absorption + ! + !!---------------------------------------------------------------------- +CONTAINS + + + SUBROUTINE CS_COARE( pQsw, pQnsol, pustar, pSST, pQlat ) + !!--------------------------------------------------------------------- + !! + !! Cool-skin parameterization, based on Fairall et al., 1996, + !! revisited for COARE 3.6 (Fairall et al., 2019) + !! + !! Fairall, C. W., Bradley, E. F., Godfrey, J. S., Wick, G. A., + !! Edson, J. B., and Young, G. S. ( 1996), Cool‐skin and warm‐layer + !! effects on sea surface temperature, J. Geophys. Res., 101( C1), 1295-1308, + !! doi:10.1029/95JC03190. + !! + !!------------------------------------------------------------------ + !! + !! ** INPUT: + !! *pQsw* surface net solar radiation into the ocean [W/m^2] => >= 0 ! + !! *pQnsol* surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + !! *pustar* friction velocity u* [m/s] + !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] + !! *pQlat* surface latent heat flux [K] + !!------------------------------------------------------------------ + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQlat ! latent heat flux [W/m^2] + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jc + REAL(wp) :: zQabs, zdlt, zfr, zalfa, zqlat, zus + !!--------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + + zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, + ! ! => we DO not miss a lot assuming 0 solar flux absorbed in the tiny layer of thicknes zdlt... + + zalfa = alpha_sw(pSST(ji,jj)) ! (crude) thermal expansion coefficient of sea-water [1/K] + zqlat = pQlat(ji,jj) + zus = pustar(ji,jj) + + + zdlt = delta_skin_layer( zalfa, zQabs, zqlat, zus ) + + DO jc = 1, 4 ! because implicit in terms of zdlt... + zfr = MAX( 0.137_wp + 11._wp*zdlt & + & - 6.6E-5_wp/zdlt*(1._wp - EXP(-zdlt/8.E-4_wp)) & + & , 0.01_wp ) ! Solar absorption, Eq.16 (Fairall al. 1996b) + ! !LB: why 0.065 and not 0.137 like in the paper??? Beljaars & Zeng use 0.065, not 0.137 ! + zQabs = pQnsol(ji,jj) + zfr*pQsw(ji,jj) + zdlt = delta_skin_layer( zalfa, zQabs, zqlat, zus ) + END DO + + dT_cs(ji,jj) = zQabs*zdlt/rk0_w ! temperature increment, yes dT_cs can actually > 0, if Qabs > 0 (rare but possible!) + + END DO ; END DO + + END SUBROUTINE CS_COARE + + + SUBROUTINE WL_COARE( pQsw, pQnsol, pTau, pSST, iwait ) + !!--------------------------------------------------------------------- + !! + !! Warm-Layer scheme according to COARE 3.6 (Fairall et al, 2019) + !! ------------------------------------------------------------------ + !! + !! ** INPUT: + !! *pQsw* surface net solar radiation into the ocean [W/m^2] => >= 0 ! + !! *pQnsol* surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + !! *pTau* surface wind stress [N/m^2] + !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] + !! *iwait* if /= 0 then wait before updating accumulated fluxes, we are within a converging itteration loop... + !!--------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTau ! wind stress [N/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] + INTEGER , INTENT(in) :: iwait ! if /= 0 then wait before updating accumulated fluxes + !! + INTEGER :: ji,jj + ! + REAL(wp) :: zdTwl, zHwl, zQabs, zfr + REAL(wp) :: zqac, ztac + REAL(wp) :: zalfa, zcd1, zcd2, flg + !!--------------------------------------------------------------------- + + REAL(wp) :: ztime, znoon, zmidn + INTEGER :: jl + + LOGICAL :: l_exit, l_destroy_wl + + !! INITIALIZATION: + zQabs = 0._wp ! total heat flux absorped in warm layer + zfr = zfr0 ! initial value of solar flux absorption !#LB: save it and use previous value !!! + + IF( .NOT. ln_dm2dc ) CALL sbc_dcy_param() ! we need to call sbc_dcy_param (sbcdcy.F90) because rdawn_dcy and rdusk_dcy are unkonwn otherwize! + + ztime = REAL(nsec_day,wp)/(24._wp*3600._wp) ! time of current time step since 00:00 for current day (UTC) -> ztime = 0 -> 00:00 / ztime = 0.5 -> 12:00 ... + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + + l_exit = .FALSE. + l_destroy_wl = .FALSE. + + zdTwl = dT_wl(ji,jj) ! value of previous time step as first guess + zHwl = MAX( MIN(Hz_wl(ji,jj),Hwl_max),0.1_wp) ! " " " + + zqac = Qnt_ac(ji,jj) ! previous time step Qnt_ac + ztac = Tau_ac(ji,jj) + + !***** variables for warm layer *** + zalfa = alpha_sw( pSST(ji,jj) ) ! (crude) thermal expansion coefficient of sea-water [1/K] (SST accurate enough!) + + zcd1 = SQRT(2._wp*rich*rCp0_w/(zalfa*grav*rho0_w)) !mess-o-constants 1 + zcd2 = SQRT(2._wp*zalfa*grav/(rich*rho0_w))/(rCp0_w**1.5) !mess-o-constants 2 + + + znoon = MOD( 0.5_wp*(rdawn_dcy(ji,jj)+rdusk_dcy(ji,jj)), 1._wp ) ! 0 rnoon*24 = UTC time of local noon + zmidn = MOD( znoon-0.5_wp , 1._wp ) + zmidn = MOD( zmidn + 0.125_wp , 1._wp ) ! 3 hours past the local midnight + + IF( (ztime >= zmidn) .AND. (ztime < rdawn_dcy(ji,jj)) ) THEN + ! Dawn reset to 0! + l_exit = .TRUE. + l_destroy_wl = .TRUE. + ENDIF + + IF( .NOT. l_exit ) THEN + !! Initial test on initial guess of absorbed heat flux in warm-layer: + zQabs = frac_solar_abs(zHwl)*pQsw(ji,jj) + pQnsol(ji,jj) ! first guess of tot. heat flux absorbed in warm layer + ! ! => #LB: depends of zfr, which is wild guess... Wrong!!! + IF( (ABS(zdTwl) < 1.E-6_wp) .AND. (zQabs <= 0._wp) ) THEN + ! We have not started to build a WL yet (dT==0) and there's no way it can occur now + ! since zQabs <= 0._wp + ! => no need to go further + l_exit = .TRUE. + ENDIF + + ENDIF + + ! Okay test on updated absorbed flux: + !#LB: remove??? has a strong influence !!! + IF( (.NOT. l_exit).AND.(Qnt_ac(ji,jj) + zQabs*rn_Dt <= 0._wp) ) THEN + l_exit = .TRUE. + l_destroy_wl = .TRUE. + ENDIF + + + IF( .NOT. l_exit) THEN + + ! Two possibilities at this point: + ! 1/ A warm layer already exists (dT>0) but it is cooling down because Qabs<0 + ! 2/ Regardless of WL formed (dT==0 or dT>0), we are in the process to initiate one or warm further it ! + + ztac = Tau_ac(ji,jj) + MAX(.002_wp , pTau(ji,jj))*rn_Dt ! updated momentum integral + !PRINT *, '#LBD: updated value for Tac=', REAL(ztac,4) + + !! We update the value of absorbtion and zQabs: + !! some part is useless if Qsw=0 !!! + DO jl = 1, 5 + zQabs = frac_solar_abs(zHwl)*pQsw(ji,jj) + pQnsol(ji,jj) + zqac = Qnt_ac(ji,jj) + zQabs*rn_Dt ! updated heat absorbed + IF( zqac <= 0._wp ) EXIT + zHwl = MAX( MIN( Hwl_max , zcd1*ztac/SQRT(zqac)) , 0.1_wp ) ! Warm-layer depth + END DO + + IF( zqac <= 0._wp ) THEN + l_destroy_wl = .TRUE. + l_exit = .TRUE. + ELSE + zdTwl = zcd2*zqac**1.5/ztac * MAX(zqac/ABS(zqac),0._wp) !! => IF(zqac>0._wp): zdTwl=zcd2*zqac**1.5/ztac ; ELSE: zdTwl=0. / ! normally: zqac > 0 ! + !PRINT *, '#LBD: updated preliminary value for dT_wl=', REAL(zdTwl,4) + ! Warm layer correction + flg = 0.5_wp + SIGN( 0.5_wp , gdept_1d(1)-zHwl ) ! => 1 when gdept_1d(1)>zHwl (zdTwl = zdTwl) | 0 when gdept_1d(1) term "Q + Rs*fs" in eq.6 of Fairall et al. 1996 + REAL(wp), INTENT(in) :: pQlat ! latent heat flux [W/m^2] + REAL(wp), INTENT(in) :: pustar_a ! friction velocity in the air (u*) [m/s] + !!--------------------------------------------------------------------- + REAL(wp) :: zusw, zusw2, zlamb, zQd, ztf, ztmp + !!--------------------------------------------------------------------- + + zQd = pQd + 0.026*MIN(pQlat,0._wp)*rCp0_w/rLevap/palpha ! #LB: Double check sign + division by palpha !!! units are okay! + + ztf = 0.5_wp + SIGN(0.5_wp, zQd) ! Qabs < 0 => cooling of the viscous layer => ztf = 0 (regular case) + ! ! Qabs > 0 => warming of the viscous layer => ztf = 1 (ex: weak evaporation and strong positive sensible heat flux) + ! + zusw = MAX(pustar_a, 1.E-4_wp) * sq_radrw ! u* in the water + zusw2 = zusw*zusw + ! + zlamb = 6._wp*( 1._wp + MAX(palpha*rcst_cs/(zusw2*zusw2)*zQd, 0._wp)**0.75 )**(-1./3.) ! see Eq.(14) in Fairall et al., 1996 + ! => zlamb is not used when Qd > 0, and since rcst_cs < 0, we just use this "MAX" to prevent FPE errors (something_negative)**0.75 + ! + ztmp = rnu0_w/zusw + delta_skin_layer = (1._wp-ztf) * zlamb*ztmp & ! regular case, Qd < 0, see Eq.(12) in Fairall et al., 1996 + & + ztf * MIN(6._wp*ztmp , 0.007_wp) ! when Qd > 0 + END FUNCTION delta_skin_layer + + + FUNCTION frac_solar_abs( pHwl ) + !!--------------------------------------------------------------------- + !! Fraction of solar heat flux absorbed inside warm layer + !!--------------------------------------------------------------------- + REAL(wp) :: frac_solar_abs + REAL(wp), INTENT(in) :: pHwl ! thickness of warm-layer [m] + !!--------------------------------------------------------------------- + frac_solar_abs = 1._wp - ( 0.28*0.014 *(1._wp - EXP(-pHwl/0.014)) & + & + 0.27*0.357*(1._wp - EXP(-pHwl/0.357)) & + & + 0.45*12.82*(1-EXP(-pHwl/12.82)) ) / pHwl + END FUNCTION frac_solar_abs + + !!====================================================================== +END MODULE sbcblk_skin_coare diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_skin_ecmwf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_skin_ecmwf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8c9b8d3bc68d6b8012698fb524d52e76fe56ecba --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcblk_skin_ecmwf.f90 @@ -0,0 +1,326 @@ + + + + + + + + + + + + + +MODULE sbcblk_skin_ecmwf + !!====================================================================== + !! *** MODULE sbcblk_skin_ecmwf *** + !! + !! Module that gathers the cool-skin and warm-layer parameterization used + !! by the IFS at ECMWF (recoded from scratch => + !! https://github.com/brodeau/aerobulk) + !! + !! Mainly based on Zeng & Beljaars, 2005 with the more recent add-up from + !! Takaya et al., 2010 when it comes to the warm-layer parameterization + !! (contribution of extra mixing due to Langmuir circulation) + !! + !! - Zeng X., and A. Beljaars, 2005: A prognostic scheme of sea surface skin + !! temperature for modeling and data assimilation. Geophysical Research + !! Letters, 32 (14) , pp. 1-4. + !! + !! - Takaya, Y., J.-R. Bildot, A. C. M. Beljaars, and P. A. E. M. Janssen, + !! 2010: Refinements to a prognostic scheme of skin sea surface + !! temperature. J. Geophys. Res., 115, C06009, doi:10.1029/2009JC005985 + !! + !! Most of the formula are taken from the documentation of IFS of ECMWF + !! (cycle 40r1) (avaible online on the ECMWF's website) + !! + !! Routine 'sbcblk_skin_ecmwf' also maintained and developed in AeroBulk (as + !! 'mod_skin_ecmwf') + !! (https://github.com/brodeau/aerobulk) + !! + !! ** Author: L. Brodeau, November 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2019-11 (L.Brodeau) Original code + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce ! Surface boundary condition: ocean fields + + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + USE lib_mpp ! distribued memory computing library + USE in_out_manager ! I/O manager + USE lib_fortran ! to use key_nosignedzero + + IMPLICIT NONE + PRIVATE + + PUBLIC :: CS_ECMWF, WL_ECMWF + !! * Substitutions + + + + + + !! Cool-skin related parameters: + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_cs !: dT due to cool-skin effect + ! ! => temperature difference between air-sea interface (z=0) + ! ! and right below viscous layer (z=delta) + + !! Warm-layer related parameters: + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_wl !: dT due to warm-layer effect + ! ! => difference between "almost surface (right below + ! ! viscous layer, z=delta) and depth of bulk SST (z=gdept_1d(1)) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Hz_wl !: depth (aka thickness) of warm-layer [m] + ! + REAL(wp), PARAMETER, PUBLIC :: rd0 = 3. !: Depth scale [m] of warm layer, "d" in Eq.11 (Zeng & Beljaars 2005) + REAL(wp), PARAMETER :: zRhoCp_w = rho0_w*rCp0_w + ! + REAL(wp), PARAMETER :: rNuwl0 = 0.5 !: Nu (exponent of temperature profile) Eq.11 + ! !: (Zeng & Beljaars 2005) !: set to 0.5 instead of + ! !: 0.3 to respect a warming of +3 K in calm + ! !: condition for the insolation peak of +1000W/m^2 + !!---------------------------------------------------------------------- +CONTAINS + + + SUBROUTINE CS_ECMWF( pQsw, pQnsol, pustar, pSST ) + !!--------------------------------------------------------------------- + !! + !! Cool-skin parameterization, based on Fairall et al., 1996: + !! + !! - Zeng X., and A. Beljaars, 2005: A prognostic scheme of sea surface + !! skin temperature for modeling and data assimilation. Geophysical + !! Research Letters, 32 (14) , pp. 1-4. + !! + !!------------------------------------------------------------------ + !! + !! ** INPUT: + !! *pQsw* surface net solar radiation into the ocean [W/m^2] => >= 0 ! + !! *pQnsol* surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + !! *pustar* friction velocity u* [m/s] + !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] + !!------------------------------------------------------------------ + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K] + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jc + REAL(wp) :: zQabs, zdlt, zfr, zalfa, zus + !!--------------------------------------------------------------------- + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + + zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, + ! ! => we DO not miss a lot assuming 0 solar flux absorbed in the tiny layer of thicknes zdlt... + + zalfa = alpha_sw(pSST(ji,jj)) ! (crude) thermal expansion coefficient of sea-water [1/K] + zus = pustar(ji,jj) + + zdlt = delta_skin_layer( zalfa, zQabs, zus ) + + DO jc = 1, 4 ! because implicit in terms of zdlt... + zfr = MAX( 0.065_wp + 11._wp*zdlt & + & - 6.6E-5_wp/zdlt*(1._wp - EXP(-zdlt/8.E-4_wp)) & + & , 0.01_wp ) ! Solar absorption, Eq.(5) Zeng & Beljaars, 2005 + ! ! => (WARNING: 0.065 rather than 0.137 in Fairal et al. 1996) + zQabs = pQnsol(ji,jj) + zfr*pQsw(ji,jj) + zdlt = delta_skin_layer( zalfa, zQabs, zus ) + END DO + + dT_cs(ji,jj) = zQabs*zdlt/rk0_w ! temperature increment, yes dT_cs can actually > 0, if Qabs > 0 (rare but possible!) + + END DO ; END DO + + END SUBROUTINE CS_ECMWF + + + SUBROUTINE WL_ECMWF( pQsw, pQnsol, pustar, pSST, pustk ) + !!--------------------------------------------------------------------- + !! + !! Warm-Layer scheme according to Zeng & Beljaars, 2005 (GRL) with the + !! more recent add-up from Takaya et al., 2010 when it comes to the + !! warm-layer parameterization (contribution of extra mixing due to + !! Langmuir circulation) + !! + !! - Zeng X., and A. Beljaars, 2005: A prognostic scheme of sea surface skin + !! temperature for modeling and data assimilation. Geophysical Research + !! Letters, 32 (14) , pp. 1-4. + !! + !! - Takaya, Y., J.-R. Bildot, A. C. M. Beljaars, and P. A. E. M. Janssen, + !! 2010: Refinements to a prognostic scheme of skin sea surface + !! temperature. J. Geophys. Res., 115, C06009, doi:10.1029/2009JC005985 + !! + !! STIL NO PROGNOSTIC EQUATION FOR THE DEPTH OF THE WARM-LAYER! + !! + !! ------------------------------------------------------------------ + !! + !! ** INPUT: + !! *pQsw* surface net solar radiation into the ocean [W/m^2] => >= 0 ! + !! *pQnsol* surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + !! *pustar* friction velocity u* [m/s] + !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] + !!------------------------------------------------------------------ + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] + !! + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pustk ! surface Stokes velocity [m/s] + ! + INTEGER :: ji, jj, jc + ! + REAL(wp) :: zHwl !: thickness of the warm-layer [m] + REAL(wp) :: ztcorr !: correction of dT w.r.t measurement depth of bulk SST (first T-point) + REAL(wp) :: zalfa !: thermal expansion coefficient of sea-water [1/K] + REAL(wp) :: zdTwl_b, zdTwl_n !: temp. diff. between "almost surface (right below viscous layer) and bottom of WL + REAL(wp) :: zfr, zeta + REAL(wp) :: zusw, zusw2 + REAL(wp) :: zLa, zfLa + REAL(wp) :: flg, zwf, zQabs + REAL(wp) :: ZA, ZB, zL1, zL2 + REAL(wp) :: zcst0, zcst1, zcst2, zcst3 + ! + LOGICAL :: l_pustk_known + !!--------------------------------------------------------------------- + + l_pustk_known = .FALSE. + IF( PRESENT(pustk) ) l_pustk_known = .TRUE. + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + + zHwl = Hz_wl(ji,jj) ! first guess for warm-layer depth (and unique..., less advanced than COARE3p6 !) + ! it is = rd0 (3m) in default Zeng & Beljaars case... + + !! Previous value of dT / warm-layer, adapted to depth: + flg = 0.5_wp + SIGN( 0.5_wp , gdept_1d(1)-zHwl ) ! => 1 when gdept_1d(1)>zHwl (dT_wl(ji,jj) = zdTwl) | 0 when z_s$ + ztcorr = flg + (1._wp - flg)*gdept_1d(1)/zHwl + zdTwl_b = MAX ( dT_wl(ji,jj) / ztcorr , 0._wp ) + ! zdTwl is the difference between "almost surface (right below viscous layer) and bottom of WL (here zHwl) + ! pdT " " and depth of bulk SST (here gdept_1d(1))! + !! => but of course in general the bulk SST is taken shallower than zHwl !!! So correction less pronounced! + !! => so here since pdT is difference between surface and gdept_1d(1), need to increase fof zdTwl ! + + zalfa = alpha_sw( pSST(ji,jj) ) ! (crude) thermal expansion coefficient of sea-water [1/K] (SST accurate enough!) + + ! *** zfr = Fraction of solar radiation absorbed in warm layer (-) + zfr = 1._wp - 0.28_wp*EXP(-71.5_wp*zHwl) - 0.27_wp*EXP(-2.8_wp*zHwl) - 0.45_wp*EXP(-0.07_wp*zHwl) !: Eq. 8.157 + + zQabs = zfr*pQsw(ji,jj) + pQnsol(ji,jj) ! tot heat absorbed in warm layer + + zusw = MAX( pustar(ji,jj), 1.E-4_wp ) * sq_radrw ! u* in the water + zusw2 = zusw*zusw + + ! Langmuir: + IF( l_pustk_known ) THEN + zLa = SQRT(zusw/MAX(pustk(ji,jj),1.E-6)) + ELSE + zla = 0.3_wp + ENDIF + zfLa = MAX( zla**(-2._wp/3._wp) , 1._wp ) ! Eq.(6) + + zwf = 0.5_wp + SIGN(0.5_wp, zQabs) ! zQabs > 0. => 1. / zQabs < 0. => 0. + + zcst1 = vkarmn*grav*zalfa + + ! 1/L when zQabs > 0 : + zL2 = zcst1*zQabs / (zRhoCp_w*zusw2*zusw) + + zcst2 = zcst1 / ( 5._wp*zHwl*zusw2 ) !OR: zcst2 = zcst1*rNuwl0 / ( 5._wp*zHwl*zusw2 ) ??? + + zcst0 = rn_Dt * (rNuwl0 + 1._wp) / zHwl + + ZA = zcst0 * zQabs / ( rNuwl0 * zRhoCp_w ) + + zcst3 = -zcst0 * vkarmn * zusw * zfLa + + !! Sorry about all these constants ( constant w.r.t zdTwl), it's for + !! the sake of optimizations... So all these operations are not done + !! over and over within the iteration loop... + + !! T R U L L Y I M P L I C I T => needs itteration + !! => have to itterate just because the 1/(Monin-Obukhov length), zL1, uses zdTwl when zQabs < 0.. + !! (without this term otherwize the implicit analytical solution is straightforward...) + zdTwl_n = zdTwl_b + DO jc = 1, 10 + + zdTwl_n = 0.5_wp * ( zdTwl_n + zdTwl_b ) ! semi implicit, for faster convergence + + ! 1/L when zdTwl > 0 .AND. zQabs < 0 : + zL1 = SQRT( zdTwl_n * zcst2 ) ! / zusw !!! Or??? => vkarmn * SQRT( zdTwl_n*grav*zalfa/( 5._wp*zHwl ) ) / zusw + + ! Stability parameter (z/L): + zeta = (1._wp - zwf) * zHwl*zL1 + zwf * zHwl*zL2 + + ZB = zcst3 / PHI(zeta) + + zdTwl_n = MAX ( zdTwl_b + ZA + ZB*zdTwl_n , 0._wp ) ! Eq.(6) + + END DO + + !! Update: + dT_wl(ji,jj) = zdTwl_n * ztcorr + + END DO ; END DO + + END SUBROUTINE WL_ECMWF + + + FUNCTION delta_skin_layer( palpha, pQd, pustar_a ) + !!--------------------------------------------------------------------- + !! Computes the thickness (m) of the viscous skin layer. + !! Based on Fairall et al., 1996 + !! + !! Fairall, C. W., Bradley, E. F., Godfrey, J. S., Wick, G. A., + !! Edson, J. B., and Young, G. S. ( 1996), Cool‐skin and warm‐layer + !! effects on sea surface temperature, J. Geophys. Res., 101( C1), 1295-1308, + !! doi:10.1029/95JC03190. + !! + !! L. Brodeau, october 2019 + !!--------------------------------------------------------------------- + REAL(wp) :: delta_skin_layer + REAL(wp), INTENT(in) :: palpha ! thermal expansion coefficient of sea-water (SST accurate enough!) + REAL(wp), INTENT(in) :: pQd ! < 0 !!! part of the net heat flux actually absorbed in the WL [W/m^2] + ! ! => term "Q + Rs*fs" in eq.6 of Fairall et al. 1996 + REAL(wp), INTENT(in) :: pustar_a ! friction velocity in the air (u*) [m/s] + !!--------------------------------------------------------------------- + REAL(wp) :: zusw, zusw2, zlamb, ztf, ztmp + !!--------------------------------------------------------------------- + ztf = 0.5_wp + SIGN(0.5_wp, pQd) ! Qabs < 0 => cooling of the viscous layer => ztf = 0 (regular case) + ! ! Qabs > 0 => warming of the viscous layer => ztf = 1 + ! ! (ex: weak evaporation and strong positive sensible heat flux) + zusw = MAX(pustar_a, 1.E-4_wp) * sq_radrw ! u* in the water + zusw2 = zusw*zusw + ! + zlamb = 6._wp*( 1._wp + MAX(palpha*rcst_cs/(zusw2*zusw2)*pQd, 0._wp)**0.75 )**(-1./3.) ! see Eq.(14) in Fairall et al., 1996 + ! => zlamb is not used when Qd > 0, and since rcst_cs < 0, we just use this "MAX" to prevent FPE errors (something_negative)**0.75 + ! + ztmp = rnu0_w/zusw + delta_skin_layer = (1._wp-ztf) * zlamb*ztmp & ! regular case, Qd < 0, see Eq.(12) in Fairall et al., 1996 + & + ztf * MIN(6._wp*ztmp , 0.007_wp) ! when Qd > 0 + END FUNCTION delta_skin_layer + + + FUNCTION PHI( pzeta) + !!--------------------------------------------------------------------- + !! + !! Takaya et al., 2010 + !! Eq.(5) + !! L. Brodeau, october 2019 + !!--------------------------------------------------------------------- + REAL(wp) :: PHI + REAL(wp), INTENT(in) :: pzeta ! stability parameter + !!--------------------------------------------------------------------- + REAL(wp) :: ztf, zzt2 + !!--------------------------------------------------------------------- + zzt2 = pzeta*pzeta + ztf = 0.5_wp + SIGN(0.5_wp, pzeta) ! zeta > 0 => ztf = 1 + ! ! zeta < 0 => ztf = 0 + PHI = ztf * ( 1. + (5.*pzeta + 4.*zzt2)/(1. + 3.*pzeta + 0.25*zzt2) ) & ! zeta > 0 + & + (1. - ztf) * 1./SQRT( 1. - 16.*(-ABS(pzeta)) ) ! zeta < 0 + END FUNCTION PHI + + !!====================================================================== +END MODULE sbcblk_skin_ecmwf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcclo.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcclo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ad26bc7752125d217ff6cda8bc61d5b6ff2b9ebc --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcclo.f90 @@ -0,0 +1,365 @@ + + + + + + + + + + + + + +MODULE sbcclo + !!====================================================================== + !! *** MODULE sbcclo *** + !! Ocean forcing: redistribution of emp unbalance over closed sea into river mouth or open ocean + !!===================================================================== + !! History : 4.0 and earlier ! see closea.F90 history + !! NEMO 4.1 ! 2019-09 (P. Mathiot) rewrite sbc_clo module to match new closed sea mask definition (original sbcclo.F90) + !! + !!---------------------------------------------------------------------- + ! + !!---------------------------------------------------------------------- + !! Public subroutines: + !! sbc_clo : update emp and qns over target area and source area + !! sbc_clo_init : initialise all variable needed for closed sea correction + !! + !! Private subroutines: + !! alloc_csarr : allocate closed sea array + !! get_cssrcsurf : compute source surface area + !! get_cstrgsurf : compute target surface area + !! prt_csctl : closed sea control print + !! sbc_csupdate : compute net fw from closed sea + !!---------------------------------------------------------------------- + ! + USE closea ! closed sea + USE in_out_manager ! I/O manager + ! + USE dom_oce, ONLY: e1e2t ! ocean space and time domain + USE phycst , ONLY: rcp ! physical constants + USE sbc_oce, ONLY: emp, qns, rnf, sst_m ! ocean surface boundary conditions + USE iom , ONLY: iom_put ! I/O routines + USE lib_fortran, ONLY: glob_sum ! fortran library + USE lib_mpp , ONLY: mpp_min, ctl_stop ! MPP library + ! + IMPLICIT NONE + ! + PRIVATE + ! + PUBLIC sbc_clo + PUBLIC sbc_clo_init + ! + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcg, rsurftrgg !: closed sea source/target glo surface areas + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcr, rsurftrgr !: closed sea source/target rnf surface areas + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrce, rsurftrge !: closed sea source/target emp surface areas + ! + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: mcsgrpg, mcsgrpr, mcsgrpe !: closed sea group for glo, rnf and emp + ! + CONTAINS + ! + !!---------------------------------------------------------------------- + !! Public subroutines + !!---------------------------------------------------------------------- + ! + SUBROUTINE sbc_clo_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_clo_init *** + !! + !! ** Purpose : Initialisation of the variable needed for the net fw closed sea correction + !! + !! ** Method : - compute source surface area for each closed sea + !! - defined the group of each closed sea + !! (needed to manage multiple closed sea and one target area like great lakes / St Laurent outlet) + !! - compute target surface area + !!---------------------------------------------------------------------- + ! + ! 0. Allocate cs variables (surf) + CALL alloc_csarr( ncsg, rsurfsrcg, rsurftrgg, mcsgrpg ) + CALL alloc_csarr( ncsr, rsurfsrcr, rsurftrgr, mcsgrpr ) + CALL alloc_csarr( ncse, rsurfsrce, rsurftrge, mcsgrpe ) + ! + ! 1. compute source surface area + CALL get_cssrcsurf( ncsg, mask_csglo, rsurfsrcg ) + CALL get_cssrcsurf( ncsr, mask_csrnf, rsurfsrcr ) + CALL get_cssrcsurf( ncse, mask_csemp, rsurfsrce ) + ! + ! 2. compute target surface area and group number (mcsgrp) for all cs and cases + ! glo could be simpler but for lisibility, all treated the same way + ! It is only done once, so not a big deal + CALL get_cstrgsurf( ncsg, mask_csglo, mask_csgrpglo, rsurftrgg, mcsgrpg ) + CALL get_cstrgsurf( ncsr, mask_csrnf, mask_csgrprnf, rsurftrgr, mcsgrpr ) + CALL get_cstrgsurf( ncse, mask_csemp, mask_csgrpemp, rsurftrge, mcsgrpe ) + ! + ! 3. print out in ocean.ouput + IF ( lwp ) WRITE(numout,*) 'sbc_clo_init : compute surface area for source (closed sea) and target (river mouth)' + IF ( lwp ) WRITE(numout,*) '~~~~~~~~~~~~~~' + CALL prt_csctl( ncsg, rsurfsrcg, rsurftrgg, mcsgrpg, 'glo' ) + CALL prt_csctl( ncsr, rsurfsrcr, rsurftrgr, mcsgrpr, 'rnf' ) + CALL prt_csctl( ncse, rsurfsrce, rsurftrge, mcsgrpe, 'emp' ) + + END SUBROUTINE sbc_clo_init + + SUBROUTINE sbc_clo( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_clo *** + !! + !! ** Purpose : Special handling of closed seas + !! + !! ** Method : Water flux is forced to zero over closed sea + !! Excess is shared between remaining ocean, or + !! put as run-off in open ocean. + !! + !! ** Action : - compute surface freshwater fluxes and associated heat content flux at kt + !! - output closed sea contribution to fw and heat budget + !! - update emp and qns + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean model time step + ! + REAL(wp), DIMENSION(jpi,jpj) :: zwcs, zqcs ! water flux and heat flux correction due to closed seas + !!---------------------------------------------------------------------- + ! + ! 0. initialisation + zwcs(:,:) = 0._wp ; zqcs(:,:) = 0._wp + ! + ! 1. update emp and qns + CALL sbc_csupdate( ncsg, mcsgrpg, mask_csglo, mask_csgrpglo, rsurfsrcg, rsurftrgg, 'glo', mask_opnsea, rsurftrgg, zwcs, zqcs ) + CALL sbc_csupdate( ncsr, mcsgrpr, mask_csrnf, mask_csgrprnf, rsurfsrcr, rsurftrgr, 'rnf', mask_opnsea, rsurftrgg, zwcs, zqcs ) + CALL sbc_csupdate( ncse, mcsgrpe, mask_csemp, mask_csgrpemp, rsurfsrce, rsurftrge, 'emp', mask_opnsea, rsurftrgg, zwcs, zqcs ) + ! + ! 2. ouput closed sea contributions + CALL iom_put('wclosea',zwcs) + CALL iom_put('qclosea',zqcs) + ! + ! 3. update emp and qns + emp(:,:) = emp(:,:) + zwcs(:,:) + qns(:,:) = qns(:,:) + zqcs(:,:) + ! + END SUBROUTINE sbc_clo + ! + !!---------------------------------------------------------------------- + !! Private subroutines + !!---------------------------------------------------------------------- + ! + SUBROUTINE get_cssrcsurf(kncs, kmaskcs, psurfsrc) + !!----------------------------------------------------------------------- + !! *** routine get_cssrcsurf *** + !! + !! ** Purpose : compute closed sea (source) surface area + !!---------------------------------------------------------------------- + ! subroutine parameters + INTEGER , INTENT(in ) :: kncs ! closed sea number + INTEGER , DIMENSION(:,:), INTENT(in ) :: kmaskcs ! closed sea mask + REAL(wp), DIMENSION(:) , INTENT( out) :: psurfsrc ! source surface area + + ! local variables + INTEGER :: jcs ! loop index + INTEGER, DIMENSION(jpi,jpj) :: imsksrc ! source mask + !!---------------------------------------------------------------------- + ! + DO jcs = 1,kncs ! loop over closed seas + ! + ! 0. build river mouth mask for this lake + WHERE ( kmaskcs == jcs ) + imsksrc = 1 + ELSE WHERE + imsksrc = 0 + END WHERE + ! + ! 1. compute target area + psurfsrc(jcs) = glob_sum('closea', e1e2t(:,:) * imsksrc(:,:) ) + ! + END DO ! jcs + + END SUBROUTINE get_cssrcsurf + + SUBROUTINE get_cstrgsurf(kncs, kmaskcs, kmaskcsgrp, psurftrg, kcsgrp ) + !!----------------------------------------------------------------------- + !! *** routine get_cstrgsurf *** + !! + !! ** Purpose : compute closed sea (target) surface area + !!---------------------------------------------------------------------- + ! subroutine parameters + ! input + INTEGER, INTENT(in ) :: kncs ! closed sea number + INTEGER, DIMENSION(:,:), INTENT(in ) :: kmaskcs, kmaskcsgrp ! closed sea and group mask + + ! output + INTEGER , DIMENSION(:) , INTENT( out) :: kcsgrp ! closed sea group number + REAL(wp), DIMENSION(:) , INTENT( out) :: psurftrg ! target surface area + + ! local variables + INTEGER :: jcs, jtmp ! tmp + INTEGER, DIMENSION(jpi,jpj) :: imskgrp, imsksrc, imsktrg, imsk ! tmp group, source, target and tmp mask + !!---------------------------------------------------------------------- + ! + DO jcs = 1,kncs ! loop over closed seas + ! + !! 0. find group number for cs number jcs + imskgrp(:,:) = kmaskcsgrp(:,:) + imsksrc(:,:) = kmaskcs(:,:) + ! + ! set cs value where cs is defined + ! imsk = HUGE outside the cs id jcs + imsk(:,:) = HUGE(1) + WHERE ( imsksrc(:,:) == jcs ) imsk(:,:) = jcs + ! + ! jtmp = jcs - group id for this lake + imsk(:,:) = imsk(:,:) - imskgrp(:,:) + jtmp = MINVAL(imsk(:,:)) ; CALL mpp_min('closea',jtmp) + ! kcsgrp = group id corresponding to the cs id jcs + ! kcsgrp(jcs)=(jcs - (jcs - group id))=group id + kcsgrp(jcs) = jcs - jtmp + ! + !! 1. build the target river mouth mask for this lake + WHERE ( imskgrp(:,:) * mask_opnsea(:,:) == kcsgrp(jcs) ) + imsktrg(:,:) = 1 + ELSE WHERE + imsktrg(:,:) = 0 + END WHERE + ! + !! 2. compute target area + psurftrg(jcs) = glob_sum('closea', e1e2t(:,:) * imsktrg(:,:) ) + ! + END DO ! jcs + + END SUBROUTINE get_cstrgsurf + + SUBROUTINE prt_csctl(kncs, psurfsrc, psurftrg, kcsgrp, cdcstype) + !!----------------------------------------------------------------------- + !! *** routine prt_csctl *** + !! + !! ** Purpose : output information about each closed sea (src id, trg id, src area and trg area) + !!---------------------------------------------------------------------- + ! subroutine parameters + INTEGER, INTENT(in ) :: kncs ! closed sea number + INTEGER, DIMENSION(:) , INTENT(in ) :: kcsgrp ! closed sea group number + ! + REAL(wp), DIMENSION(:), INTENT(in ) :: psurfsrc, psurftrg ! source and target surface area + ! + CHARACTER(LEN=3) , INTENT(in ) :: cdcstype ! closed sea scheme used for redistribution + !!---------------------------------------------------------------------- + ! local variable + INTEGER :: jcs + !!---------------------------------------------------------------------- + ! + IF ( lwp .AND. kncs > 0 ) THEN + WRITE(numout,*)'' + ! + WRITE(numout,*)'Closed sea target ',TRIM(cdcstype),' : ' + ! + DO jcs = 1,kncs + WRITE(numout,FMT='(3a,i3,a,i3)') ' ',TRIM(cdcstype),' closed sea id is ',jcs,' and trg group id is : ', kcsgrp(jcs) + WRITE(numout,FMT='(a,f12.2)' ) ' src surface areas (km2) : ', psurfsrc(jcs) * 1.0e-6 + WRITE(numout,FMT='(a,f12.2)' ) ' trg surface areas (km2) : ', psurftrg(jcs) * 1.0e-6 + END DO + ! + WRITE(numout,*)'' + END IF + + END SUBROUTINE prt_csctl + + SUBROUTINE sbc_csupdate(kncs, kcsgrp, kmsk_src, kmsk_grp, psurfsrc, psurftrg, cdcstype, kmsk_opnsea, psurf_opnsea, pwcs, pqcs) + !!----------------------------------------------------------------------- + !! *** routine sbc_csupdate *** + !! + !! ** Purpose : - compute the net freshwater fluxes over each closed seas + !! - apply correction to closed sea source/target net fwf accordingly + !!---------------------------------------------------------------------- + ! subroutine parameters + CHARACTER(LEN=3) , INTENT(in ) :: cdcstype ! closed sea scheme used for redistribution + ! + INTEGER, INTENT(in) :: kncs ! closed sea id + INTEGER, DIMENSION(: ), INTENT(in) :: kcsgrp ! closed sea group id + INTEGER, DIMENSION(:,:), INTENT(in) :: kmsk_src, kmsk_grp, kmsk_opnsea ! source, target, open ocean mask + + REAL(wp), DIMENSION(:) , INTENT(in ) :: psurfsrc, psurftrg, psurf_opnsea ! source, target and open ocean surface area + REAL(wp), DIMENSION(:,:), INTENT(inout) :: pwcs, pqcs ! water and heat flux correction due to closed seas + + + ! local variables + INTEGER :: jcs ! loop index over closed sea + INTEGER, DIMENSION(jpi,jpj) :: imsk_src, imsk_trg ! tmp array source and target closed sea masks + + REAL(wp) :: zcsfw, zcsh ! total fresh water and associated heat over one closed sea + REAL(wp) :: zcsfwf ! mean fresh water flux over one closed sea + REAL(wp) :: zsurftrg, zsurfsrc ! total target surface area + !!---------------------------------------------------------------------- + ! + DO jcs = 1, kncs ! loop over closed seas + ! + !! 0. get mask and surface of the closed sea + ! mask src + WHERE ( kmsk_src(:,:) == jcs ) + imsk_src(:,:) = 1 + ELSEWHERE + imsk_src(:,:) = 0 + END WHERE + ! area src + zsurfsrc = psurfsrc(jcs) + ! + !! 1. Work out net freshwater over the closed sea from EMP - RNF. + !! Work out net heat associated with the correction (needed for conservation) + !! (PM: should we consider used delayed glob sum ?) + zcsfw = glob_sum( 'closea', e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * imsk_src(:,:) ) + ! + !! 2. Deal with runoff special case (net evaporation spread globally) + !! and compute trg mask + IF (cdcstype == 'rnf' .AND. zcsfw > 0._wp) THEN + zsurftrg = psurf_opnsea(1) ! change the target area surface + imsk_trg = kcsgrp(jcs) * kmsk_opnsea ! trg mask is now the open sea mask + ELSE + zsurftrg = psurftrg(jcs) + imsk_trg = kmsk_grp * kmsk_opnsea + END IF + ! + IF( zsurftrg > 0._wp ) THEN ! target area /=0 + !! 3. Subtract residuals from source points + zcsfwf = zcsfw / zsurfsrc + pwcs(:,:) = pwcs(:,:) - zcsfwf * imsk_src(:,:) + pqcs(:,:) = pqcs(:,:) + rcp * zcsfwf * sst_m(:,:) * imsk_src(:,:) + ! + !! 4. Add residuals to target points + !! Do not use pqcs(:,:) = pqcs(:,:) - rcp * zcsfw * sst_m(:,:) / zsurftrg + !! as there is no reason heat will be conserved with this formulation + zcsh = glob_sum( 'closea', e1e2t(:,:) * rcp * zcsfwf * sst_m(:,:) * imsk_src(:,:) ) + WHERE( imsk_trg(:,:) == kcsgrp(jcs) ) + pwcs(:,:) = pwcs(:,:) + zcsfw / zsurftrg + pqcs(:,:) = pqcs(:,:) - zcsh / zsurftrg + ENDWHERE + ENDIF + ! + END DO ! jcs + + END SUBROUTINE sbc_csupdate + + SUBROUTINE alloc_csarr( klen, pvarsrc, pvartrg, kvargrp ) + !!----------------------------------------------------------------------- + !! *** routine alloc_cssurf *** + !! + !! ** Purpose : allocate closed sea surface array + !!---------------------------------------------------------------------- + ! subroutine parameters + INTEGER, INTENT(in) :: klen + INTEGER, ALLOCATABLE, DIMENSION(:), INTENT( out) :: kvargrp + REAL(wp), ALLOCATABLE, DIMENSION(:), INTENT( out) :: pvarsrc, pvartrg + ! + ! local variables + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + ! klen (number of lake) can be zero so use MAX(klen,1) to avoid 0 length array + ALLOCATE( pvarsrc(MAX(klen,1)) , pvartrg(MAX(klen,1)) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate surf array') + ! + ALLOCATE( kvargrp(MAX(klen,1)) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate group array') + ! + ! initialise to 0 + pvarsrc(:) = 0.e0_wp + pvartrg(:) = 0.e0_wp + kvargrp(:) = 0 + END SUBROUTINE alloc_csarr + +END MODULE diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbccpl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbccpl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9abaab0123436ee11f2d016840c7c677d2d41ae0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbccpl.f90 @@ -0,0 +1,2111 @@ + + + + + + + + + + + + + +MODULE sbccpl + !!====================================================================== + !! *** MODULE sbccpl *** + !! Surface Boundary Condition : momentum, heat and freshwater fluxes in coupled mode + !!====================================================================== + !! History : 2.0 ! 2007-06 (R. Redler, N. Keenlyside, W. Park) Original code split into flxmod & taumod + !! 3.0 ! 2008-02 (G. Madec, C Talandier) surface module + !! 3.1 ! 2009_02 (G. Madec, S. Masson, E. Maisonave, A. Caubel) generic coupled interface + !! 3.4 ! 2011_11 (C. Harris) more flexibility + multi-category fields + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) wave coupling updates + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! namsbc_cpl : coupled formulation namlist + !! sbc_cpl_init : initialisation of the coupled exchanges + !! sbc_cpl_rcv : receive fields from the atmosphere over the ocean (ocean only) + !! receive stress from the atmosphere over the ocean (ocean-ice case) + !! sbc_cpl_ice_tau : receive stress from the atmosphere over ice + !! sbc_cpl_ice_flx : receive fluxes from the atmosphere over ice + !! sbc_cpl_snd : send fields to the atmosphere + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE trc_oce ! share SMS/Ocean variables + USE sbc_ice ! Surface boundary condition: ice fields + USE sbcapr ! Stochastic param. : ??? + USE sbcdcy ! surface boundary condition: diurnal cycle + USE sbcwave ! surface boundary condition: waves + USE phycst ! physical constants + USE isf_oce , ONLY : l_isfoasis, fwfisf_oasis ! ice shelf boundary condition + USE cpl_oasis3 ! OASIS3 coupling + USE geo2ocean ! + USE oce , ONLY : ts, uu, vv, ssh, fraqsr_1lev + USE ocealb ! + USE eosbn2 ! + USE sbcrnf , ONLY : l_rnfcpl + ! + USE in_out_manager ! I/O manager + USE iom ! NetCDF library + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + + USE sbc_phy, ONLY : pp_cldf, rpref + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_cpl_init ! routine called by sbcmod.F90 + PUBLIC sbc_cpl_rcv ! routine called by icestp.F90 + PUBLIC sbc_cpl_snd ! routine called by step.F90 + PUBLIC sbc_cpl_ice_tau ! routine called by icestp.F90 + PUBLIC sbc_cpl_ice_flx ! routine called by icestp.F90 + PUBLIC sbc_cpl_alloc ! routine called in sbcice_cice.F90 + + INTEGER, PARAMETER :: jpr_otx1 = 1 ! 3 atmosphere-ocean stress components on grid 1 + INTEGER, PARAMETER :: jpr_oty1 = 2 ! + INTEGER, PARAMETER :: jpr_otz1 = 3 ! + INTEGER, PARAMETER :: jpr_otx2 = 4 ! 3 atmosphere-ocean stress components on grid 2 + INTEGER, PARAMETER :: jpr_oty2 = 5 ! + INTEGER, PARAMETER :: jpr_otz2 = 6 ! + INTEGER, PARAMETER :: jpr_itx1 = 7 ! 3 atmosphere-ice stress components on grid 1 + INTEGER, PARAMETER :: jpr_ity1 = 8 ! + INTEGER, PARAMETER :: jpr_itz1 = 9 ! + INTEGER, PARAMETER :: jpr_itx2 = 10 ! 3 atmosphere-ice stress components on grid 2 + INTEGER, PARAMETER :: jpr_ity2 = 11 ! + INTEGER, PARAMETER :: jpr_itz2 = 12 ! + INTEGER, PARAMETER :: jpr_qsroce = 13 ! Qsr above the ocean + INTEGER, PARAMETER :: jpr_qsrice = 14 ! Qsr above the ice + INTEGER, PARAMETER :: jpr_qsrmix = 15 + INTEGER, PARAMETER :: jpr_qnsoce = 16 ! Qns above the ocean + INTEGER, PARAMETER :: jpr_qnsice = 17 ! Qns above the ice + INTEGER, PARAMETER :: jpr_qnsmix = 18 + INTEGER, PARAMETER :: jpr_rain = 19 ! total liquid precipitation (rain) + INTEGER, PARAMETER :: jpr_snow = 20 ! solid precipitation over the ocean (snow) + INTEGER, PARAMETER :: jpr_tevp = 21 ! total evaporation + INTEGER, PARAMETER :: jpr_ievp = 22 ! solid evaporation (sublimation) + INTEGER, PARAMETER :: jpr_sbpr = 23 ! sublimation - liquid precipitation - solid precipitation + INTEGER, PARAMETER :: jpr_semp = 24 ! solid freshwater budget (sublimation - snow) + INTEGER, PARAMETER :: jpr_oemp = 25 ! ocean freshwater budget (evap - precip) + INTEGER, PARAMETER :: jpr_w10m = 26 ! 10m wind + INTEGER, PARAMETER :: jpr_dqnsdt = 27 ! d(Q non solar)/d(temperature) + INTEGER, PARAMETER :: jpr_rnf = 28 ! runoffs + INTEGER, PARAMETER :: jpr_cal = 29 ! calving + INTEGER, PARAMETER :: jpr_taum = 30 ! wind stress module + INTEGER, PARAMETER :: jpr_co2 = 31 + INTEGER, PARAMETER :: jpr_topm = 32 ! topmeltn + INTEGER, PARAMETER :: jpr_botm = 33 ! botmeltn + INTEGER, PARAMETER :: jpr_sflx = 34 ! salt flux + INTEGER, PARAMETER :: jpr_toce = 35 ! ocean temperature + INTEGER, PARAMETER :: jpr_soce = 36 ! ocean salinity + INTEGER, PARAMETER :: jpr_ocx1 = 37 ! ocean current on grid 1 + INTEGER, PARAMETER :: jpr_ocy1 = 38 ! + INTEGER, PARAMETER :: jpr_ssh = 39 ! sea surface height + INTEGER, PARAMETER :: jpr_fice = 40 ! ice fraction + INTEGER, PARAMETER :: jpr_e3t1st = 41 ! first T level thickness + INTEGER, PARAMETER :: jpr_fraqsr = 42 ! fraction of solar net radiation absorbed in the first ocean level + INTEGER, PARAMETER :: jpr_mslp = 43 ! mean sea level pressure + !** surface wave coupling ** + INTEGER, PARAMETER :: jpr_hsig = 44 ! Hsig + INTEGER, PARAMETER :: jpr_phioc = 45 ! Wave=>ocean energy flux + INTEGER, PARAMETER :: jpr_sdrftx = 46 ! Stokes drift on grid 1 + INTEGER, PARAMETER :: jpr_sdrfty = 47 ! Stokes drift on grid 2 + INTEGER, PARAMETER :: jpr_wper = 48 ! Mean wave period + INTEGER, PARAMETER :: jpr_wnum = 49 ! Mean wavenumber + INTEGER, PARAMETER :: jpr_wstrf = 50 ! Stress fraction adsorbed by waves + INTEGER, PARAMETER :: jpr_wdrag = 51 ! Neutral surface drag coefficient + INTEGER, PARAMETER :: jpr_charn = 52 ! Chranock coefficient + INTEGER, PARAMETER :: jpr_twox = 53 ! wave to ocean momentum flux + INTEGER, PARAMETER :: jpr_twoy = 54 ! wave to ocean momentum flux + INTEGER, PARAMETER :: jpr_tawx = 55 ! net wave-supported stress + INTEGER, PARAMETER :: jpr_tawy = 56 ! net wave-supported stress + INTEGER, PARAMETER :: jpr_bhd = 57 ! Bernoulli head. waves' induced surface pressure + INTEGER, PARAMETER :: jpr_tusd = 58 ! zonal stokes transport + INTEGER, PARAMETER :: jpr_tvsd = 59 ! meridional stokes tranmport + INTEGER, PARAMETER :: jpr_isf = 60 + INTEGER, PARAMETER :: jpr_icb = 61 + INTEGER, PARAMETER :: jpr_ts_ice = 62 ! Sea ice surface temp + !!INTEGER, PARAMETER :: jpr_qtrice = 63 ! Transmitted solar thru sea-ice + + INTEGER, PARAMETER :: jprcv = 62 ! total number of fields received + + INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction sent to the atmosphere + INTEGER, PARAMETER :: jps_toce = 2 ! ocean temperature + INTEGER, PARAMETER :: jps_tice = 3 ! ice temperature + INTEGER, PARAMETER :: jps_tmix = 4 ! mixed temperature (ocean+ice) + INTEGER, PARAMETER :: jps_albice = 5 ! ice albedo + INTEGER, PARAMETER :: jps_albmix = 6 ! mixed albedo + INTEGER, PARAMETER :: jps_hice = 7 ! ice thickness + INTEGER, PARAMETER :: jps_hsnw = 8 ! snow thickness + INTEGER, PARAMETER :: jps_ocx1 = 9 ! ocean current on grid 1 + INTEGER, PARAMETER :: jps_ocy1 = 10 ! + INTEGER, PARAMETER :: jps_ocz1 = 11 ! + INTEGER, PARAMETER :: jps_ivx1 = 12 ! ice current on grid 1 + INTEGER, PARAMETER :: jps_ivy1 = 13 ! + INTEGER, PARAMETER :: jps_ivz1 = 14 ! + INTEGER, PARAMETER :: jps_co2 = 15 + INTEGER, PARAMETER :: jps_soce = 16 ! ocean salinity + INTEGER, PARAMETER :: jps_ssh = 17 ! sea surface height + INTEGER, PARAMETER :: jps_qsroce = 18 ! Qsr above the ocean + INTEGER, PARAMETER :: jps_qnsoce = 19 ! Qns above the ocean + INTEGER, PARAMETER :: jps_oemp = 20 ! ocean freshwater budget (evap - precip) + INTEGER, PARAMETER :: jps_sflx = 21 ! salt flux + INTEGER, PARAMETER :: jps_otx1 = 22 ! 2 atmosphere-ocean stress components on grid 1 + INTEGER, PARAMETER :: jps_oty1 = 23 ! + INTEGER, PARAMETER :: jps_rnf = 24 ! runoffs + INTEGER, PARAMETER :: jps_taum = 25 ! wind stress module + INTEGER, PARAMETER :: jps_fice2 = 26 ! ice fraction sent to OCE (by SAS when doing SAS-OCE coupling) + INTEGER, PARAMETER :: jps_e3t1st = 27 ! first level depth (vvl) + INTEGER, PARAMETER :: jps_fraqsr = 28 ! fraction of solar net radiation absorbed in the first ocean level + INTEGER, PARAMETER :: jps_ficet = 29 ! total ice fraction + INTEGER, PARAMETER :: jps_ocxw = 30 ! currents on grid 1 + INTEGER, PARAMETER :: jps_ocyw = 31 ! currents on grid 2 + INTEGER, PARAMETER :: jps_wlev = 32 ! water level + INTEGER, PARAMETER :: jps_fice1 = 33 ! first-order ice concentration (for semi-implicit coupling of atmos-ice fluxes) + INTEGER, PARAMETER :: jps_a_p = 34 ! meltpond area fraction + INTEGER, PARAMETER :: jps_ht_p = 35 ! meltpond thickness + INTEGER, PARAMETER :: jps_kice = 36 ! sea ice effective conductivity + INTEGER, PARAMETER :: jps_sstfrz = 37 ! sea surface freezing temperature + INTEGER, PARAMETER :: jps_ttilyr = 38 ! sea ice top layer temp + + INTEGER, PARAMETER :: jpsnd = 38 ! total number of fields sent + + ! Dummy variables to enable compilation when oasis3 is not being used + INTEGER :: OASIS_Sent = -1 + INTEGER :: OASIS_SentOut = -1 + INTEGER :: OASIS_ToRest = -1 + INTEGER :: OASIS_ToRestOut = -1 + + ! !!** namelist namsbc_cpl ** + TYPE :: FLD_C ! + CHARACTER(len = 32) :: cldes ! desciption of the coupling strategy + CHARACTER(len = 32) :: clcat ! multiple ice categories strategy + CHARACTER(len = 32) :: clvref ! reference of vector ('spherical' or 'cartesian') + CHARACTER(len = 32) :: clvor ! orientation of vector fields ('eastward-northward' or 'local grid') + CHARACTER(len = 32) :: clvgrd ! grids on which is located the vector fields + END TYPE FLD_C + ! ! Send to the atmosphere + TYPE(FLD_C) :: sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2, & + & sn_snd_thick1, sn_snd_cond, sn_snd_mpnd , sn_snd_sstfrz, sn_snd_ttilyr + ! ! Received from the atmosphere + TYPE(FLD_C) :: sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_dqnsdt, sn_rcv_qsr, & + & sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf, sn_rcv_ts_ice + TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_mslp, sn_rcv_icb, sn_rcv_isf + ! ! Send to waves + TYPE(FLD_C) :: sn_snd_ifrac, sn_snd_crtw, sn_snd_wlev + ! ! Received from waves + TYPE(FLD_C) :: sn_rcv_hsig, sn_rcv_phioc, sn_rcv_sdrfx, sn_rcv_sdrfy, sn_rcv_wper, sn_rcv_wnum, & + & sn_rcv_wstrf, sn_rcv_wdrag, sn_rcv_charn, sn_rcv_taw, sn_rcv_bhd, sn_rcv_tusd, sn_rcv_tvsd + ! ! Other namelist parameters +!! TYPE(FLD_C) :: sn_rcv_qtrice + INTEGER :: nn_cplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data + LOGICAL :: ln_usecplmask ! use a coupling mask file to merge data received from several models + ! -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel) + LOGICAL :: ln_scale_ice_flux ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) + + TYPE :: DYNARR + REAL(wp), POINTER, DIMENSION(:,:,:) :: z3 + END TYPE DYNARR + + TYPE( DYNARR ), SAVE, DIMENSION(jprcv) :: frcv ! all fields recieved from the atmosphere + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: alb_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky) + + INTEGER , ALLOCATABLE, SAVE, DIMENSION(:) :: nrcvinfo ! OASIS info argument + + !! Substitution + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbccpl.F90 15551 2021-11-28 20:19:36Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_cpl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_cpl_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(4) + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( alb_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) ) + + ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) + ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) + ! + IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(4) ) + + sbc_cpl_alloc = MAXVAL( ierr ) + CALL mpp_sum ( 'sbccpl', sbc_cpl_alloc ) + IF( sbc_cpl_alloc > 0 ) CALL ctl_warn('sbc_cpl_alloc: allocation of arrays failed') + ! + END FUNCTION sbc_cpl_alloc + + + SUBROUTINE sbc_cpl_init( k_ice ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_init *** + !! + !! ** Purpose : Initialisation of send and received information from + !! the atmospheric component + !! + !! ** Method : * Read namsbc_cpl namelist + !! * define the receive interface + !! * define the send interface + !! * initialise the OASIS coupler + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3) + ! + INTEGER :: jn ! dummy loop index + INTEGER :: ios, inum ! Local integer + REAL(wp), DIMENSION(jpi,jpj) :: zacs, zaos + !! + NAMELIST/namsbc_cpl/ nn_cplmodel , ln_usecplmask, nn_cats_cpl , ln_scale_ice_flux, & + & sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , & + & sn_snd_ttilyr, sn_snd_cond , sn_snd_mpnd , sn_snd_sstfrz, sn_snd_thick1, & + & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc , & + & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr , & + & sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum , sn_rcv_wstrf , & + & sn_rcv_charn , sn_rcv_taw , sn_rcv_bhd , sn_rcv_tusd , sn_rcv_tvsd, & + & sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , & + & sn_rcv_iceflx, sn_rcv_co2 , sn_rcv_icb , sn_rcv_isf , sn_rcv_ts_ice, & !!, sn_rcv_qtrice + & sn_rcv_mslp + + !!--------------------------------------------------------------------- + ! + ! ================================ ! + ! Namelist informations ! + ! ================================ ! + ! + READ ( numnam_ref, namsbc_cpl, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist' ) + ! + READ ( numnam_cfg, namsbc_cpl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_cpl ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*)'sbc_cpl_init : namsbc_cpl namelist ' + WRITE(numout,*)'~~~~~~~~~~~~' + ENDIF + IF( lwp .AND. ln_cpl ) THEN ! control print + WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel + WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask + WRITE(numout,*)' ln_scale_ice_flux = ', ln_scale_ice_flux + WRITE(numout,*)' nn_cats_cpl = ', nn_cats_cpl + WRITE(numout,*)' received fields (mutiple ice categogies)' + WRITE(numout,*)' 10m wind module = ', TRIM(sn_rcv_w10m%cldes ), ' (', TRIM(sn_rcv_w10m%clcat ), ')' + WRITE(numout,*)' stress module = ', TRIM(sn_rcv_taumod%cldes), ' (', TRIM(sn_rcv_taumod%clcat), ')' + WRITE(numout,*)' surface stress = ', TRIM(sn_rcv_tau%cldes ), ' (', TRIM(sn_rcv_tau%clcat ), ')' + WRITE(numout,*)' - referential = ', sn_rcv_tau%clvref + WRITE(numout,*)' - orientation = ', sn_rcv_tau%clvor + WRITE(numout,*)' - mesh = ', sn_rcv_tau%clvgrd + WRITE(numout,*)' non-solar heat flux sensitivity = ', TRIM(sn_rcv_dqnsdt%cldes), ' (', TRIM(sn_rcv_dqnsdt%clcat), ')' + WRITE(numout,*)' solar heat flux = ', TRIM(sn_rcv_qsr%cldes ), ' (', TRIM(sn_rcv_qsr%clcat ), ')' + WRITE(numout,*)' non-solar heat flux = ', TRIM(sn_rcv_qns%cldes ), ' (', TRIM(sn_rcv_qns%clcat ), ')' + WRITE(numout,*)' freshwater budget = ', TRIM(sn_rcv_emp%cldes ), ' (', TRIM(sn_rcv_emp%clcat ), ')' + WRITE(numout,*)' runoffs = ', TRIM(sn_rcv_rnf%cldes ), ' (', TRIM(sn_rcv_rnf%clcat ), ')' + WRITE(numout,*)' calving = ', TRIM(sn_rcv_cal%cldes ), ' (', TRIM(sn_rcv_cal%clcat ), ')' + WRITE(numout,*)' iceberg = ', TRIM(sn_rcv_icb%cldes ), ' (', TRIM(sn_rcv_icb%clcat ), ')' + WRITE(numout,*)' ice shelf = ', TRIM(sn_rcv_isf%cldes ), ' (', TRIM(sn_rcv_isf%clcat ), ')' + WRITE(numout,*)' sea ice heat fluxes = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')' +!! WRITE(numout,*)' transmitted solar thru sea-ice = ', TRIM(sn_rcv_qtrice%cldes), ' (', TRIM(sn_rcv_qtrice%clcat), ')' + WRITE(numout,*)' atm co2 = ', TRIM(sn_rcv_co2%cldes ), ' (', TRIM(sn_rcv_co2%clcat ), ')' + WRITE(numout,*)' Sea ice surface skin temperature= ', TRIM(sn_rcv_ts_ice%cldes), ' (', TRIM(sn_rcv_ts_ice%clcat), ')' + WRITE(numout,*)' surface waves:' + WRITE(numout,*)' significant wave heigth = ', TRIM(sn_rcv_hsig%cldes ), ' (', TRIM(sn_rcv_hsig%clcat ), ')' + WRITE(numout,*)' wave to oce energy flux = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')' + WRITE(numout,*)' Surface Stokes drift grid u = ', TRIM(sn_rcv_sdrfx%cldes ), ' (', TRIM(sn_rcv_sdrfx%clcat ), ')' + WRITE(numout,*)' Surface Stokes drift grid v = ', TRIM(sn_rcv_sdrfy%cldes ), ' (', TRIM(sn_rcv_sdrfy%clcat ), ')' + WRITE(numout,*)' Mean wave period = ', TRIM(sn_rcv_wper%cldes ), ' (', TRIM(sn_rcv_wper%clcat ), ')' + WRITE(numout,*)' Mean wave number = ', TRIM(sn_rcv_wnum%cldes ), ' (', TRIM(sn_rcv_wnum%clcat ), ')' + WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_wstrf%cldes ), ' (', TRIM(sn_rcv_wstrf%clcat ), ')' + WRITE(numout,*)' Neutral surf drag coefficient = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' + WRITE(numout,*)' Charnock coefficient = ', TRIM(sn_rcv_charn%cldes ), ' (', TRIM(sn_rcv_charn%clcat ), ')' + WRITE(numout,*)' sent fields (multiple ice categories)' + WRITE(numout,*)' surface temperature = ', TRIM(sn_snd_temp%cldes ), ' (', TRIM(sn_snd_temp%clcat ), ')' + WRITE(numout,*)' top ice layer temperature = ', TRIM(sn_snd_ttilyr%cldes), ' (', TRIM(sn_snd_ttilyr%clcat), ')' + WRITE(numout,*)' albedo = ', TRIM(sn_snd_alb%cldes ), ' (', TRIM(sn_snd_alb%clcat ), ')' + WRITE(numout,*)' ice/snow thickness = ', TRIM(sn_snd_thick%cldes ), ' (', TRIM(sn_snd_thick%clcat ), ')' + WRITE(numout,*)' total ice fraction = ', TRIM(sn_snd_ifrac%cldes ), ' (', TRIM(sn_snd_ifrac%clcat ), ')' + WRITE(numout,*)' surface current = ', TRIM(sn_snd_crt%cldes ), ' (', TRIM(sn_snd_crt%clcat ), ')' + WRITE(numout,*)' - referential = ', sn_snd_crt%clvref + WRITE(numout,*)' - orientation = ', sn_snd_crt%clvor + WRITE(numout,*)' - mesh = ', sn_snd_crt%clvgrd + WRITE(numout,*)' oce co2 flux = ', TRIM(sn_snd_co2%cldes ), ' (', TRIM(sn_snd_co2%clcat ), ')' + WRITE(numout,*)' ice effective conductivity = ', TRIM(sn_snd_cond%cldes ), ' (', TRIM(sn_snd_cond%clcat ), ')' + WRITE(numout,*)' meltponds fraction and depth = ', TRIM(sn_snd_mpnd%cldes ), ' (', TRIM(sn_snd_mpnd%clcat ), ')' + WRITE(numout,*)' sea surface freezing temp = ', TRIM(sn_snd_sstfrz%cldes), ' (', TRIM(sn_snd_sstfrz%clcat), ')' + WRITE(numout,*)' water level = ', TRIM(sn_snd_wlev%cldes ), ' (', TRIM(sn_snd_wlev%clcat ), ')' + WRITE(numout,*)' mean sea level pressure = ', TRIM(sn_rcv_mslp%cldes ), ' (', TRIM(sn_rcv_mslp%clcat ), ')' + WRITE(numout,*)' surface current to waves = ', TRIM(sn_snd_crtw%cldes ), ' (', TRIM(sn_snd_crtw%clcat ), ')' + WRITE(numout,*)' - referential = ', sn_snd_crtw%clvref + WRITE(numout,*)' - orientation = ', sn_snd_crtw%clvor + WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd + ENDIF + IF( lwp .AND. ln_wave) THEN ! control print + WRITE(numout,*)' surface waves:' + WRITE(numout,*)' Significant wave heigth = ', TRIM(sn_rcv_hsig%cldes ), ' (', TRIM(sn_rcv_hsig%clcat ), ')' + WRITE(numout,*)' Wave to oce energy flux = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')' + WRITE(numout,*)' Surface Stokes drift grid u = ', TRIM(sn_rcv_sdrfx%cldes ), ' (', TRIM(sn_rcv_sdrfx%clcat ), ')' + WRITE(numout,*)' Surface Stokes drift grid v = ', TRIM(sn_rcv_sdrfy%cldes ), ' (', TRIM(sn_rcv_sdrfy%clcat ), ')' + WRITE(numout,*)' Mean wave period = ', TRIM(sn_rcv_wper%cldes ), ' (', TRIM(sn_rcv_wper%clcat ), ')' + WRITE(numout,*)' Mean wave number = ', TRIM(sn_rcv_wnum%cldes ), ' (', TRIM(sn_rcv_wnum%clcat ), ')' + WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_wstrf%cldes ), ' (', TRIM(sn_rcv_wstrf%clcat ), ')' + WRITE(numout,*)' Neutral surf drag coefficient = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' + WRITE(numout,*)' Charnock coefficient = ', TRIM(sn_rcv_charn%cldes ), ' (', TRIM(sn_rcv_charn%clcat ), ')' + WRITE(numout,*)' Transport associated to Stokes drift grid u = ', TRIM(sn_rcv_tusd%cldes ), ' (', TRIM(sn_rcv_tusd%clcat ), ')' + WRITE(numout,*)' Transport associated to Stokes drift grid v = ', TRIM(sn_rcv_tvsd%cldes ), ' (', TRIM(sn_rcv_tvsd%clcat ), ')' + WRITE(numout,*)' Bernouilli pressure head = ', TRIM(sn_rcv_bhd%cldes ), ' (', TRIM(sn_rcv_bhd%clcat ), ')' + WRITE(numout,*)'Wave to ocean momentum flux and Net wave-supported stress = ', TRIM(sn_rcv_taw%cldes ), ' (', TRIM(sn_rcv_taw%clcat ), ')' + WRITE(numout,*)' Surface current to waves = ', TRIM(sn_snd_crtw%cldes ), ' (', TRIM(sn_snd_crtw%clcat ), ')' + WRITE(numout,*)' - referential = ', sn_snd_crtw%clvref + WRITE(numout,*)' - orientation = ', sn_snd_crtw%clvor + WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd + ENDIF + ! ! allocate sbccpl arrays + IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) + + ! ================================ ! + ! Define the receive interface ! + ! ================================ ! + nrcvinfo(:) = OASIS_idle ! needed by nrcvinfo(jpr_otx1) if we do not receive ocean stress + + ! for each field: define the OASIS name (srcv(:)%clname) + ! define receive or not from the namelist parameters (srcv(:)%laction) + ! define the north fold type of lbc (srcv(:)%nsgn) + + ! default definitions of srcv + srcv(:)%laction = .FALSE. ; srcv(:)%clgrid = 'T' ; srcv(:)%nsgn = 1. ; srcv(:)%nct = 1 + + ! ! ------------------------- ! + ! ! ice and ocean wind stress ! + ! ! ------------------------- ! + ! ! Name + srcv(jpr_otx1)%clname = 'O_OTaux1' ! 1st ocean component on grid ONE (T or U) + srcv(jpr_oty1)%clname = 'O_OTauy1' ! 2nd - - - - + srcv(jpr_otz1)%clname = 'O_OTauz1' ! 3rd - - - - + srcv(jpr_otx2)%clname = 'O_OTaux2' ! 1st ocean component on grid TWO (V) + srcv(jpr_oty2)%clname = 'O_OTauy2' ! 2nd - - - - + srcv(jpr_otz2)%clname = 'O_OTauz2' ! 3rd - - - - + ! + srcv(jpr_itx1)%clname = 'O_ITaux1' ! 1st ice component on grid ONE (T, F, I or U) + srcv(jpr_ity1)%clname = 'O_ITauy1' ! 2nd - - - - + srcv(jpr_itz1)%clname = 'O_ITauz1' ! 3rd - - - - + srcv(jpr_itx2)%clname = 'O_ITaux2' ! 1st ice component on grid TWO (V) + srcv(jpr_ity2)%clname = 'O_ITauy2' ! 2nd - - - - + srcv(jpr_itz2)%clname = 'O_ITauz2' ! 3rd - - - - + ! + ! Vectors: change of sign at north fold ONLY if on the local grid + IF( TRIM( sn_rcv_tau%cldes ) == 'oce only' .OR. TRIM( sn_rcv_tau%cldes ) == 'oce and ice' & + .OR. TRIM( sn_rcv_tau%cldes ) == 'mixed oce-ice' ) THEN ! avoid working with the atmospheric fields if they are not coupled + ! + IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) srcv(jpr_otx1:jpr_itz2)%nsgn = -1. + + ! ! Set grid and action + SELECT CASE( TRIM( sn_rcv_tau%clvgrd ) ) ! 'T', 'U,V', 'U,V,I', 'U,V,F', 'T,I', 'T,F', or 'T,U,V' + CASE( 'T' ) + srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point + srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 + CASE( 'U,V' ) + srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'U' ! ice components given at U-point + srcv(jpr_itx2:jpr_itz2)%clgrid = 'V' ! and V-point + srcv(jpr_otx1:jpr_itz2)%laction = .TRUE. ! receive oce and ice components on both grid 1 & 2 + CASE( 'U,V,T' ) + srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'T' ! ice components given at T-point + srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only + CASE( 'U,V,I' ) + srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'I' ! ice components given at I-point + srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only + CASE( 'U,V,F' ) + srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point + srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only + CASE( 'T,I' ) + srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'I' ! ice components given at I-point + srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 + CASE( 'T,F' ) + srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point + srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 + CASE( 'T,U,V' ) + srcv(jpr_otx1:jpr_otz1)%clgrid = 'T' ! oce components given at T-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'U' ! ice components given at U-point + srcv(jpr_itx2:jpr_itz2)%clgrid = 'V' ! and V-point + srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 only + srcv(jpr_itx1:jpr_itz2)%laction = .TRUE. ! receive ice components on grid 1 & 2 + CASE default + CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_tau%clvgrd' ) + END SELECT + ! + IF( TRIM( sn_rcv_tau%clvref ) == 'spherical' ) & ! spherical: 3rd component not received + & srcv( (/jpr_otz1, jpr_otz2, jpr_itz1, jpr_itz2/) )%laction = .FALSE. + ! + IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) THEN ! already on local grid -> no need of the second grid + srcv(jpr_otx2:jpr_otz2)%laction = .FALSE. + srcv(jpr_itx2:jpr_itz2)%laction = .FALSE. + srcv(jpr_oty1)%clgrid = srcv(jpr_oty2)%clgrid ! not needed but cleaner... + srcv(jpr_ity1)%clgrid = srcv(jpr_ity2)%clgrid ! not needed but cleaner... + ENDIF + ! + IF( TRIM( sn_rcv_tau%cldes ) /= 'oce and ice' ) THEN ! 'oce and ice' case ocean stress on ocean mesh used + srcv(jpr_itx1:jpr_itz2)%laction = .FALSE. ! ice components not received + srcv(jpr_itx1)%clgrid = 'U' ! ocean stress used after its transformation + srcv(jpr_ity1)%clgrid = 'V' ! i.e. it is always at U- & V-points for i- & j-comp. resp. + ENDIF + ENDIF + + ! ! ------------------------- ! + ! ! freshwater budget ! E-P + ! ! ------------------------- ! + ! we suppose that atmosphere modele do not make the difference between precipiration (liquide or solid) + ! over ice of free ocean within the same atmospheric cell.cd + srcv(jpr_rain)%clname = 'OTotRain' ! Rain = liquid precipitation + srcv(jpr_snow)%clname = 'OTotSnow' ! Snow = solid precipitation + srcv(jpr_tevp)%clname = 'OTotEvap' ! total evaporation (over oce + ice sublimation) + srcv(jpr_ievp)%clname = 'OIceEvap' ! evaporation over ice = sublimation + srcv(jpr_sbpr)%clname = 'OSubMPre' ! sublimation - liquid precipitation - solid precipitation + srcv(jpr_semp)%clname = 'OISubMSn' ! ice solid water budget = sublimation - solid precipitation + srcv(jpr_oemp)%clname = 'OOEvaMPr' ! ocean water budget = ocean Evap - ocean precip + SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'oce only' ) ; srcv(jpr_oemp)%laction = .TRUE. + CASE( 'conservative' ) + srcv( (/jpr_rain, jpr_snow, jpr_ievp, jpr_tevp/) )%laction = .TRUE. + IF( k_ice <= 1 ) srcv(jpr_ievp)%laction = .FALSE. + CASE( 'oce and ice' ) ; srcv( (/jpr_ievp, jpr_sbpr, jpr_semp, jpr_oemp/) )%laction = .TRUE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_emp%cldes' ) + END SELECT + ! + ! ! ------------------------- ! + ! ! Runoffs & Calving ! + ! ! ------------------------- ! + srcv(jpr_rnf )%clname = 'O_Runoff' + IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN + srcv(jpr_rnf)%laction = .TRUE. + l_rnfcpl = .TRUE. ! -> no need to read runoffs in sbcrnf + ln_rnf = nn_components /= jp_iam_sas ! -> force to go through sbcrnf if not sas + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' runoffs received from oasis -> force ln_rnf = ', ln_rnf + ENDIF + ! + srcv(jpr_cal)%clname = 'OCalving' ; IF( TRIM( sn_rcv_cal%cldes) == 'coupled' ) srcv(jpr_cal)%laction = .TRUE. + srcv(jpr_isf)%clname = 'OIcshelf' ; IF( TRIM( sn_rcv_isf%cldes) == 'coupled' ) srcv(jpr_isf)%laction = .TRUE. + srcv(jpr_icb)%clname = 'OIceberg' ; IF( TRIM( sn_rcv_icb%cldes) == 'coupled' ) srcv(jpr_icb)%laction = .TRUE. + + IF( srcv(jpr_isf)%laction ) THEN + l_isfoasis = .TRUE. ! -> isf fwf comes from oasis + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' iceshelf received from oasis ' + ENDIF + ! + ! + ! ! ------------------------- ! + ! ! non solar radiation ! Qns + ! ! ------------------------- ! + srcv(jpr_qnsoce)%clname = 'O_QnsOce' + srcv(jpr_qnsice)%clname = 'O_QnsIce' + srcv(jpr_qnsmix)%clname = 'O_QnsMix' + SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'oce only' ) ; srcv( jpr_qnsoce )%laction = .TRUE. + CASE( 'conservative' ) ; srcv( (/jpr_qnsice, jpr_qnsmix/) )%laction = .TRUE. + CASE( 'oce and ice' ) ; srcv( (/jpr_qnsice, jpr_qnsoce/) )%laction = .TRUE. + CASE( 'mixed oce-ice' ) ; srcv( jpr_qnsmix )%laction = .TRUE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qns%cldes' ) + END SELECT + IF( TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' .AND. nn_cats_cpl > 1 ) & + CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qns%cldes not currently allowed to be mixed oce-ice for multi-category ice' ) + ! + ! ! ------------------------- ! + ! ! solar radiation ! Qsr + ! ! ------------------------- ! + srcv(jpr_qsroce)%clname = 'O_QsrOce' + srcv(jpr_qsrice)%clname = 'O_QsrIce' + srcv(jpr_qsrmix)%clname = 'O_QsrMix' + SELECT CASE( TRIM( sn_rcv_qsr%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'oce only' ) ; srcv( jpr_qsroce )%laction = .TRUE. + CASE( 'conservative' ) ; srcv( (/jpr_qsrice, jpr_qsrmix/) )%laction = .TRUE. + CASE( 'oce and ice' ) ; srcv( (/jpr_qsrice, jpr_qsroce/) )%laction = .TRUE. + CASE( 'mixed oce-ice' ) ; srcv( jpr_qsrmix )%laction = .TRUE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qsr%cldes' ) + END SELECT + IF( TRIM( sn_rcv_qsr%cldes ) == 'mixed oce-ice' .AND. nn_cats_cpl > 1 ) & + CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qsr%cldes not currently allowed to be mixed oce-ice for multi-category ice' ) + ! + ! ! ------------------------- ! + ! ! non solar sensitivity ! d(Qns)/d(T) + ! ! ------------------------- ! + srcv(jpr_dqnsdt)%clname = 'O_dQnsdT' + IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'coupled' ) srcv(jpr_dqnsdt)%laction = .TRUE. + ! + ! non solar sensitivity mandatory for mixed oce-ice solar radiation coupling technique + IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' ) & + & CALL ctl_stop( 'sbc_cpl_init: namsbc_cpl namelist mismatch between sn_rcv_qns%cldes and sn_rcv_dqnsdt%cldes' ) + ! + ! ! ------------------------- ! + ! ! 10m wind module ! + ! ! ------------------------- ! + srcv(jpr_w10m)%clname = 'O_Wind10' ; IF( TRIM(sn_rcv_w10m%cldes ) == 'coupled' ) srcv(jpr_w10m)%laction = .TRUE. + ! + ! ! ------------------------- ! + ! ! wind stress module ! + ! ! ------------------------- ! + srcv(jpr_taum)%clname = 'O_TauMod' ; IF( TRIM(sn_rcv_taumod%cldes) == 'coupled' ) srcv(jpr_taum)%laction = .TRUE. + ! + ! ! ------------------------- ! + ! ! Atmospheric CO2 ! + ! ! ------------------------- ! + srcv(jpr_co2 )%clname = 'O_AtmCO2' + IF( TRIM(sn_rcv_co2%cldes ) == 'coupled' ) THEN + srcv(jpr_co2 )%laction = .TRUE. + l_co2cpl = .TRUE. + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Atmospheric pco2 received from oasis ' + IF(lwp) WRITE(numout,*) + ENDIF + ! + ! ! ------------------------- ! + ! ! Mean Sea Level Pressure ! + ! ! ------------------------- ! + srcv(jpr_mslp)%clname = 'O_MSLP' ; IF( TRIM(sn_rcv_mslp%cldes ) == 'coupled' ) srcv(jpr_mslp)%laction = .TRUE. + ! + ! ! --------------------------------- ! + ! ! ice topmelt and conduction flux ! + ! ! --------------------------------- ! + srcv(jpr_topm )%clname = 'OTopMlt' + srcv(jpr_botm )%clname = 'OBotMlt' + IF( TRIM(sn_rcv_iceflx%cldes) == 'coupled' ) THEN + IF( TRIM( sn_rcv_iceflx%clcat ) == 'yes' ) THEN + srcv(jpr_topm:jpr_botm)%nct = nn_cats_cpl + ELSE + CALL ctl_stop( 'sbc_cpl_init: sn_rcv_iceflx%clcat should always be set to yes currently' ) + ENDIF + srcv(jpr_topm:jpr_botm)%laction = .TRUE. + ENDIF +!! ! ! --------------------------- ! +!! ! ! transmitted solar thru ice ! +!! ! ! --------------------------- ! +!! srcv(jpr_qtrice)%clname = 'OQtr' +!! IF( TRIM(sn_rcv_qtrice%cldes) == 'coupled' ) THEN +!! IF ( TRIM( sn_rcv_qtrice%clcat ) == 'yes' ) THEN +!! srcv(jpr_qtrice)%nct = nn_cats_cpl +!! ELSE +!! CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qtrice%clcat should always be set to yes currently' ) +!! ENDIF +!! srcv(jpr_qtrice)%laction = .TRUE. +!! ENDIF + ! ! ------------------------- ! + ! ! ice skin temperature ! + ! ! ------------------------- ! + srcv(jpr_ts_ice)%clname = 'OTsfIce' ! needed by Met Office + IF( TRIM( sn_rcv_ts_ice%cldes ) == 'ice' ) srcv(jpr_ts_ice)%laction = .TRUE. + IF( TRIM( sn_rcv_ts_ice%clcat ) == 'yes' ) srcv(jpr_ts_ice)%nct = nn_cats_cpl + IF( TRIM( sn_rcv_emp%clcat ) == 'yes' ) srcv(jpr_ievp)%nct = nn_cats_cpl + + ! ! ------------------------- ! + ! ! Wave breaking ! + ! ! ------------------------- ! + srcv(jpr_hsig)%clname = 'O_Hsigwa' ! significant wave height + IF( TRIM(sn_rcv_hsig%cldes ) == 'coupled' ) THEN + srcv(jpr_hsig)%laction = .TRUE. + cpl_hsig = .TRUE. + ENDIF + srcv(jpr_phioc)%clname = 'O_PhiOce' ! wave to ocean energy + IF( TRIM(sn_rcv_phioc%cldes ) == 'coupled' ) THEN + srcv(jpr_phioc)%laction = .TRUE. + cpl_phioc = .TRUE. + ENDIF + srcv(jpr_sdrftx)%clname = 'O_Sdrfx' ! Stokes drift in the u direction + IF( TRIM(sn_rcv_sdrfx%cldes ) == 'coupled' ) THEN + srcv(jpr_sdrftx)%laction = .TRUE. + cpl_sdrftx = .TRUE. + ENDIF + srcv(jpr_sdrfty)%clname = 'O_Sdrfy' ! Stokes drift in the v direction + IF( TRIM(sn_rcv_sdrfy%cldes ) == 'coupled' ) THEN + srcv(jpr_sdrfty)%laction = .TRUE. + cpl_sdrfty = .TRUE. + ENDIF + srcv(jpr_wper)%clname = 'O_WPer' ! mean wave period + IF( TRIM(sn_rcv_wper%cldes ) == 'coupled' ) THEN + srcv(jpr_wper)%laction = .TRUE. + cpl_wper = .TRUE. + ENDIF + srcv(jpr_wnum)%clname = 'O_WNum' ! mean wave number + IF( TRIM(sn_rcv_wnum%cldes ) == 'coupled' ) THEN + srcv(jpr_wnum)%laction = .TRUE. + cpl_wnum = .TRUE. + ENDIF + srcv(jpr_wstrf)%clname = 'O_WStrf' ! stress fraction adsorbed by the wave + IF( TRIM(sn_rcv_wstrf%cldes ) == 'coupled' ) THEN + srcv(jpr_wstrf)%laction = .TRUE. + cpl_wstrf = .TRUE. + ENDIF + srcv(jpr_wdrag)%clname = 'O_WDrag' ! neutral surface drag coefficient + IF( TRIM(sn_rcv_wdrag%cldes ) == 'coupled' ) THEN + srcv(jpr_wdrag)%laction = .TRUE. + cpl_wdrag = .TRUE. + ENDIF + srcv(jpr_charn)%clname = 'O_Charn' ! Chranock coefficient + IF( TRIM(sn_rcv_charn%cldes ) == 'coupled' ) THEN + srcv(jpr_charn)%laction = .TRUE. + cpl_charn = .TRUE. + ENDIF + srcv(jpr_bhd)%clname = 'O_Bhd' ! Bernoulli head. waves' induced surface pressure + IF( TRIM(sn_rcv_bhd%cldes ) == 'coupled' ) THEN + srcv(jpr_bhd)%laction = .TRUE. + cpl_bhd = .TRUE. + ENDIF + srcv(jpr_tusd)%clname = 'O_Tusd' ! zonal stokes transport + IF( TRIM(sn_rcv_tusd%cldes ) == 'coupled' ) THEN + srcv(jpr_tusd)%laction = .TRUE. + cpl_tusd = .TRUE. + ENDIF + srcv(jpr_tvsd)%clname = 'O_Tvsd' ! meridional stokes tranmport + IF( TRIM(sn_rcv_tvsd%cldes ) == 'coupled' ) THEN + srcv(jpr_tvsd)%laction = .TRUE. + cpl_tvsd = .TRUE. + ENDIF + + srcv(jpr_twox)%clname = 'O_Twox' ! wave to ocean momentum flux in the u direction + srcv(jpr_twoy)%clname = 'O_Twoy' ! wave to ocean momentum flux in the v direction + srcv(jpr_tawx)%clname = 'O_Tawx' ! Net wave-supported stress in the u direction + srcv(jpr_tawy)%clname = 'O_Tawy' ! Net wave-supported stress in the v direction + IF( TRIM(sn_rcv_taw%cldes ) == 'coupled' ) THEN + srcv(jpr_twox)%laction = .TRUE. + srcv(jpr_twoy)%laction = .TRUE. + srcv(jpr_tawx)%laction = .TRUE. + srcv(jpr_tawy)%laction = .TRUE. + cpl_taw = .TRUE. + ENDIF + ! + ! ! ------------------------------- ! + ! ! OCE-SAS coupling - rcv by opa ! + ! ! ------------------------------- ! + srcv(jpr_sflx)%clname = 'O_SFLX' + srcv(jpr_fice)%clname = 'RIceFrc' + ! + IF( nn_components == jp_iam_oce ) THEN ! OCE coupled to SAS via OASIS: force received field by OCE (sent by SAS) + srcv(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling + srcv(:)%clgrid = 'T' ! force default definition in case of opa <-> sas coupling + srcv(:)%nsgn = 1. ! force default definition in case of opa <-> sas coupling + srcv( (/jpr_qsroce, jpr_qnsoce, jpr_oemp, jpr_sflx, jpr_fice, jpr_otx1, jpr_oty1, jpr_taum/) )%laction = .TRUE. + srcv(jpr_otx1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_oty1)%clgrid = 'V' ! and V-point + ! Vectors: change of sign at north fold ONLY if on the local grid + srcv( (/jpr_otx1,jpr_oty1/) )%nsgn = -1. + sn_rcv_tau%clvgrd = 'U,V' + sn_rcv_tau%clvor = 'local grid' + sn_rcv_tau%clvref = 'spherical' + sn_rcv_emp%cldes = 'oce only' + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*)' Special conditions for SAS-OCE coupling ' + WRITE(numout,*)' OCE component ' + WRITE(numout,*) + WRITE(numout,*)' received fields from SAS component ' + WRITE(numout,*)' ice cover ' + WRITE(numout,*)' oce only EMP ' + WRITE(numout,*)' salt flux ' + WRITE(numout,*)' mixed oce-ice solar flux ' + WRITE(numout,*)' mixed oce-ice non solar flux ' + WRITE(numout,*)' wind stress U,V on local grid and sperical coordinates ' + WRITE(numout,*)' wind stress module' + WRITE(numout,*) + ENDIF + ENDIF + ! ! -------------------------------- ! + ! ! OCE-SAS coupling - rcv by sas ! + ! ! -------------------------------- ! + srcv(jpr_toce )%clname = 'I_SSTSST' + srcv(jpr_soce )%clname = 'I_SSSal' + srcv(jpr_ocx1 )%clname = 'I_OCurx1' + srcv(jpr_ocy1 )%clname = 'I_OCury1' + srcv(jpr_ssh )%clname = 'I_SSHght' + srcv(jpr_e3t1st)%clname = 'I_E3T1st' + srcv(jpr_fraqsr)%clname = 'I_FraQsr' + ! + IF( nn_components == jp_iam_sas ) THEN + IF( .NOT. ln_cpl ) srcv(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling + IF( .NOT. ln_cpl ) srcv(:)%clgrid = 'T' ! force default definition in case of opa <-> sas coupling + IF( .NOT. ln_cpl ) srcv(:)%nsgn = 1. ! force default definition in case of opa <-> sas coupling + srcv( (/jpr_toce, jpr_soce, jpr_ssh, jpr_fraqsr, jpr_ocx1, jpr_ocy1/) )%laction = .TRUE. + srcv( jpr_e3t1st )%laction = .NOT.ln_linssh + srcv(jpr_ocx1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_ocy1)%clgrid = 'V' ! and V-point + ! Vectors: change of sign at north fold ONLY if on the local grid + srcv(jpr_ocx1:jpr_ocy1)%nsgn = -1. + ! Change first letter to couple with atmosphere if already coupled OCE + ! this is nedeed as each variable name used in the namcouple must be unique: + ! for example O_Runoff received by OCE from SAS and therefore S_Runoff received by SAS from the Atmosphere + DO jn = 1, jprcv + IF( srcv(jn)%clname(1:1) == "O" ) srcv(jn)%clname = "S"//srcv(jn)%clname(2:LEN(srcv(jn)%clname)) + END DO + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*)' Special conditions for SAS-OCE coupling ' + WRITE(numout,*)' SAS component ' + WRITE(numout,*) + IF( .NOT. ln_cpl ) THEN + WRITE(numout,*)' received fields from OCE component ' + ELSE + WRITE(numout,*)' Additional received fields from OCE component : ' + ENDIF + WRITE(numout,*)' sea surface temperature (Celsius) ' + WRITE(numout,*)' sea surface salinity ' + WRITE(numout,*)' surface currents ' + WRITE(numout,*)' sea surface height ' + WRITE(numout,*)' thickness of first ocean T level ' + WRITE(numout,*)' fraction of solar net radiation absorbed in the first ocean level' + WRITE(numout,*) + ENDIF + ENDIF + + ! =================================================== ! + ! Allocate all parts of frcv used for received fields ! + ! =================================================== ! + DO jn = 1, jprcv + IF( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(jpi,jpj,srcv(jn)%nct) ) + END DO + ! Allocate taum part of frcv which is used even when not received as coupling field + IF( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jpr_taum)%nct) ) + ! Allocate w10m part of frcv which is used even when not received as coupling field + IF( .NOT. srcv(jpr_w10m)%laction ) ALLOCATE( frcv(jpr_w10m)%z3(jpi,jpj,srcv(jpr_w10m)%nct) ) + ! Allocate jpr_otx1 part of frcv which is used even when not received as coupling field + IF( .NOT. srcv(jpr_otx1)%laction ) ALLOCATE( frcv(jpr_otx1)%z3(jpi,jpj,srcv(jpr_otx1)%nct) ) + IF( .NOT. srcv(jpr_oty1)%laction ) ALLOCATE( frcv(jpr_oty1)%z3(jpi,jpj,srcv(jpr_oty1)%nct) ) + ! Allocate itx1 and ity1 as they are used in sbc_cpl_ice_tau even if srcv(jpr_itx1)%laction = .FALSE. + IF( k_ice /= 0 ) THEN + IF( .NOT. srcv(jpr_itx1)%laction ) ALLOCATE( frcv(jpr_itx1)%z3(jpi,jpj,srcv(jpr_itx1)%nct) ) + IF( .NOT. srcv(jpr_ity1)%laction ) ALLOCATE( frcv(jpr_ity1)%z3(jpi,jpj,srcv(jpr_ity1)%nct) ) + ENDIF + + ! ================================ ! + ! Define the send interface ! + ! ================================ ! + ! for each field: define the OASIS name (ssnd(:)%clname) + ! define send or not from the namelist parameters (ssnd(:)%laction) + ! define the north fold type of lbc (ssnd(:)%nsgn) + + ! default definitions of nsnd + ssnd(:)%laction = .FALSE. ; ssnd(:)%clgrid = 'T' ; ssnd(:)%nsgn = 1. ; ssnd(:)%nct = 1 + + ! ! ------------------------- ! + ! ! Surface temperature ! + ! ! ------------------------- ! + ssnd(jps_toce)%clname = 'O_SSTSST' + ssnd(jps_tice)%clname = 'O_TepIce' + ssnd(jps_ttilyr)%clname = 'O_TtiLyr' + ssnd(jps_tmix)%clname = 'O_TepMix' + SELECT CASE( TRIM( sn_snd_temp%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'oce only' ) ; ssnd( jps_toce )%laction = .TRUE. + CASE( 'oce and ice' , 'weighted oce and ice' , 'oce and weighted ice' ) + ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE. + IF( TRIM( sn_snd_temp%clcat ) == 'yes' ) ssnd(jps_tice)%nct = nn_cats_cpl + CASE( 'mixed oce-ice' ) ; ssnd( jps_tmix )%laction = .TRUE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_temp%cldes' ) + END SELECT + + ! ! ------------------------- ! + ! ! Albedo ! + ! ! ------------------------- ! + ssnd(jps_albice)%clname = 'O_AlbIce' + ssnd(jps_albmix)%clname = 'O_AlbMix' + SELECT CASE( TRIM( sn_snd_alb%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'ice' , 'weighted ice' ) ; ssnd(jps_albice)%laction = .TRUE. + CASE( 'mixed oce-ice' ) ; ssnd(jps_albmix)%laction = .TRUE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_alb%cldes' ) + END SELECT + ! + ! Need to calculate oceanic albedo if + ! 1. sending mixed oce-ice albedo or + ! 2. receiving mixed oce-ice solar radiation + IF( TRIM ( sn_snd_alb%cldes ) == 'mixed oce-ice' .OR. TRIM ( sn_rcv_qsr%cldes ) == 'mixed oce-ice' ) THEN + CALL oce_alb( zaos, zacs ) + ! Due to lack of information on nebulosity : mean clear/overcast sky + alb_oce_mix(:,:) = ( zacs(:,:) + zaos(:,:) ) * 0.5 + ENDIF + ! ! ------------------------- ! + ! ! Ice fraction & Thickness ! + ! ! ------------------------- ! + ssnd(jps_fice)%clname = 'OIceFrc' + ssnd(jps_ficet)%clname = 'OIceFrcT' + ssnd(jps_hice)%clname = 'OIceTck' + ssnd(jps_a_p)%clname = 'OPndFrc' + ssnd(jps_ht_p)%clname = 'OPndTck' + ssnd(jps_hsnw)%clname = 'OSnwTck' + ssnd(jps_fice1)%clname = 'OIceFrd' + IF( k_ice /= 0 ) THEN + ssnd(jps_fice)%laction = .TRUE. ! if ice treated in the ocean (even in climato case) + ssnd(jps_fice1)%laction = .TRUE. ! First-order regridded ice concentration, to be used producing atmos-to-ice fluxes (Met Office requirement) +! Currently no namelist entry to determine sending of multi-category ice fraction so use the thickness entry for now + IF( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_fice)%nct = nn_cats_cpl + IF( TRIM( sn_snd_thick1%clcat ) == 'yes' ) ssnd(jps_fice1)%nct = nn_cats_cpl + ENDIF + + IF(TRIM( sn_snd_ifrac%cldes ) == 'coupled') ssnd(jps_ficet)%laction = .TRUE. + + SELECT CASE ( TRIM( sn_snd_thick%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'ice and snow' ) + ssnd(jps_hice:jps_hsnw)%laction = .TRUE. + IF( TRIM( sn_snd_thick%clcat ) == 'yes' ) THEN + ssnd(jps_hice:jps_hsnw)%nct = nn_cats_cpl + ENDIF + CASE ( 'weighted ice and snow' ) + ssnd(jps_hice:jps_hsnw)%laction = .TRUE. + IF( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_hice:jps_hsnw)%nct = nn_cats_cpl + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_thick%cldes' ) + END SELECT + + ! ! ------------------------- ! + ! ! Ice Meltponds ! + ! ! ------------------------- ! + ! Needed by Met Office + ssnd(jps_a_p)%clname = 'OPndFrc' + ssnd(jps_ht_p)%clname = 'OPndTck' + SELECT CASE ( TRIM( sn_snd_mpnd%cldes ) ) + CASE ( 'none' ) + ssnd(jps_a_p)%laction = .FALSE. + ssnd(jps_ht_p)%laction = .FALSE. + CASE ( 'ice only' ) + ssnd(jps_a_p)%laction = .TRUE. + ssnd(jps_ht_p)%laction = .TRUE. + IF( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN + ssnd(jps_a_p)%nct = nn_cats_cpl + ssnd(jps_ht_p)%nct = nn_cats_cpl + ELSE + IF( nn_cats_cpl > 1 ) THEN + CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_mpnd%cldes if not exchanging category fields' ) + ENDIF + ENDIF + CASE ( 'weighted ice' ) + ssnd(jps_a_p)%laction = .TRUE. + ssnd(jps_ht_p)%laction = .TRUE. + IF( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN + ssnd(jps_a_p)%nct = nn_cats_cpl + ssnd(jps_ht_p)%nct = nn_cats_cpl + ENDIF + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_mpnd%cldes; '//sn_snd_mpnd%cldes ) + END SELECT + + ! ! ------------------------- ! + ! ! Surface current ! + ! ! ------------------------- ! + ! ocean currents ! ice velocities + ssnd(jps_ocx1)%clname = 'O_OCurx1' ; ssnd(jps_ivx1)%clname = 'O_IVelx1' + ssnd(jps_ocy1)%clname = 'O_OCury1' ; ssnd(jps_ivy1)%clname = 'O_IVely1' + ssnd(jps_ocz1)%clname = 'O_OCurz1' ; ssnd(jps_ivz1)%clname = 'O_IVelz1' + ssnd(jps_ocxw)%clname = 'O_OCurxw' + ssnd(jps_ocyw)%clname = 'O_OCuryw' + ! + ssnd(jps_ocx1:jps_ivz1)%nsgn = -1. ! vectors: change of the sign at the north fold + + IF( sn_snd_crt%clvgrd == 'U,V' ) THEN + ssnd(jps_ocx1)%clgrid = 'U' ; ssnd(jps_ocy1)%clgrid = 'V' + ELSE IF( sn_snd_crt%clvgrd /= 'T' ) THEN + CALL ctl_stop( 'sn_snd_crt%clvgrd must be equal to T' ) + ENDIF + ssnd(jps_ocx1:jps_ivz1)%laction = .TRUE. ! default: all are send + IF( TRIM( sn_snd_crt%clvref ) == 'spherical' ) ssnd( (/jps_ocz1, jps_ivz1/) )%laction = .FALSE. + IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) ssnd(jps_ocx1:jps_ivz1)%nsgn = 1. + SELECT CASE( TRIM( sn_snd_crt%cldes ) ) + CASE( 'none' ) ; ssnd(jps_ocx1:jps_ivz1)%laction = .FALSE. + CASE( 'oce only' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE. + CASE( 'weighted oce and ice' ) ! nothing to do + CASE( 'mixed oce-ice' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_crt%cldes' ) + END SELECT + + ssnd(jps_ocxw:jps_ocyw)%nsgn = -1. ! vectors: change of the sign at the north fold + + IF( sn_snd_crtw%clvgrd == 'U,V' ) THEN + ssnd(jps_ocxw)%clgrid = 'U' ; ssnd(jps_ocyw)%clgrid = 'V' + ELSE IF( sn_snd_crtw%clvgrd /= 'T' ) THEN + CALL ctl_stop( 'sn_snd_crtw%clvgrd must be equal to T' ) + ENDIF + IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) ssnd(jps_ocxw:jps_ocyw)%nsgn = 1. + SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) + CASE( 'none' ) ; ssnd(jps_ocxw:jps_ocyw)%laction = .FALSE. + CASE( 'oce only' ) ; ssnd(jps_ocxw:jps_ocyw)%laction = .TRUE. + CASE( 'weighted oce and ice' ) ! nothing to do + CASE( 'mixed oce-ice' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_crtw%cldes' ) + END SELECT + + ! ! ------------------------- ! + ! ! CO2 flux ! + ! ! ------------------------- ! + ssnd(jps_co2)%clname = 'O_CO2FLX' ; IF( TRIM(sn_snd_co2%cldes) == 'coupled' ) ssnd(jps_co2 )%laction = .TRUE. + ! + ! ! ------------------------- ! + ! ! Sea surface freezing temp ! + ! ! ------------------------- ! + ! needed by Met Office + ssnd(jps_sstfrz)%clname = 'O_SSTFrz' ; IF( TRIM(sn_snd_sstfrz%cldes) == 'coupled' ) ssnd(jps_sstfrz)%laction = .TRUE. + ! + ! ! ------------------------- ! + ! ! Ice conductivity ! + ! ! ------------------------- ! + ! needed by Met Office + ! Note that ultimately we will move to passing an ocean effective conductivity as well so there + ! will be some changes to the parts of the code which currently relate only to ice conductivity + ssnd(jps_ttilyr )%clname = 'O_TtiLyr' + SELECT CASE ( TRIM( sn_snd_ttilyr%cldes ) ) + CASE ( 'none' ) + ssnd(jps_ttilyr)%laction = .FALSE. + CASE ( 'ice only' ) + ssnd(jps_ttilyr)%laction = .TRUE. + IF( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) THEN + ssnd(jps_ttilyr)%nct = nn_cats_cpl + ELSE + IF( nn_cats_cpl > 1 ) THEN + CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_ttilyr%cldes if not exchanging category fields' ) + ENDIF + ENDIF + CASE ( 'weighted ice' ) + ssnd(jps_ttilyr)%laction = .TRUE. + IF( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) ssnd(jps_ttilyr)%nct = nn_cats_cpl + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_ttilyr%cldes;'//sn_snd_ttilyr%cldes ) + END SELECT + + ssnd(jps_kice )%clname = 'OIceKn' + SELECT CASE ( TRIM( sn_snd_cond%cldes ) ) + CASE ( 'none' ) + ssnd(jps_kice)%laction = .FALSE. + CASE ( 'ice only' ) + ssnd(jps_kice)%laction = .TRUE. + IF( TRIM( sn_snd_cond%clcat ) == 'yes' ) THEN + ssnd(jps_kice)%nct = nn_cats_cpl + ELSE + IF( nn_cats_cpl > 1 ) THEN + CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_cond%cldes if not exchanging category fields' ) + ENDIF + ENDIF + CASE ( 'weighted ice' ) + ssnd(jps_kice)%laction = .TRUE. + IF( TRIM( sn_snd_cond%clcat ) == 'yes' ) ssnd(jps_kice)%nct = nn_cats_cpl + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_cond%cldes;'//sn_snd_cond%cldes ) + END SELECT + ! + ! ! ------------------------- ! + ! ! Sea surface height ! + ! ! ------------------------- ! + ssnd(jps_wlev)%clname = 'O_Wlevel' ; IF( TRIM(sn_snd_wlev%cldes) == 'coupled' ) ssnd(jps_wlev)%laction = .TRUE. + + ! ! ------------------------------- ! + ! ! OCE-SAS coupling - snd by opa ! + ! ! ------------------------------- ! + ssnd(jps_ssh )%clname = 'O_SSHght' + ssnd(jps_soce )%clname = 'O_SSSal' + ssnd(jps_e3t1st)%clname = 'O_E3T1st' + ssnd(jps_fraqsr)%clname = 'O_FraQsr' + ! + IF( nn_components == jp_iam_oce ) THEN + ssnd(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling + ssnd( (/jps_toce, jps_soce, jps_ssh, jps_fraqsr, jps_ocx1, jps_ocy1/) )%laction = .TRUE. + ssnd( jps_e3t1st )%laction = .NOT.ln_linssh + ! vector definition: not used but cleaner... + ssnd(jps_ocx1)%clgrid = 'U' ! oce components given at U-point + ssnd(jps_ocy1)%clgrid = 'V' ! and V-point + sn_snd_crt%clvgrd = 'U,V' + sn_snd_crt%clvor = 'local grid' + sn_snd_crt%clvref = 'spherical' + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*)' sent fields to SAS component ' + WRITE(numout,*)' sea surface temperature (T before, Celsius) ' + WRITE(numout,*)' sea surface salinity ' + WRITE(numout,*)' surface currents U,V on local grid and spherical coordinates' + WRITE(numout,*)' sea surface height ' + WRITE(numout,*)' thickness of first ocean T level ' + WRITE(numout,*)' fraction of solar net radiation absorbed in the first ocean level' + WRITE(numout,*) + ENDIF + ENDIF + ! ! ------------------------------- ! + ! ! OCE-SAS coupling - snd by sas ! + ! ! ------------------------------- ! + ssnd(jps_sflx )%clname = 'I_SFLX' + ssnd(jps_fice2 )%clname = 'IIceFrc' + ssnd(jps_qsroce)%clname = 'I_QsrOce' + ssnd(jps_qnsoce)%clname = 'I_QnsOce' + ssnd(jps_oemp )%clname = 'IOEvaMPr' + ssnd(jps_otx1 )%clname = 'I_OTaux1' + ssnd(jps_oty1 )%clname = 'I_OTauy1' + ssnd(jps_rnf )%clname = 'I_Runoff' + ssnd(jps_taum )%clname = 'I_TauMod' + ! + IF( nn_components == jp_iam_sas ) THEN + IF( .NOT. ln_cpl ) ssnd(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling + ssnd( (/jps_qsroce, jps_qnsoce, jps_oemp, jps_fice2, jps_sflx, jps_otx1, jps_oty1, jps_taum/) )%laction = .TRUE. + ! + ! Change first letter to couple with atmosphere if already coupled with sea_ice + ! this is nedeed as each variable name used in the namcouple must be unique: + ! for example O_SSTSST sent by OCE to SAS and therefore S_SSTSST sent by SAS to the Atmosphere + DO jn = 1, jpsnd + IF( ssnd(jn)%clname(1:1) == "O" ) ssnd(jn)%clname = "S"//ssnd(jn)%clname(2:LEN(ssnd(jn)%clname)) + END DO + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + IF( .NOT. ln_cpl ) THEN + WRITE(numout,*)' sent fields to OCE component ' + ELSE + WRITE(numout,*)' Additional sent fields to OCE component : ' + ENDIF + WRITE(numout,*)' ice cover ' + WRITE(numout,*)' oce only EMP ' + WRITE(numout,*)' salt flux ' + WRITE(numout,*)' mixed oce-ice solar flux ' + WRITE(numout,*)' mixed oce-ice non solar flux ' + WRITE(numout,*)' wind stress U,V components' + WRITE(numout,*)' wind stress module' + ENDIF + ENDIF + + ! + ! ================================ ! + ! initialisation of the coupler ! + ! ================================ ! + CALL cpl_define(jprcv, jpsnd, nn_cplmodel) + + IF(ln_usecplmask) THEN + xcplmask(:,:,:) = 0. + CALL iom_open( 'cplmask', inum ) + CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(1:jpi,1:jpj,1:nn_cplmodel), & + & kstart = (/ mig(1),mjg(1),1 /), kcount = (/ jpi,jpj,nn_cplmodel /) ) + CALL iom_close( inum ) + ELSE + xcplmask(:,:,:) = 1. + ENDIF + xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 ) + ! + ! + END SUBROUTINE sbc_cpl_init + + + SUBROUTINE sbc_cpl_rcv( kt, k_fsbc, k_ice, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_rcv *** + !! + !! ** Purpose : provide the stress over the ocean and, if no sea-ice, + !! provide the ocean heat and freshwater fluxes. + !! + !! ** Method : - Receive all the atmospheric fields (stored in frcv array). called at each time step. + !! OASIS controls if there is something do receive or not. nrcvinfo contains the info + !! to know if the field was really received or not + !! + !! --> If ocean stress was really received: + !! + !! - transform the received ocean stress vector from the received + !! referential and grid into an atmosphere-ocean stress in + !! the (i,j) ocean referencial and at the ocean velocity point. + !! The received stress are : + !! - defined by 3 components (if cartesian coordinate) + !! or by 2 components (if spherical) + !! - oriented along geographical coordinate (if eastward-northward) + !! or along the local grid coordinate (if local grid) + !! - given at U- and V-point, resp. if received on 2 grids + !! or at T-point if received on 1 grid + !! Therefore and if necessary, they are successively + !! processed in order to obtain them + !! first as 2 components on the sphere + !! second as 2 components oriented along the local grid + !! third as 2 components on the U,V grid + !! + !! --> + !! + !! - In 'ocean only' case, non solar and solar ocean heat fluxes + !! and total ocean freshwater fluxes + !! + !! ** Method : receive all fields from the atmosphere and transform + !! them into ocean surface boundary condition fields + !! + !! ** Action : update utau, vtau ocean stress at U,V grid + !! taum wind stress module at T-point + !! wndm wind speed module at T-point over free ocean or leads in presence of sea-ice + !! qns non solar heat fluxes including emp heat content (ocean only case) + !! and the latent heat flux of solid precip. melting + !! qsr solar ocean heat fluxes (ocean only case) + !! emp upward mass flux [evap. - precip. (- runoffs) (- calving)] (ocean only case) + !!---------------------------------------------------------------------- + USE zdf_oce, ONLY : ln_zdfswm + ! + INTEGER, INTENT(in) :: kt ! ocean model time step index + INTEGER, INTENT(in) :: k_fsbc ! frequency of sbc (-> ice model) computation + INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3) + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean model time level indices + !! + LOGICAL :: llnewtx, llnewtau ! update wind stress components and module?? + INTEGER :: ji, jj, jn ! dummy loop indices + INTEGER :: isec ! number of seconds since nit000 (assuming rdt did not change since nit000) + REAL(wp) :: zcumulneg, zcumulpos ! temporary scalars + REAL(wp) :: zcoef ! temporary scalar + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: zzx, zzy ! temporary variables + REAL(wp) :: r1_grau ! = 1.e0 / (grav * rho0) + REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr, zcloud_fra + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + ! cannot be done in the init phase when we use agrif as cpl_freq requires that oasis_enddef is done + ncpl_qsr_freq = cpl_freq( 'O_QsrOce' ) + cpl_freq( 'O_QsrMix' ) + cpl_freq( 'I_QsrOce' ) + cpl_freq( 'I_QsrMix' ) + IF( ln_dm2dc .AND. ncpl_qsr_freq /= 86400 ) & + & CALL ctl_stop( 'sbc_cpl_rcv: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' ) + + IF ( ln_wave .AND. nn_components == 0 ) THEN + ncpl_qsr_freq = 1; + WRITE(numout,*) 'ncpl_qsr_freq is set to 1 when coupling NEMO with wave (without SAS) ' + ENDIF + ENDIF + ! + IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) + ! + ! ! ======================================================= ! + ! ! Receive all the atmos. fields (including ice information) + ! ! ======================================================= ! + isec = ( kt - nit000 ) * NINT( rn_Dt ) ! date of exchanges + DO jn = 1, jprcv ! received fields sent by the atmosphere + IF( srcv(jn)%laction ) CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask(:,:,1:nn_cplmodel), nrcvinfo(jn) ) + END DO + + ! ! ========================= ! + IF( srcv(jpr_otx1)%laction ) THEN ! ocean stress components ! + ! ! ========================= ! + ! define frcv(jpr_otx1)%z3(:,:,1) and frcv(jpr_oty1)%z3(:,:,1): stress at U/V point along model grid + ! => need to be done only when we receive the field + IF( nrcvinfo(jpr_otx1) == OASIS_Rcv ) THEN + ! + IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere + ! ! (cartesian to spherical -> 3 to 2 components) + ! + CALL geo2oce( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), frcv(jpr_otz1)%z3(:,:,1), & + & srcv(jpr_otx1)%clgrid, ztx, zty ) + frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid + frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid + ! + IF( srcv(jpr_otx2)%laction ) THEN + CALL geo2oce( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), frcv(jpr_otz2)%z3(:,:,1), & + & srcv(jpr_otx2)%clgrid, ztx, zty ) + frcv(jpr_otx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid + frcv(jpr_oty2)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid + ENDIF + ! + ENDIF + ! + IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid + ! ! (geographical to local grid -> rotate the components) + CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx ) + IF( srcv(jpr_otx2)%laction ) THEN + CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty ) + ELSE + CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty ) + ENDIF + frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid + frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 2nd grid + ENDIF + ! + IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! T ==> (U,V) + frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) ) + frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) + END DO ; END DO + CALL lbc_lnk( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V', -1.0_wp ) + ENDIF + llnewtx = .TRUE. + ELSE + llnewtx = .FALSE. + ENDIF + ! ! ========================= ! + ELSE ! No dynamical coupling ! + ! ! ========================= ! + frcv(jpr_otx1)%z3(:,:,1) = 0.e0 ! here simply set to zero + frcv(jpr_oty1)%z3(:,:,1) = 0.e0 ! an external read in a file can be added instead + llnewtx = .TRUE. + ! + ENDIF + ! ! ========================= ! + ! ! wind stress module ! (taum) + ! ! ========================= ! + IF( .NOT. srcv(jpr_taum)%laction ) THEN ! compute wind stress module from its components if not received + ! => need to be done only when otx1 was changed + IF( llnewtx ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zzx = frcv(jpr_otx1)%z3(ji-1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) + zzy = frcv(jpr_oty1)%z3(ji ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1) + frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) + END DO ; END DO + CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1.0_wp ) + llnewtau = .TRUE. + ELSE + llnewtau = .FALSE. + ENDIF + ELSE + llnewtau = nrcvinfo(jpr_taum) == OASIS_Rcv + ! Stress module can be negative when received (interpolation problem) + IF( llnewtau ) THEN + frcv(jpr_taum)%z3(:,:,1) = MAX( 0._wp, frcv(jpr_taum)%z3(:,:,1) ) + ENDIF + ENDIF + ! + ! ! ========================= ! + ! ! 10 m wind speed ! (wndm) + ! ! ========================= ! + IF( .NOT. srcv(jpr_w10m)%laction ) THEN ! compute wind spreed from wind stress module if not received + ! => need to be done only when taumod was changed + IF( llnewtau ) THEN + zcoef = 1. / ( zrhoa * zcdrag ) + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) + END DO ; END DO + ENDIF + ENDIF +!!$ ! ! ========================= ! +!!$ SELECT CASE( TRIM( sn_rcv_clouds%cldes ) ) ! cloud fraction ! +!!$ ! ! ========================= ! +!!$ cloud_fra(:,:) = frcv(jpr_clfra)*z3(:,:,1) +!!$ END SELECT +!!$ + zcloud_fra(:,:) = pp_cldf ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm. + IF( ln_mixcpl ) THEN + cloud_fra(:,:) = cloud_fra(:,:) * xcplmask(:,:,0) + zcloud_fra(:,:)* zmsk(:,:) + ELSE + cloud_fra(:,:) = zcloud_fra(:,:) + ENDIF + ! ! ========================= ! + ! u(v)tau and taum will be modified by ice model + ! -> need to be reset before each call of the ice/fsbc + IF( MOD( kt-1, k_fsbc ) == 0 ) THEN + ! + IF( ln_mixcpl ) THEN + utau(:,:) = utau(:,:) * xcplmask(:,:,0) + frcv(jpr_otx1)%z3(:,:,1) * zmsk(:,:) + vtau(:,:) = vtau(:,:) * xcplmask(:,:,0) + frcv(jpr_oty1)%z3(:,:,1) * zmsk(:,:) + taum(:,:) = taum(:,:) * xcplmask(:,:,0) + frcv(jpr_taum)%z3(:,:,1) * zmsk(:,:) + wndm(:,:) = wndm(:,:) * xcplmask(:,:,0) + frcv(jpr_w10m)%z3(:,:,1) * zmsk(:,:) + ELSE + utau(:,:) = frcv(jpr_otx1)%z3(:,:,1) + vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1) + taum(:,:) = frcv(jpr_taum)%z3(:,:,1) + wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1) + ENDIF + CALL iom_put( "taum_oce", taum ) ! output wind stress module + ! + ENDIF + + ! ! ================== ! + ! ! atmosph. CO2 (ppm) ! + ! ! ================== ! + IF( srcv(jpr_co2)%laction ) atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Mean Sea Level Pressure ! (taum) + ! ! ========================= ! + IF( srcv(jpr_mslp)%laction ) THEN ! UKMO SHELF effect of atmospheric pressure on SSH + IF( kt /= nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) !* Swap of ssh_ib fields + + r1_grau = 1.e0 / (grav * rho0) !* constant for optimization + ssh_ib(:,:) = - ( frcv(jpr_mslp)%z3(:,:,1) - rpref ) * r1_grau ! equivalent ssh (inverse barometer) + apr (:,:) = frcv(jpr_mslp)%z3(:,:,1) !atmospheric pressure + + IF( kt == nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) ! correct this later (read from restart if possible) + ENDIF + ! + IF( ln_sdw ) THEN ! Stokes Drift correction activated + ! ! ========================= ! + ! ! Stokes drift u ! + ! ! ========================= ! + IF( srcv(jpr_sdrftx)%laction ) ut0sd(:,:) = frcv(jpr_sdrftx)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Stokes drift v ! + ! ! ========================= ! + IF( srcv(jpr_sdrfty)%laction ) vt0sd(:,:) = frcv(jpr_sdrfty)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Wave mean period ! + ! ! ========================= ! + IF( srcv(jpr_wper)%laction ) wmp(:,:) = frcv(jpr_wper)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Significant wave height ! + ! ! ========================= ! + IF( srcv(jpr_hsig)%laction ) hsw(:,:) = frcv(jpr_hsig)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Vertical mixing Qiao ! + ! ! ========================= ! + IF( srcv(jpr_wnum)%laction .AND. ln_zdfswm ) wnum(:,:) = frcv(jpr_wnum)%z3(:,:,1) + + ! Calculate the 3D Stokes drift both in coupled and not fully uncoupled mode + IF( srcv(jpr_sdrftx)%laction .OR. srcv(jpr_sdrfty)%laction .OR. & + srcv(jpr_wper)%laction .OR. srcv(jpr_hsig)%laction ) THEN + CALL sbc_stokes( Kmm ) + ENDIF + ENDIF + ! ! ========================= ! + ! ! Stress adsorbed by waves ! + ! ! ========================= ! + IF( srcv(jpr_wstrf)%laction .AND. ln_tauoc ) tauoc_wave(:,:) = frcv(jpr_wstrf)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Wave drag coefficient ! + ! ! ========================= ! + IF( srcv(jpr_wdrag)%laction .AND. ln_cdgw ) cdn_wave(:,:) = frcv(jpr_wdrag)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Chranock coefficient ! + ! ! ========================= ! + IF( srcv(jpr_charn)%laction .AND. ln_charn ) charn(:,:) = frcv(jpr_charn)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! net wave-supported stress ! + ! ! ========================= ! + IF( srcv(jpr_tawx)%laction .AND. ln_taw ) tawx(:,:) = frcv(jpr_tawx)%z3(:,:,1) + IF( srcv(jpr_tawy)%laction .AND. ln_taw ) tawy(:,:) = frcv(jpr_tawy)%z3(:,:,1) + ! + ! ! ========================= ! + ! !wave to ocean momentum flux! + ! ! ========================= ! + IF( srcv(jpr_twox)%laction .AND. ln_taw ) twox(:,:) = frcv(jpr_twox)%z3(:,:,1) + IF( srcv(jpr_twoy)%laction .AND. ln_taw ) twoy(:,:) = frcv(jpr_twoy)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! wave TKE flux at sfc ! + ! ! ========================= ! + IF( srcv(jpr_phioc)%laction .AND. ln_phioc ) phioc(:,:) = frcv(jpr_phioc)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Bernoulli head ! + ! ! ========================= ! + IF( srcv(jpr_bhd)%laction .AND. ln_bern_srfc ) bhd_wave(:,:) = frcv(jpr_bhd)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Stokes transport u dir ! + ! ! ========================= ! + IF( srcv(jpr_tusd)%laction .AND. ln_breivikFV_2016 ) tusd(:,:) = frcv(jpr_tusd)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Stokes transport v dir ! + ! ! ========================= ! + IF( srcv(jpr_tvsd)%laction .AND. ln_breivikFV_2016 ) tvsd(:,:) = frcv(jpr_tvsd)%z3(:,:,1) + ! + ! Fields received by SAS when OASIS coupling + ! (arrays no more filled at sbcssm stage) + ! ! ================== ! + ! ! SSS ! + ! ! ================== ! + IF( srcv(jpr_soce)%laction ) THEN ! received by sas in case of opa <-> sas coupling + sss_m(:,:) = frcv(jpr_soce)%z3(:,:,1) + CALL iom_put( 'sss_m', sss_m ) + ENDIF + ! + ! ! ================== ! + ! ! SST ! + ! ! ================== ! + IF( srcv(jpr_toce)%laction ) THEN ! received by sas in case of opa <-> sas coupling + sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1) + IF( srcv(jpr_soce)%laction .AND. l_useCT ) THEN ! make sure that sst_m is the potential temperature + sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) ) + ENDIF + ENDIF + ! ! ================== ! + ! ! SSH ! + ! ! ================== ! + IF( srcv(jpr_ssh )%laction ) THEN ! received by sas in case of opa <-> sas coupling + ssh_m(:,:) = frcv(jpr_ssh )%z3(:,:,1) + CALL iom_put( 'ssh_m', ssh_m ) + ENDIF + ! ! ================== ! + ! ! surface currents ! + ! ! ================== ! + IF( srcv(jpr_ocx1)%laction ) THEN ! received by sas in case of opa <-> sas coupling + ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) + uu(:,:,1,Kbb) = ssu_m(:,:) ! will be used in icestp in the call of ice_forcing_tau + uu(:,:,1,Kmm) = ssu_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling + CALL iom_put( 'ssu_m', ssu_m ) + ENDIF + IF( srcv(jpr_ocy1)%laction ) THEN + ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) + vv(:,:,1,Kbb) = ssv_m(:,:) ! will be used in icestp in the call of ice_forcing_tau + vv(:,:,1,Kmm) = ssv_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling + CALL iom_put( 'ssv_m', ssv_m ) + ENDIF + ! ! ======================== ! + ! ! first T level thickness ! + ! ! ======================== ! + IF( srcv(jpr_e3t1st )%laction ) THEN ! received by sas in case of opa <-> sas coupling + e3t_m(:,:) = frcv(jpr_e3t1st )%z3(:,:,1) + CALL iom_put( 'e3t_m', e3t_m(:,:) ) + ENDIF + ! ! ================================ ! + ! ! fraction of solar net radiation ! + ! ! ================================ ! + IF( srcv(jpr_fraqsr)%laction ) THEN ! received by sas in case of opa <-> sas coupling + frq_m(:,:) = frcv(jpr_fraqsr)%z3(:,:,1) + CALL iom_put( 'frq_m', frq_m ) + ENDIF + + ! ! ========================= ! + IF( k_ice <= 1 .AND. MOD( kt-1, k_fsbc ) == 0 ) THEN ! heat & freshwater fluxes ! (Ocean only case) + ! ! ========================= ! + ! + ! ! total freshwater fluxes over the ocean (emp) + IF( srcv(jpr_oemp)%laction .OR. srcv(jpr_rain)%laction ) THEN + SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) ! evaporation - precipitation + CASE( 'conservative' ) + zemp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) ) + CASE( 'oce only', 'oce and ice' ) + zemp(:,:) = frcv(jpr_oemp)%z3(:,:,1) + CASE default + CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' ) + END SELECT + ELSE + zemp(:,:) = 0._wp + ENDIF + ! + ! ! runoffs and calving (added in emp) + IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) + IF( srcv(jpr_cal)%laction ) zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1) + + IF( srcv(jpr_icb)%laction ) THEN + fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) + rnf(:,:) = rnf(:,:) + fwficb(:,:) ! iceberg added to runfofs + ENDIF + ! + ! ice shelf fwf + IF( srcv(jpr_isf)%laction ) THEN + fwfisf_oasis(:,:) = frcv(jpr_isf)%z3(:,:,1) ! fresh water flux from the isf to the ocean ( > 0 = melting ) + END IF + + IF( ln_mixcpl ) THEN ; emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:) + ELSE ; emp(:,:) = zemp(:,:) + ENDIF + ! + ! ! non solar heat flux over the ocean (qns) + IF( srcv(jpr_qnsoce)%laction ) THEN ; zqns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) + ELSE IF( srcv(jpr_qnsmix)%laction ) THEN ; zqns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) + ELSE ; zqns(:,:) = 0._wp + ENDIF + ! update qns over the free ocean with: + IF( nn_components /= jp_iam_oce ) THEN + zqns(:,:) = zqns(:,:) - zemp(:,:) * sst_m(:,:) * rcp ! remove heat content due to mass flux (assumed to be at SST) + IF( srcv(jpr_snow )%laction ) THEN + zqns(:,:) = zqns(:,:) - frcv(jpr_snow)%z3(:,:,1) * rLfus ! energy for melting solid precipitation over the free ocean + ENDIF + ENDIF + ! + IF( srcv(jpr_icb)%laction ) zqns(:,:) = zqns(:,:) - frcv(jpr_icb)%z3(:,:,1) * rLfus ! remove heat content associated to iceberg melting + ! + IF( ln_mixcpl ) THEN ; qns(:,:) = qns(:,:) * xcplmask(:,:,0) + zqns(:,:) * zmsk(:,:) + ELSE ; qns(:,:) = zqns(:,:) + ENDIF + + ! ! solar flux over the ocean (qsr) + IF ( srcv(jpr_qsroce)%laction ) THEN ; zqsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1) + ELSE IF( srcv(jpr_qsrmix)%laction ) then ; zqsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1) + ELSE ; zqsr(:,:) = 0._wp + ENDIF + IF( ln_dm2dc .AND. ln_cpl ) zqsr(:,:) = sbc_dcy( zqsr ) ! modify qsr to include the diurnal cycle + IF( ln_mixcpl ) THEN ; qsr(:,:) = qsr(:,:) * xcplmask(:,:,0) + zqsr(:,:) * zmsk(:,:) + ELSE ; qsr(:,:) = zqsr(:,:) + ENDIF + ! + ! salt flux over the ocean (received by opa in case of opa <-> sas coupling) + IF( srcv(jpr_sflx )%laction ) sfx(:,:) = frcv(jpr_sflx )%z3(:,:,1) + ! Ice cover (received by opa in case of opa <-> sas coupling) + IF( srcv(jpr_fice )%laction ) fr_i(:,:) = frcv(jpr_fice )%z3(:,:,1) + ! + ENDIF + ! + END SUBROUTINE sbc_cpl_rcv + + + SUBROUTINE sbc_cpl_ice_tau( p_taui, p_tauj ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_ice_tau *** + !! + !! ** Purpose : provide the stress over sea-ice in coupled mode + !! + !! ** Method : transform the received stress from the atmosphere into + !! an atmosphere-ice stress in the (i,j) ocean referencial + !! and at the velocity point of the sea-ice model: + !! 'C'-grid : i- (j-) components given at U- (V-) point + !! + !! The received stress are : + !! - defined by 3 components (if cartesian coordinate) + !! or by 2 components (if spherical) + !! - oriented along geographical coordinate (if eastward-northward) + !! or along the local grid coordinate (if local grid) + !! - given at U- and V-point, resp. if received on 2 grids + !! or at a same point (T or I) if received on 1 grid + !! Therefore and if necessary, they are successively + !! processed in order to obtain them + !! first as 2 components on the sphere + !! second as 2 components oriented along the local grid + !! third as 2 components on the ice grid point + !! + !! Except in 'oce and ice' case, only one vector stress field + !! is received. It has already been processed in sbc_cpl_rcv + !! so that it is now defined as (i,j) components given at U- + !! and V-points, respectively. + !! + !! ** Action : return ptau_i, ptau_j, the stress over the ice + !!---------------------------------------------------------------------- + REAL(wp), INTENT(inout), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2] + REAL(wp), INTENT(inout), DIMENSION(:,:) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid) + !! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: itx ! index of taux over ice + REAL(wp) :: zztmp1, zztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty + !!---------------------------------------------------------------------- + ! + ! + END SUBROUTINE sbc_cpl_ice_tau + + + SUBROUTINE sbc_cpl_ice_flx( kt, picefr, palbi, psst, pist, phs, phi ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_ice_flx *** + !! + !! ** Purpose : provide the heat and freshwater fluxes of the ocean-ice system + !! + !! ** Method : transform the fields received from the atmosphere into + !! surface heat and fresh water boundary condition for the + !! ice-ocean system. The following fields are provided: + !! * total non solar, solar and freshwater fluxes (qns_tot, + !! qsr_tot and emp_tot) (total means weighted ice-ocean flux) + !! NB: emp_tot include runoffs and calving. + !! * fluxes over ice (qns_ice, qsr_ice, emp_ice) where + !! emp_ice = sublimation - solid precipitation as liquid + !! precipitation are re-routed directly to the ocean and + !! calving directly enter the ocean (runoffs are read but included in trasbc.F90) + !! * solid precipitation (sprecip), used to add to qns_tot + !! the heat lost associated to melting solid precipitation + !! over the ocean fraction. + !! * heat content of rain, snow and evap can also be provided, + !! otherwise heat flux associated with these mass flux are + !! guessed (qemp_oce, qemp_ice) + !! + !! - the fluxes have been separated from the stress as + !! (a) they are updated at each ice time step compare to + !! an update at each coupled time step for the stress, and + !! (b) the conservative computation of the fluxes over the + !! sea-ice area requires the knowledge of the ice fraction + !! after the ice advection and before the ice thermodynamics, + !! so that the stress is updated before the ice dynamics + !! while the fluxes are updated after it. + !! + !! ** Details + !! qns_tot = (1-a) * qns_oce + a * qns_ice => provided + !! + qemp_oce + qemp_ice => recalculated and added up to qns + !! + !! qsr_tot = (1-a) * qsr_oce + a * qsr_ice => provided + !! + !! emp_tot = emp_oce + emp_ice => calving is provided and added to emp_tot (and emp_oce). + !! runoff (which includes rivers+icebergs) and iceshelf + !! are provided but not included in emp here. Only runoff will + !! be included in emp in other parts of NEMO code + !! + !! ** Note : In case of the ice-atm coupling with conduction fluxes (such as Jules interface for the Met-Office), + !! qsr_ice and qns_ice are not provided and they are not supposed to be used in the ice code. + !! However, by precaution we also "fake" qns_ice and qsr_ice this way: + !! qns_ice = qml_ice + qcn_ice ?? + !! qsr_ice = qtr_ice_top ?? + !! + !! ** Action : update at each nf_ice time step: + !! qns_tot, qsr_tot non-solar and solar total heat fluxes + !! qns_ice, qsr_ice non-solar and solar heat fluxes over the ice + !! emp_tot total evaporation - precipitation(liquid and solid) (-calving) + !! emp_ice ice sublimation - solid precipitation over the ice + !! dqns_ice d(non-solar heat flux)/d(Temperature) over the ice + !! sprecip solid precipitation over the ocean + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean model time step index (only for a_i_last_couple) + REAL(wp), INTENT(in) , DIMENSION(:,:) :: picefr ! ice fraction [0 to 1] + ! !! ! optional arguments, used only in 'mixed oce-ice' case or for Met-Office coupling + REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo + REAL(wp), INTENT(in) , DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] + REAL(wp), INTENT(inout), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] => inout for Met-Office + REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phs ! snow depth [m] + REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phi ! ice thickness [m] + ! + INTEGER :: ji, jj, jl ! dummy loop index + REAL(wp), DIMENSION(jpi,jpj) :: zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw + REAL(wp), DIMENSION(jpi,jpj) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip , zevap_oce, zdevap_ice + REAL(wp), DIMENSION(jpi,jpj) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice + REAL(wp), DIMENSION(jpi,jpj) :: zevap_ice_total + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top, ztsu + REAL(wp), DIMENSION(jpi,jpj) :: ztri + !!---------------------------------------------------------------------- + ! + ! + END SUBROUTINE sbc_cpl_ice_flx + + + SUBROUTINE sbc_cpl_snd( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_snd *** + !! + !! ** Purpose : provide the ocean-ice informations to the atmosphere + !! + !! ** Method : send to the atmosphere through a call to cpl_snd + !! all the needed fields (as defined in sbc_cpl_init) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean model time level index + ! + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: isec, info ! local integer + REAL(wp) :: zumax, zvmax + REAL(wp), DIMENSION(jpi,jpj) :: zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 + REAL(wp), DIMENSION(jpi,jpj,jpl) :: ztmp3, ztmp4 + !!---------------------------------------------------------------------- + ! + isec = ( kt - nit000 ) * NINT( rn_Dt ) ! date of exchanges + info = OASIS_idle + + zfr_l(:,:) = 1.- fr_i(:,:) + ! ! ------------------------- ! + ! ! Surface temperature ! in Kelvin + ! ! ------------------------- ! + IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN + + IF( nn_components == jp_iam_oce ) THEN + ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) ! send temperature as it is (potential or conservative) -> use of l_useCT on the received part + ELSE + ! we must send the surface potential temperature + IF( l_useCT ) THEN ; ztmp1(:,:) =eos_pt_from_ct( REAL(ts(:,:,1,jp_tem,Kmm),sp), REAL(ts(:,:,1,jp_sal,Kmm),sp) ) + ELSE ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) + ENDIF + ! + SELECT CASE( sn_snd_temp%cldes) + CASE( 'oce only' ) ; ztmp1(:,:) = ztmp1(:,:) + rt0 + CASE( 'oce and ice' ) ; ztmp1(:,:) = ztmp1(:,:) + rt0 + SELECT CASE( sn_snd_temp%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) + CASE( 'no' ) + WHERE( SUM( a_i, dim=3 ) /= 0. ) + ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) + ELSEWHERE + ztmp3(:,:,1) = rt0 + END WHERE + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) + END SELECT + CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) + SELECT CASE( sn_snd_temp%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE( 'no' ) + ztmp3(:,:,:) = 0.0 + DO jl=1,jpl + ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) + END SELECT + CASE( 'oce and weighted ice') ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) + rt0 + SELECT CASE( sn_snd_temp%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE( 'no' ) + ztmp3(:,:,:) = 0.0 + DO jl=1,jpl + ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) + END SELECT + CASE( 'mixed oce-ice' ) + ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) + DO jl=1,jpl + ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) + END SELECT + ENDIF + IF( ssnd(jps_toce)%laction ) CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_tice)%laction ) CALL cpl_snd( jps_tice, isec, ztmp3, info ) + IF( ssnd(jps_tmix)%laction ) CALL cpl_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + ENDIF + ! + ! ! ------------------------- ! + ! ! 1st layer ice/snow temp. ! + ! ! ------------------------- ! + ! ! ------------------------- ! + ! ! Albedo ! + ! ! ------------------------- ! + IF( ssnd(jps_albice)%laction ) THEN ! ice + SELECT CASE( sn_snd_alb%cldes ) + CASE( 'ice' ) + SELECT CASE( sn_snd_alb%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) + CASE( 'no' ) + WHERE( SUM( a_i, dim=3 ) /= 0. ) + ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 ) + ELSEWHERE + ztmp1(:,:) = alb_oce_mix(:,:) + END WHERE + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%clcat' ) + END SELECT + CASE( 'weighted ice' ) ; + SELECT CASE( sn_snd_alb%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE( 'no' ) + WHERE( fr_i (:,:) > 0. ) + ztmp1(:,:) = SUM ( alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) + ELSEWHERE + ztmp1(:,:) = 0. + END WHERE + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ice%clcat' ) + END SELECT + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) + END SELECT + + SELECT CASE( sn_snd_alb%clcat ) + CASE( 'yes' ) + CALL cpl_snd( jps_albice, isec, ztmp3, info ) !-> MV this has never been checked in coupled mode + CASE( 'no' ) + CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + END SELECT + ENDIF + + IF( ssnd(jps_albmix)%laction ) THEN ! mixed ice-ocean + ztmp1(:,:) = alb_oce_mix(:,:) * zfr_l(:,:) + DO jl = 1, jpl + ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(:,:,jl) + END DO + CALL cpl_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + ENDIF + ! ! ------------------------- ! + ! ! Ice fraction & Thickness ! + ! ! ------------------------- ! + ! Send ice fraction field to atmosphere + IF( ssnd(jps_fice)%laction ) THEN + SELECT CASE( sn_snd_thick%clcat ) + CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl) + CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(:,: ) + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) + END SELECT + CALL cpl_snd( jps_fice, isec, ztmp3, info ) + ENDIF + + + IF( ssnd(jps_fice1)%laction ) THEN + SELECT CASE( sn_snd_thick1%clcat ) + CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl) + CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(:,: ) + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick1%clcat' ) + END SELECT + CALL cpl_snd( jps_fice1, isec, ztmp3, info ) + ENDIF + + ! Send ice fraction field to OCE (sent by SAS in SAS-OCE coupling) + IF( ssnd(jps_fice2)%laction ) THEN + ztmp3(:,:,1) = fr_i(:,:) + IF( ssnd(jps_fice2)%laction ) CALL cpl_snd( jps_fice2, isec, ztmp3, info ) + ENDIF + + ! Send ice and snow thickness field + IF( ssnd(jps_hice)%laction .OR. ssnd(jps_hsnw)%laction ) THEN + SELECT CASE( sn_snd_thick%cldes) + CASE( 'none' ) ! nothing to do + CASE( 'weighted ice and snow' ) + SELECT CASE( sn_snd_thick%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl) * a_i(:,:,1:jpl) + ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE( 'no' ) + ztmp3(:,:,:) = 0.0 ; ztmp4(:,:,:) = 0.0 + DO jl=1,jpl + ztmp3(:,:,1) = ztmp3(:,:,1) + h_i(:,:,jl) * a_i(:,:,jl) + ztmp4(:,:,1) = ztmp4(:,:,1) + h_s(:,:,jl) * a_i(:,:,jl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) + END SELECT + CASE( 'ice and snow' ) + SELECT CASE( sn_snd_thick%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl) + ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl) + CASE( 'no' ) + WHERE( SUM( a_i, dim=3 ) /= 0. ) + ztmp3(:,:,1) = SUM( h_i * a_i, dim=3 ) / SUM( a_i, dim=3 ) + ztmp4(:,:,1) = SUM( h_s * a_i, dim=3 ) / SUM( a_i, dim=3 ) + ELSEWHERE + ztmp3(:,:,1) = 0. + ztmp4(:,:,1) = 0. + END WHERE + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) + END SELECT + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' ) + END SELECT + IF( ssnd(jps_hice)%laction ) CALL cpl_snd( jps_hice, isec, ztmp3, info ) + IF( ssnd(jps_hsnw)%laction ) CALL cpl_snd( jps_hsnw, isec, ztmp4, info ) + ENDIF + + + ! ! ------------------------- ! + ! ! CO2 flux from PISCES ! + ! ! ------------------------- ! + IF( ssnd(jps_co2)%laction .AND. l_co2cpl ) THEN + ztmp1(:,:) = oce_co2(:,:) * 1000. ! conversion in molC/m2/s + CALL cpl_snd( jps_co2, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ) , info ) + ENDIF + ! + ! ! ------------------------- ! + IF( ssnd(jps_ocx1)%laction ) THEN ! Surface current ! + ! ! ------------------------- ! + ! + ! j+1 j -----V---F + ! surface velocity always sent from T point ! | + ! j | T U + ! | | + ! j j-1 -I-------| + ! (for I) | | + ! i-1 i i + ! i i+1 (for I) + IF( nn_components == jp_iam_oce ) THEN + zotx1(:,:) = uu(:,:,1,Kmm) + zoty1(:,:) = vv(:,:,1,Kmm) + ELSE + SELECT CASE( TRIM( sn_snd_crt%cldes ) ) + CASE( 'oce only' ) ! C-grid ==> T + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Kmm) + uu(ji-1,jj ,1,Kmm) ) + zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Kmm) + vv(ji ,jj-1,1,Kmm) ) + END DO ; END DO + CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) + zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) + zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) + zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) + END DO ; END DO + CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) + CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) & + & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) + zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) & + & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) + END DO ; END DO + END SELECT + CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp ) + ! + ENDIF + ! + ! + IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components + ! ! Ocean component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zotx1(:,:) = ztmp1(:,:) ! overwrite the components + zoty1(:,:) = ztmp2(:,:) + IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zitx1(:,:) = ztmp1(:,:) ! overwrite the components + zity1(:,:) = ztmp2(:,:) + ENDIF + ENDIF + ! + ! spherical coordinates to cartesian -> 2 components to 3 components + IF( TRIM( sn_snd_crt%clvref ) == 'cartesian' ) THEN + ztmp1(:,:) = zotx1(:,:) ! ocean currents + ztmp2(:,:) = zoty1(:,:) + CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 ) + ! + IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities + ztmp1(:,:) = zitx1(:,:) + ztmp1(:,:) = zity1(:,:) + CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 ) + ENDIF + ENDIF + ! + IF( ssnd(jps_ocx1)%laction ) CALL cpl_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid + IF( ssnd(jps_ocy1)%laction ) CALL cpl_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid + IF( ssnd(jps_ocz1)%laction ) CALL cpl_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/jpi,jpj,1/) ), info ) ! ocean z current 1st grid + ! + IF( ssnd(jps_ivx1)%laction ) CALL cpl_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/jpi,jpj,1/) ), info ) ! ice x current 1st grid + IF( ssnd(jps_ivy1)%laction ) CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info ) ! ice y current 1st grid + IF( ssnd(jps_ivz1)%laction ) CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info ) ! ice z current 1st grid + ! + ENDIF + ! + ! ! ------------------------- ! + ! ! Surface current to waves ! + ! ! ------------------------- ! + IF( ssnd(jps_ocxw)%laction .OR. ssnd(jps_ocyw)%laction ) THEN + ! + ! j+1 j -----V---F + ! surface velocity always sent from T point ! | + ! j | T U + ! | | + ! j j-1 -I-------| + ! (for I) | | + ! i-1 i i + ! i i+1 (for I) + SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) + CASE( 'oce only' ) ! C-grid ==> T + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Kmm) + uu(ji-1,jj ,1,Kmm) ) + zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Kmm) + vv(ji , jj-1,1,Kmm) ) + END DO ; END DO + CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) + zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) + zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) + zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) + END DO ; END DO + CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) + CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) & + & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) + zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) & + & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) + END DO ; END DO + END SELECT + CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) + ! + ! + IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components + ! ! Ocean component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zotx1(:,:) = ztmp1(:,:) ! overwrite the components + zoty1(:,:) = ztmp2(:,:) + IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zitx1(:,:) = ztmp1(:,:) ! overwrite the components + zity1(:,:) = ztmp2(:,:) + ENDIF + ENDIF + ! +! ! spherical coordinates to cartesian -> 2 components to 3 components +! IF( TRIM( sn_snd_crtw%clvref ) == 'cartesian' ) THEN +! ztmp1(:,:) = zotx1(:,:) ! ocean currents +! ztmp2(:,:) = zoty1(:,:) +! CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 ) +! ! +! IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities +! ztmp1(:,:) = zitx1(:,:) +! ztmp1(:,:) = zity1(:,:) +! CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 ) +! ENDIF +! ENDIF + ! + IF( ssnd(jps_ocxw)%laction ) CALL cpl_snd( jps_ocxw, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid + IF( ssnd(jps_ocyw)%laction ) CALL cpl_snd( jps_ocyw, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid + ! + ENDIF + ! + IF( ssnd(jps_ficet)%laction ) THEN + CALL cpl_snd( jps_ficet, isec, RESHAPE ( fr_i, (/jpi,jpj,1/) ), info ) + ENDIF + ! ! ------------------------- ! + ! ! Water levels to waves ! + ! ! ------------------------- ! + IF( ssnd(jps_wlev)%laction ) THEN + IF( ln_apr_dyn ) THEN + IF( kt /= nit000 ) THEN + ztmp1(:,:) = ssh(:,:,Kbb) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE + ztmp1(:,:) = ssh(:,:,Kbb) + ENDIF + ELSE + ztmp1(:,:) = ssh(:,:,Kmm) + ENDIF + CALL cpl_snd( jps_wlev , isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + ENDIF + ! + ! Fields sent by OCE to SAS when doing OCE<->SAS coupling + ! ! SSH + IF( ssnd(jps_ssh )%laction ) THEN + ! ! removed inverse barometer ssh when Patm + ! forcing is used (for sea-ice dynamics) + IF( ln_apr_dyn ) THEN ; ztmp1(:,:) = ssh(:,:,Kbb) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE ; ztmp1(:,:) = ssh(:,:,Kmm) + ENDIF + CALL cpl_snd( jps_ssh , isec, RESHAPE ( ztmp1 , (/jpi,jpj,1/) ), info ) + + ENDIF + ! ! SSS + IF( ssnd(jps_soce )%laction ) THEN + CALL cpl_snd( jps_soce , isec, REAL(RESHAPE ( ts(:,:,1,jp_sal,Kmm), (/jpi,jpj,1/) ),sp), info ) + ENDIF + ! ! first T level thickness + IF( ssnd(jps_e3t1st )%laction ) THEN + CALL cpl_snd( jps_e3t1st, isec, REAL(RESHAPE ( (e3t_0(:,:,1)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,1))) , (/jpi,jpj,1/) ),sp), info ) + ENDIF + ! ! Qsr fraction + IF( ssnd(jps_fraqsr)%laction ) THEN + CALL cpl_snd( jps_fraqsr, isec, RESHAPE ( fraqsr_1lev(:,:) , (/jpi,jpj,1/) ), info ) + ENDIF + ! + ! Fields sent by SAS to OCE when OASIS coupling + ! ! Solar heat flux + IF( ssnd(jps_qsroce)%laction ) CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr , (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_qnsoce)%laction ) CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns , (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_oemp )%laction ) CALL cpl_snd( jps_oemp , isec, RESHAPE ( emp , (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_sflx )%laction ) CALL cpl_snd( jps_sflx , isec, RESHAPE ( sfx , (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_otx1 )%laction ) CALL cpl_snd( jps_otx1 , isec, RESHAPE ( utau, (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_oty1 )%laction ) CALL cpl_snd( jps_oty1 , isec, RESHAPE ( vtau, (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_rnf )%laction ) CALL cpl_snd( jps_rnf , isec, RESHAPE ( rnf , (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_taum )%laction ) CALL cpl_snd( jps_taum , isec, RESHAPE ( taum, (/jpi,jpj,1/) ), info ) + + ! + END SUBROUTINE sbc_cpl_snd + + !!====================================================================== +END MODULE sbccpl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcdcy.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcdcy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f6039f9b37246c0e0c5772455a010f7b827fa572 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcdcy.f90 @@ -0,0 +1,285 @@ + + + + + + + + + + + + + +MODULE sbcdcy + !!====================================================================== + !! *** MODULE sbcdcy *** + !! Ocean forcing: compute the diurnal cycle + !!====================================================================== + !! History : OPA ! 2005-02 (D. Bernie) Original code + !! NEMO 2.0 ! 2006-02 (S. Masson, G. Madec) adaptation to NEMO + !! 3.1 ! 2009-07 (J.M. Molines) adaptation to v3.1 + !! 4.* ! 2019-10 (L. Brodeau) nothing really new, but the routine + !! ! "sbc_dcy_param" has been extracted from old function "sbc_dcy" + !! ! => this allows the warm-layer param of COARE3* to know the time + !! ! of dawn and dusk even if "ln_dm2dc=.false." (rdawn_dcy & rdusk_dcy + !! ! are now public) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_dcy : solar flux at kt from daily mean, taking diurnal cycle into account + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE phycst ! ocean physics + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + INTEGER, PUBLIC :: nday_qsr !: day when parameters were computed + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: raa , rbb , rcc , rab ! diurnal cycle parameters + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: rtmd, rscal ! - - - + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rdawn_dcy, rdusk_dcy ! - - - + + PUBLIC sbc_dcy ! routine called by sbc + PUBLIC sbc_dcy_param ! routine used here and called by warm-layer parameterization (sbcblk_skin_coare*) + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcdcy.F90 13483 2020-09-17 08:24:00Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_dcy_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_dcy_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( raa (jpi,jpj) , rbb (jpi,jpj) , rcc (jpi,jpj) , rab (jpi,jpj) , & + & rtmd(jpi,jpj) , rdawn_dcy(jpi,jpj) , rdusk_dcy(jpi,jpj) , rscal(jpi,jpj) , STAT=sbc_dcy_alloc ) + ! + CALL mpp_sum ( 'sbcdcy', sbc_dcy_alloc ) + IF( sbc_dcy_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_dcy_alloc: failed to allocate arrays' ) + END FUNCTION sbc_dcy_alloc + + + FUNCTION sbc_dcy( pqsrin, l_mask ) RESULT( zqsrout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_dcy *** + !! + !! ** Purpose : introduce a diurnal cycle of qsr from daily values + !! + !! ** Method : see Appendix A of Bernie et al. 2007. + !! + !! ** Action : redistribute daily QSR on each time step following the diurnal cycle + !! + !! reference : Bernie, DJ, E Guilyardi, G Madec, JM Slingo, and SJ Woolnough, 2007 + !! Impact of resolving the diurnal cycle in an ocean--atmosphere GCM. + !! Part 1: a diurnally forced OGCM. Climate Dynamics 29:6, 575-590. + !!---------------------------------------------------------------------- + LOGICAL , OPTIONAL , INTENT(in) :: l_mask ! use the routine for night mask computation + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqsrin ! input daily QSR flux + REAL(wp), DIMENSION(jpi,jpj) :: zqsrout ! output QSR flux with diurnal cycle + !! + INTEGER :: ji, jj ! dummy loop indices + INTEGER, DIMENSION(jpi,jpj) :: imask_night ! night mask + REAL(wp) :: zlo, zup, zlousd, zupusd + REAL(wp) :: ztmp, ztmp1, ztmp2 + REAL(wp) :: ztmpm, ztmpm1, ztmpm2 + !!--------------------------------------------------------------------- + ! + ! Initialization + ! -------------- + ! When are we during the day (from 0 to 1) + zlo = ( REAL(nsec_day, wp) - 0.5_wp * rn_Dt ) / rday + zup = zlo + ( REAL(nn_fsbc, wp) * rn_Dt ) / rday + ! + IF( nday_qsr == -1 ) THEN ! first time step only + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_dcy : introduce diurnal cycle from daily mean qsr' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) + ENDIF + ENDIF + + ! Setting parameters for each new day: + CALL sbc_dcy_param() + + !CALL iom_put( "rdusk_dcy", rdusk_dcy(:,:)*tmask(:,:,1) ) !LB + !CALL iom_put( "rdawn_dcy", rdawn_dcy(:,:)*tmask(:,:,1) ) !LB + !CALL iom_put( "rscal_dcy", rscal(:,:)*tmask(:,:,1) ) !LB + + + ! 3. update qsr with the diurnal cycle + ! ------------------------------------ + + imask_night(:,:) = 0 + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ztmpm = 0._wp + IF( ABS(rab(ji,jj)) < 1. ) THEN ! day duration is less than 24h + ! + IF( rdawn_dcy(ji,jj) < rdusk_dcy(ji,jj) ) THEN ! day time in one part + zlousd = MAX(zlo, rdawn_dcy(ji,jj)) + zlousd = MIN(zlousd, zup) + zupusd = MIN(zup, rdusk_dcy(ji,jj)) + zupusd = MAX(zupusd, zlo) + ztmp = fintegral(zlousd, zupusd, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + zqsrout(ji,jj) = pqsrin(ji,jj) * ztmp * rscal(ji,jj) + ztmpm = zupusd - zlousd + IF( ztmpm .EQ. 0 ) imask_night(ji,jj) = 1 + ! + ELSE ! day time in two parts + zlousd = MIN(zlo, rdusk_dcy(ji,jj)) + zupusd = MIN(zup, rdusk_dcy(ji,jj)) + ztmp1 = fintegral(zlousd, zupusd, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + ztmpm1=zupusd-zlousd + zlousd = MAX(zlo, rdawn_dcy(ji,jj)) + zupusd = MAX(zup, rdawn_dcy(ji,jj)) + ztmp2 = fintegral(zlousd, zupusd, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + ztmpm2 =zupusd-zlousd + ztmp = ztmp1 + ztmp2 + ztmpm = ztmpm1 + ztmpm2 + zqsrout(ji,jj) = pqsrin(ji,jj) * ztmp * rscal(ji,jj) + IF(ztmpm .EQ. 0.) imask_night(ji,jj) = 1 + ENDIF + ELSE ! 24h light or 24h night + ! + IF( raa(ji,jj) > rbb(ji,jj) ) THEN ! 24h day + ztmp = fintegral(zlo, zup, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + zqsrout(ji,jj) = pqsrin(ji,jj) * ztmp * rscal(ji,jj) + imask_night(ji,jj) = 0 + ! + ELSE ! No day + zqsrout(ji,jj) = 0.0_wp + imask_night(ji,jj) = 1 + ENDIF + ENDIF + END DO ; END DO + ! + IF( PRESENT(l_mask) .AND. l_mask ) THEN + zqsrout(:,:) = float(imask_night(:,:)) + ENDIF + ! + END FUNCTION sbc_dcy + + + SUBROUTINE sbc_dcy_param( ) + !! + INTEGER :: ji, jj ! dummy loop indices + !INTEGER, DIMENSION(jpi,jpj) :: imask_night ! night mask + REAL(wp) :: zdsws, zdecrad, ztx, zsin, zcos + REAL(wp) :: ztmp, ztest + !---------------------------statement functions------------------------ + ! + IF( nday_qsr == -1 ) THEN ! first time step only + ! allocate sbcdcy arrays + IF( sbc_dcy_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_dcy_alloc : unable to allocate arrays' ) + ! Compute rcc needed to compute the time integral of the diurnal cycle + rcc(:,:) = rad * glamt(:,:) - rpi + ! time of midday + rtmd(:,:) = 0.5_wp - glamt(:,:) / 360._wp + rtmd(:,:) = MOD( (rtmd(:,:) + 1._wp) , 1._wp) + ENDIF + + ! If this is a new day, we have to update the dawn, dusk and scaling function + !---------------------- + + ! 2.1 dawn and dusk + + ! nday is the number of days since the beginning of the current month + IF( nday_qsr /= nday ) THEN + ! save the day of the year and the daily mean of qsr + nday_qsr = nday + ! number of days since the previous winter solstice (supposed to be always 21 December) + zdsws = REAL(11 + nday_year, wp) + ! declination of the earths orbit + zdecrad = (-23.5_wp * rad) * COS( zdsws * 2._wp*rpi / REAL(nyear_len(1),wp) ) + ! Compute A and B needed to compute the time integral of the diurnal cycle + + zsin = SIN( zdecrad ) ; zcos = COS( zdecrad ) + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ztmp = rad * gphit(ji,jj) + raa(ji,jj) = SIN( ztmp ) * zsin + rbb(ji,jj) = COS( ztmp ) * zcos + END DO ; END DO + ! Compute the time of dawn and dusk + + ! rab to test if the day time is equal to 0, less than 24h of full day + rab(:,:) = -raa(:,:) / rbb(:,:) + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h + ! When is it night? + ztx = 1._wp/(2._wp*rpi) * (ACOS(rab(ji,jj)) - rcc(ji,jj)) + ztest = -rbb(ji,jj) * SIN( rcc(ji,jj) + 2._wp*rpi * ztx ) + ! is it dawn or dusk? + IF( ztest > 0._wp ) THEN + rdawn_dcy(ji,jj) = ztx + rdusk_dcy(ji,jj) = rtmd(ji,jj) + ( rtmd(ji,jj) - rdawn_dcy(ji,jj) ) + ELSE + rdusk_dcy(ji,jj) = ztx + rdawn_dcy(ji,jj) = rtmd(ji,jj) - ( rdusk_dcy(ji,jj) - rtmd(ji,jj) ) + ENDIF + ELSE + rdawn_dcy(ji,jj) = rtmd(ji,jj) + 0.5_wp + rdusk_dcy(ji,jj) = rdawn_dcy(ji,jj) + ENDIF + END DO ; END DO + rdawn_dcy(:,:) = MOD( (rdawn_dcy(:,:) + 1._wp), 1._wp ) + rdusk_dcy(:,:) = MOD( (rdusk_dcy(:,:) + 1._wp), 1._wp ) + ! 2.2 Compute the scaling function: + ! S* = the inverse of the time integral of the diurnal cycle from dawn to dusk + ! Avoid possible infinite scaling factor, associated with very short daylight + ! periods, by ignoring periods less than 1/1000th of a day (ticket #1040) + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h + rscal(ji,jj) = 0.0_wp + IF( rdawn_dcy(ji,jj) < rdusk_dcy(ji,jj) ) THEN ! day time in one part + IF( (rdusk_dcy(ji,jj) - rdawn_dcy(ji,jj) ) .ge. 0.001_wp ) THEN + rscal(ji,jj) = fintegral(rdawn_dcy(ji,jj), rdusk_dcy(ji,jj), raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + rscal(ji,jj) = 1._wp / rscal(ji,jj) + ENDIF + ELSE ! day time in two parts + IF( (rdusk_dcy(ji,jj) + (1._wp - rdawn_dcy(ji,jj)) ) .ge. 0.001_wp ) THEN + rscal(ji,jj) = fintegral(0._wp, rdusk_dcy(ji,jj), raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) & + & + fintegral(rdawn_dcy(ji,jj), 1._wp, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + rscal(ji,jj) = 1. / rscal(ji,jj) + ENDIF + ENDIF + ELSE + IF( raa(ji,jj) > rbb(ji,jj) ) THEN ! 24h day + rscal(ji,jj) = fintegral(0._wp, 1._wp, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + rscal(ji,jj) = 1._wp / rscal(ji,jj) + ELSE ! No day + rscal(ji,jj) = 0.0_wp + ENDIF + ENDIF + END DO ; END DO + ! + ztmp = rday / ( rn_Dt * REAL(nn_fsbc, wp) ) + rscal(:,:) = rscal(:,:) * ztmp + ! + ENDIF !IF( nday_qsr /= nday ) + ! + END SUBROUTINE sbc_dcy_param + + + FUNCTION fintegral( pt1, pt2, paaa, pbbb, pccc ) + REAL(wp), INTENT(in) :: pt1, pt2, paaa, pbbb, pccc + REAL(wp) :: fintegral + fintegral = paaa * pt2 + 1._wp/(2._wp*rpi) * pbbb * SIN(pccc + 2._wp*rpi*pt2) & + & - paaa * pt1 - 1._wp/(2._wp*rpi) * pbbb * SIN(pccc + 2._wp*rpi*pt1) + END FUNCTION fintegral + + !!====================================================================== +END MODULE sbcdcy diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcflx.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcflx.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fa2dc63618d6af8b16470aa163769bf471ce34b9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcflx.f90 @@ -0,0 +1,194 @@ + + + + + + + + + + + + + +MODULE sbcflx + !!====================================================================== + !! *** MODULE sbcflx *** + !! Ocean forcing: momentum, heat and freshwater flux formulation + !!===================================================================== + !! History : 1.0 ! 2006-06 (G. Madec) Original code + !! 3.3 ! 2010-10 (S. Masson) add diurnal cycle + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! namflx : flux formulation namlist + !! sbc_flx : flux formulation as ocean surface boundary condition (forced mode, fluxes read in NetCDF files) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition: ocean fields + USE trc_oce ! share SMS/Ocean variables + USE sbcdcy ! surface boundary condition: diurnal cycle on qsr + USE phycst ! physical constants + ! + USE fldread ! read input fields + USE iom ! IOM library + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_flx ! routine called by step.F90 + + INTEGER , PARAMETER :: jp_utau = 1 ! index of wind stress (i-component) file + INTEGER , PARAMETER :: jp_vtau = 2 ! index of wind stress (j-component) file + INTEGER , PARAMETER :: jp_qtot = 3 ! index of total (non solar+solar) heat file + INTEGER , PARAMETER :: jp_qsr = 4 ! index of solar heat file + INTEGER , PARAMETER :: jp_emp = 5 ! index of evaporation-precipation file + !!INTEGER , PARAMETER :: jp_sfx = 6 ! index of salt flux flux + INTEGER , PARAMETER :: jpfld = 5 !! 6 ! maximum number of files to read + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcflx.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_flx( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_flx *** + !! + !! ** Purpose : provide at each time step the surface ocean fluxes + !! (momentum, heat, freshwater and runoff) + !! + !! ** Method : - READ each fluxes in NetCDF files: + !! i-component of the stress utau (N/m2) + !! j-component of the stress vtau (N/m2) + !! net downward heat flux qtot (watt/m2) + !! net downward radiative flux qsr (watt/m2) + !! net upward freshwater (evapo - precip) emp (kg/m2/s) + !! salt flux sfx (pss*dh*rho/dt => g/m2/s) + !! + !! CAUTION : - never mask the surface stress fields + !! - the stress is assumed to be in the (i,j) mesh referential + !! + !! ** Action : update at each time-step + !! - utau, vtau i- and j-component of the wind stress + !! - taum wind stress module at T-point + !! - wndm 10m wind module at T-point + !! - qns non solar heat flux including heat flux due to emp + !! - qsr solar heat flux + !! - emp upward mass flux (evap. - precip.) + !! - sfx salt flux; set to zero at nit000 but possibly non-zero + !! if ice + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !! + INTEGER :: ji, jj, jf ! dummy indices + INTEGER :: ierror ! return error code + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp) :: zfact ! temporary scalar + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: ztx, zty, zmod, zcoef ! temporary variables + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of flx files + TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist information structures + TYPE(FLD_N) :: sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx ! informations about the fields to be read + NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN ! First call kt=nit000 + ! set file information + READ ( numnam_ref, namsbc_flx, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_flx in reference namelist' ) + + READ ( numnam_cfg, namsbc_flx, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_flx in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_flx ) + ! + ! ! check: do we plan to use ln_dm2dc with non-daily forcing? + IF( ln_dm2dc .AND. sn_qsr%freqh /= 24. ) & + & CALL ctl_stop( 'sbc_blk_core: ln_dm2dc can be activated only with daily short-wave forcing' ) + ! + ! ! store namelist information in an array + slf_i(jp_utau) = sn_utau ; slf_i(jp_vtau) = sn_vtau + slf_i(jp_qtot) = sn_qtot ; slf_i(jp_qsr ) = sn_qsr + slf_i(jp_emp ) = sn_emp !! ; slf_i(jp_sfx ) = sn_sfx + ! + ALLOCATE( sf(jpfld), STAT=ierror ) ! set sf structure + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_flx: unable to allocate sf structure' ) ; RETURN + ENDIF + DO ji= 1, jpfld + ALLOCATE( sf(ji)%fnow(jpi,jpj,1) ) + IF( slf_i(ji)%ln_tint ) ALLOCATE( sf(ji)%fdta(jpi,jpj,1,2) ) + END DO + ! ! fill sf with slf_i and control print + CALL fld_fill( sf, slf_i, cn_dir, 'sbc_flx', 'flux formulation for ocean surface boundary condition', 'namsbc_flx' ) + sf(jp_utau)%cltype = 'U' ; sf(jp_utau)%zsgn = -1._wp ! vector field at U point: overwrite default definition of cltype and zsgn + sf(jp_vtau)%cltype = 'V' ; sf(jp_vtau)%zsgn = -1._wp ! vector field at V point: overwrite default definition of cltype and zsgn + ! + ENDIF + + CALL fld_read( kt, nn_fsbc, sf ) ! input fields provided at the current time-step + + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! update ocean fluxes at each SBC frequency + + IF( ln_dm2dc ) THEN ! modify now Qsr to include the diurnal cycle + qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) + ELSE + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + qsr(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1) + END DO ; END DO + ENDIF + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! set the ocean fluxes from read fields + utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) * umask(ji,jj,1) + vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) * vmask(ji,jj,1) + qns (ji,jj) = ( sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) ) * tmask(ji,jj,1) + emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) * tmask(ji,jj,1) + !!sfx (ji,jj) = sf(jp_sfx )%fnow(ji,jj,1) * tmask(ji,jj,1) + END DO ; END DO + ! ! add to qns the heat due to e-p + !!clem: I do not think it is needed + !!qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! mass flux is at SST + ! + IF( nitend-nit000 <= 100 .AND. lwp ) THEN ! control print (if less than 100 time-step asked) + WRITE(numout,*) + WRITE(numout,*) ' read daily momentum, heat and freshwater fluxes OK' + DO jf = 1, jpfld + IF( jf == jp_utau .OR. jf == jp_vtau ) zfact = 1. + IF( jf == jp_qtot .OR. jf == jp_qsr ) zfact = 0.1 + IF( jf == jp_emp ) zfact = 86400. + WRITE(numout,*) + WRITE(numout,*) ' day: ', ndastp , TRIM(sf(jf)%clvar), ' * ', zfact + END DO + ENDIF + ! + ENDIF + ! ! module of wind stress and wind speed at T-point + ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines + zcoef = 1. / ( zrhoa * zcdrag ) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ztx = ( utau(ji-1,jj ) + utau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( umask(ji-1,jj ,1), umask(ji,jj,1) ) ) + zty = ( vtau(ji ,jj-1) + vtau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( vmask(ji ,jj-1,1), vmask(ji,jj,1) ) ) + zmod = SQRT( ztx * ztx + zty * zty ) * tmask(ji,jj,1) + taum(ji,jj) = zmod + wndm(ji,jj) = SQRT( zmod * zcoef ) !!clem: not used? + END DO ; END DO + ! + CALL lbc_lnk( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp ) + ! + END SUBROUTINE sbc_flx + + !!====================================================================== +END MODULE sbcflx diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcfwb.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcfwb.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dfe0e36ce71cdff8cfbea8f2f92176b10f994819 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcfwb.f90 @@ -0,0 +1,267 @@ + + + + + + + + + + + + + +MODULE sbcfwb + !!====================================================================== + !! *** MODULE sbcfwb *** + !! Ocean fluxes : domain averaged freshwater budget + !!====================================================================== + !! History : OPA ! 2001-02 (E. Durand) Original code + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.0 ! 2006-08 (G. Madec) Surface module + !! 3.2 ! 2009-07 (C. Talandier) emp mean s spread over erp area + !! 3.6 ! 2014-11 (P. Mathiot ) add ice shelf melting + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_fwb : freshwater budget for global ocean configurations (free surface & forced mode) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface ocean boundary condition + USE isf_oce , ONLY : fwfisf_cav, fwfisf_par ! ice shelf melting contribution + USE sbc_ice , ONLY : snwice_mass, snwice_mass_b, snwice_fmass + USE phycst ! physical constants + USE sbcrnf ! ocean runoffs + USE sbcssr ! Sea-Surface damping terms + ! + USE in_out_manager ! I/O manager + USE iom ! IOM + USE lib_mpp ! distribued memory computing library + USE timing ! Timing + USE lbclnk ! ocean lateral boundary conditions + USE lib_fortran ! + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_fwb ! routine called by step + + REAL(wp) :: rn_fwb0 ! initial freshwater adjustment flux [kg/m2/s] (nn_fwb = 2 only) + REAL(wp) :: a_fwb ! annual domain averaged freshwater budget from the previous year + REAL(wp) :: a_fwb_b ! annual domain averaged freshwater budget from the year before or at initial state + REAL(wp) :: a_fwb_ini ! initial domain averaged freshwater budget + REAL(wp) :: area ! global mean ocean surface (interior domain) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcfwb.F90 15439 2021-10-22 17:53:09Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_fwb( kt, kn_fwb, kn_fsbc, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_fwb *** + !! + !! ** Purpose : Control the mean sea surface drift + !! + !! ** Method : several ways depending on kn_fwb + !! =0 no control + !! =1 global mean of emp set to zero at each nn_fsbc time step + !! =2 annual global mean corrected from previous year + !! =3 global mean of emp set to zero at each nn_fsbc time step + !! & spread out over erp area depending its sign + !! Note: if sea ice is embedded it is taken into account when computing the budget + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( in ) :: kn_fsbc ! + INTEGER, INTENT( in ) :: kn_fwb ! ocean time-step index + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + ! + INTEGER :: ios, inum, ikty ! local integers + REAL(wp) :: z_fwf, z_fwf_nsrf, zsum_fwf, zsum_erp ! local scalars + REAL(wp) :: zsurf_neg, zsurf_pos, zsurf_tospread, zcoef ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_neg, ztmsk_pos, z_wgt ! 2D workspaces + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_tospread, zerp_cor ! - - + REAL(wp) ,DIMENSION(1) :: z_fwfprv + COMPLEX(dp),DIMENSION(1) :: y_fwfnow + ! + NAMELIST/namsbc_fwb/rn_fwb0 + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + READ( numnam_ref, namsbc_fwb, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam( ios, 'namsbc_fwb in reference namelist' ) + READ( numnam_cfg, namsbc_fwb, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam( ios, 'namsbc_fwb in configuration namelist' ) + IF(lwm) WRITE( numond, namsbc_fwb ) + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_fwb : FreshWater Budget correction' + WRITE(numout,*) '~~~~~~~' + IF( kn_fwb == 1 ) WRITE(numout,*) ' instantaneously set to zero' + IF( kn_fwb == 3 ) WRITE(numout,*) ' fwf set to zero and spread out over erp area' + IF( kn_fwb == 2 ) THEN + WRITE(numout,*) ' adjusted from previous year budget' + WRITE(numout,*) + WRITE(numout,*) ' Namelist namsbc_fwb' + WRITE(numout,*) ' Initial freshwater adjustment flux [kg/m2/s] = ', rn_fwb0 + END IF + ENDIF + ! + IF( kn_fwb == 3 .AND. nn_sssr /= 2 ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 requires nn_sssr = 2, we stop ' ) + IF( kn_fwb == 3 .AND. ln_isfcav ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 with ln_isfcav = .TRUE. not working, we stop ' ) + ! + area = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask(:,:,1)) ! interior global domain surface + ! isf cavities are excluded because it can feedback to the melting with generation of inhibition of plumes + ! and in case of no melt, it can generate HSSW. + ! + snwice_mass_b(:,:) = 0.e0 ! no sea-ice model is being used : no snow+ice mass + snwice_mass (:,:) = 0.e0 + snwice_fmass (:,:) = 0.e0 + ! + ENDIF + + SELECT CASE ( kn_fwb ) + ! + CASE ( 1 ) !== global mean fwf set to zero ==! + ! + IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN + y_fwfnow(1) = local_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) ) + CALL mpp_delay_sum( 'sbcfwb', 'fwb', y_fwfnow(:), z_fwfprv(:), kt == nitend - nn_fsbc + 1 ) + z_fwfprv(1) = z_fwfprv(1) / area + zcoef = z_fwfprv(1) * rcp + emp(:,:) = emp(:,:) - z_fwfprv(1) * tmask(:,:,1) + qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction + ! outputs + IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', zcoef * sst_m(:,:) * tmask(:,:,1) ) + IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', z_fwfprv(1) * tmask(:,:,1) ) + ENDIF + ! + CASE ( 2 ) !== fw adjustment based on fw budget at the end of the previous year ==! + ! simulation is supposed to start 1st of January + IF( kt == nit000 ) THEN ! initialisation + ! ! set the fw adjustment (a_fwb) + IF ( ln_rstart .AND. iom_varid( numror, 'a_fwb_b', ldstop = .FALSE. ) > 0 & ! as read from restart file + & .AND. iom_varid( numror, 'a_fwb', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) 'sbc_fwb : reading freshwater-budget from restart file' + CALL iom_get( numror, 'a_fwb_b', a_fwb_b ) + CALL iom_get( numror, 'a_fwb' , a_fwb ) + ! + a_fwb_ini = a_fwb_b + ELSE ! as specified in namelist + IF(lwp) WRITE(numout,*) 'sbc_fwb : setting freshwater-budget from namelist rn_fwb0' + a_fwb = rn_fwb0 + a_fwb_b = 0._wp ! used only the first year then it is replaced by a_fwb_ini + ! + a_fwb_ini = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) ) & + & * rho0 / ( area * rday * REAL(nyear_len(1), wp) ) + END IF + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'sbc_fwb : freshwater-budget at the end of previous year = ', a_fwb , 'kg/m2/s' + IF(lwp) WRITE(numout,*)' freshwater-budget at initial state = ', a_fwb_ini, 'kg/m2/s' + ! + ELSE + ! at the end of year n: + ikty = nyear_len(1) * 86400 / NINT(rn_Dt) + IF( MOD( kt, ikty ) == 0 ) THEN ! Update a_fwb at the last time step of a year + ! It should be the first time step of a year MOD(kt-1,ikty) but then the restart would be wrong + ! Hence, we make a small error here but the code is restartable + a_fwb_b = a_fwb_ini + ! mean sea level taking into account ice+snow + a_fwb = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) ) + a_fwb = a_fwb * rho0 / ( area * rday * REAL(nyear_len(1), wp) ) ! convert in kg/m2/s + ENDIF + ! + ENDIF + ! + IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! correct the freshwater fluxes using previous year budget minus initial state + zcoef = ( a_fwb - a_fwb_b ) + emp(:,:) = emp(:,:) + zcoef * tmask(:,:,1) + qns(:,:) = qns(:,:) - zcoef * rcp * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction + ! outputs + IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zcoef * rcp * sst_m(:,:) * tmask(:,:,1) ) + IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zcoef * tmask(:,:,1) ) + ENDIF + ! Output restart information + IF( lrst_oce ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_fwb : writing FW-budget adjustment to ocean restart file at it = ', kt + IF(lwp) WRITE(numout,*) '~~~~' + CALL iom_rstput( kt, nitrst, numrow, 'a_fwb_b', a_fwb_b ) + CALL iom_rstput( kt, nitrst, numrow, 'a_fwb', a_fwb ) + END IF + ! + IF( kt == nitend .AND. lwp ) THEN + WRITE(numout,*) 'sbc_fwb : freshwater-budget at the end of simulation (year now) = ', a_fwb , 'kg/m2/s' + WRITE(numout,*) ' freshwater-budget at initial state = ', a_fwb_b, 'kg/m2/s' + ENDIF + ! + CASE ( 3 ) !== global fwf set to zero and spread out over erp area ==! + ! + ALLOCATE( ztmsk_neg(jpi,jpj) , ztmsk_pos(jpi,jpj) , ztmsk_tospread(jpi,jpj) , z_wgt(jpi,jpj) , zerp_cor(jpi,jpj) ) + ! + IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN + ztmsk_pos(:,:) = tmask_i(:,:) ! Select <0 and >0 area of erp + WHERE( erp < 0._wp ) ztmsk_pos = 0._wp + ztmsk_neg(:,:) = tmask_i(:,:) - ztmsk_pos(:,:) + ! ! fwf global mean (excluding ocean to ice/snow exchanges) + z_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) ) / area + ! + IF( z_fwf < 0._wp ) THEN ! spread out over >0 erp area to increase evaporation + zsurf_pos = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_pos(:,:) ) + zsurf_tospread = zsurf_pos + ztmsk_tospread(:,:) = ztmsk_pos(:,:) + ELSE ! spread out over <0 erp area to increase precipitation + zsurf_neg = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_neg(:,:) ) ! Area filled by <0 and >0 erp + zsurf_tospread = zsurf_neg + ztmsk_tospread(:,:) = ztmsk_neg(:,:) + ENDIF + ! + zsum_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * z_fwf ) ! fwf global mean over <0 or >0 erp area +!!gm : zsum_fwf = z_fwf * area ??? it is right? I think so.... + z_fwf_nsrf = zsum_fwf / ( zsurf_tospread + rsmall ) + ! ! weight to respect erp field 2D structure + zsum_erp = glob_sum( 'sbcfwb', ztmsk_tospread(:,:) * erp(:,:) * e1e2t(:,:) ) + z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( zsum_erp + rsmall ) + ! ! final correction term to apply + zerp_cor(:,:) = -1. * z_fwf_nsrf * zsurf_tospread * z_wgt(:,:) + ! +!!gm ===>>>> lbc_lnk should be useless as all the computation is done over the whole domain ! + CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1.0_wp ) + ! + emp(:,:) = emp(:,:) + zerp_cor(:,:) + qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(:,:) ! account for change to the heat budget due to fw correction + erp(:,:) = erp(:,:) + zerp_cor(:,:) + ! outputs + IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zerp_cor(:,:) * rcp * sst_m(:,:) ) + IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zerp_cor(:,:) ) + ! + IF( lwp ) THEN ! control print + IF( z_fwf < 0._wp ) THEN + WRITE(numout,*)' z_fwf < 0' + WRITE(numout,*)' SUM(erp+) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' + ELSE + WRITE(numout,*)' z_fwf >= 0' + WRITE(numout,*)' SUM(erp-) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' + ENDIF + WRITE(numout,*)' SUM(empG) = ', SUM( z_fwf*e1e2t(:,:) )*1.e-9,' Sv' + WRITE(numout,*)' z_fwf = ', z_fwf ,' Kg/m2/s' + WRITE(numout,*)' z_fwf_nsrf = ', z_fwf_nsrf ,' Kg/m2/s' + WRITE(numout,*)' MIN(zerp_cor) = ', MINVAL(zerp_cor) + WRITE(numout,*)' MAX(zerp_cor) = ', MAXVAL(zerp_cor) + ENDIF + ENDIF + DEALLOCATE( ztmsk_neg , ztmsk_pos , ztmsk_tospread , z_wgt , zerp_cor ) + ! + CASE DEFAULT !== you should never be there ==! + CALL ctl_stop( 'sbc_fwb : wrong nn_fwb value for the FreshWater Budget correction, choose either 1, 2 or 3' ) + ! + END SELECT + ! + END SUBROUTINE sbc_fwb + + !!====================================================================== +END MODULE sbcfwb diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcice_cice.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcice_cice.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cb6a2fbadc40989fa7b4d1ff50332fca97a075ca --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcice_cice.f90 @@ -0,0 +1,44 @@ + + + + + + + + + + + + + +MODULE sbcice_cice + !!====================================================================== + !! *** MODULE sbcice_cice *** + !! To couple with sea ice model CICE (LANL) + !!===================================================================== + !!---------------------------------------------------------------------- + !! Default option Dummy module NO CICE sea-ice model + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_ice_cice ( kt, ksbc ) ! Dummy routine + IMPLICIT NONE + INTEGER, INTENT( in ) :: kt, ksbc + WRITE(*,*) 'sbc_ice_cice: You should not have seen this print! error?', kt + END SUBROUTINE sbc_ice_cice + + SUBROUTINE cice_sbc_init (ksbc, Kbb, Kmm) ! Dummy routine + IMPLICIT NONE + INTEGER, INTENT( in ) :: ksbc + INTEGER, INTENT( in ) :: Kbb, Kmm + WRITE(*,*) 'cice_sbc_init: You should not have seen this print! error?', ksbc + END SUBROUTINE cice_sbc_init + + SUBROUTINE cice_sbc_final ! Dummy routine + IMPLICIT NONE + WRITE(*,*) 'cice_sbc_final: You should not have seen this print! error?' + END SUBROUTINE cice_sbc_final + + + !!====================================================================== +END MODULE sbcice_cice diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcice_if.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcice_if.f90 new file mode 100644 index 0000000000000000000000000000000000000000..723b24287d777781783e876ddc9afad35e07c5c0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcice_if.f90 @@ -0,0 +1,160 @@ + + + + + + + + + + + + + +MODULE sbcice_if + !!====================================================================== + !! *** MODULE sbcice *** + !! Surface module : update surface ocean boundary condition over ice + !! covered area using ice-if model + !!====================================================================== + !! History : 3.0 ! 2006-06 (G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_ice_if : update sbc in ice-covered area + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE eosbn2 ! equation of state + USE sbc_oce ! surface boundary condition: ocean fields + USE sbc_ice , ONLY : a_i + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE fldread ! read input field + USE lib_mpp ! MPP library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_ice_if ! routine called in sbcmod + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ice ! structure of input ice-cover (file informations, fields read) + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcice_if.F90 13295 2020-07-10 18:24:21Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_ice_if( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_ice_if *** + !! + !! ** Purpose : handle surface boundary condition over ice cover area + !! when sea-ice model are not used + !! + !! ** Method : - read sea-ice cover climatology + !! - blah blah blah, ... + !! + !! ** Action : utau, vtau : remain unchanged + !! taum, wndm : remain unchanged + !! qns, qsr : update heat flux below sea-ice + !! emp, sfx : update freshwater flux below sea-ice + !! fr_i : update the ice fraction + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ierror ! return error code + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp) :: ztrp, zsice, zt_fzp, zfr_obs + REAL(wp) :: zqri, zqrj, zqrp, zqi + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ice-if files + TYPE(FLD_N) :: sn_ice ! informations about the fields to be read + NAMELIST/namsbc_iif/ cn_dir, sn_ice + !!--------------------------------------------------------------------- + ! ! ====================== ! + IF( kt == nit000 ) THEN ! First call kt=nit000 ! + ! ! ====================== ! + ! set file information + READ ( numnam_ref, namsbc_iif, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iif in reference namelist' ) + + READ ( numnam_cfg, namsbc_iif, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_iif in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_iif ) + + ALLOCATE( sf_ice(1), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_if: unable to allocate sf_ice structure' ) + ALLOCATE( sf_ice(1)%fnow(jpi,jpj,1) ) + IF( sn_ice%ln_tint ) ALLOCATE( sf_ice(1)%fdta(jpi,jpj,1,2) ) + + ! fill sf_ice with sn_ice and control print + CALL fld_fill( sf_ice, (/ sn_ice /), cn_dir, 'sbc_ice_if', 'ice-if sea-ice model', 'namsbc_iif' ) + ! + ENDIF + + CALL fld_read( kt, nn_fsbc, sf_ice ) ! Read input fields and provides the + ! ! input fields at the current time-step + + IF( MOD( kt-1, nn_fsbc) == 0 ) THEN + ! + ztrp = -40. ! restoring terme for temperature (w/m2/k) + zsice = - 0.04 / 0.8 ! ratio of isohaline compressibility over isotherme compressibility + ! ( d rho / dt ) / ( d rho / ds ) ( s = 34, t = -1.8 ) + + CALL eos_fzp( sss_m(:,:), fr_i(:,:) ) ! sea surface freezing temperature [Celsius] + fr_i(:,:) = fr_i(:,:) * tmask(:,:,1) + + IF( ln_cpl ) a_i(:,:,1) = fr_i(:,:) + + ! Flux and ice fraction computation + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ! + zt_fzp = fr_i(ji,jj) ! freezing point temperature + zfr_obs = sf_ice(1)%fnow(ji,jj,1) ! observed ice cover + ! ! ocean ice fraction (0/1) from the freezing point temperature + IF( sst_m(ji,jj) <= zt_fzp ) THEN ; fr_i(ji,jj) = 1.e0 + ELSE ; fr_i(ji,jj) = 0.e0 + ENDIF + + ts(ji,jj,1,jp_tem,Kmm) = MAX( ts(ji,jj,1,jp_tem,Kmm), zt_fzp ) ! avoid over-freezing point temperature + + qsr(ji,jj) = ( 1. - zfr_obs ) * qsr(ji,jj) ! solar heat flux : zero below observed ice cover + + ! ! non solar heat flux : add a damping term + ! # ztrp*(t-(tgel-1.)) if observed ice and no opa ice (zfr_obs=1 fr_i=0) + ! # ztrp*min(0,t-tgel) if observed ice and opa ice (zfr_obs=1 fr_i=1) + zqri = ztrp * ( ts(ji,jj,1,jp_tem,Kbb) - ( zt_fzp - 1.) ) + zqrj = ztrp * MIN( 0., ts(ji,jj,1,jp_tem,Kbb) - zt_fzp ) + zqrp = ( zfr_obs * ( (1. - fr_i(ji,jj) ) * zqri & + & + fr_i(ji,jj) * zqrj ) ) * tmask(ji,jj,1) + + ! ! non-solar heat flux + ! # qns unchanged if no climatological ice (zfr_obs=0) + ! # qns = zqrp if climatological ice and no opa ice (zfr_obs=1, fr_i=0) + ! # qns = zqrp -2(-4) watt/m2 if climatological ice and opa ice (zfr_obs=1, fr_i=1) + ! (-2=arctic, -4=antarctic) + zqi = -3. + SIGN( 1._wp, ff_f(ji,jj) ) + qns(ji,jj) = ( ( 1.- zfr_obs ) * qns(ji,jj) & + & + zfr_obs * fr_i(ji,jj) * zqi ) * tmask(ji,jj,1) & + & + zqrp + END DO ; END DO + ! + ENDIF + ! + END SUBROUTINE sbc_ice_if + + !!====================================================================== +END MODULE sbcice_if diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcmod.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcmod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d6ffa46710f467fc3200d5af88e8c14bc352821c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcmod.f90 @@ -0,0 +1,632 @@ + + + + + + + + + + + + + +MODULE sbcmod + !!====================================================================== + !! *** MODULE sbcmod *** + !! Surface module : provide to the ocean its surface boundary condition + !!====================================================================== + !! History : 3.0 ! 2006-07 (G. Madec) Original code + !! 3.1 ! 2008-08 (S. Masson, A. Caubel, E. Maisonnave, G. Madec) coupled interface + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps + !! 3.3 ! 2010-10 (S. Masson) add diurnal cycle + !! 3.3 ! 2010-09 (D. Storkey) add ice boundary conditions (BDY) + !! - ! 2010-11 (G. Madec) ice-ocean stress always computed at each ocean time-step + !! - ! 2010-10 (J. Chanut, C. Bricaud, G. Madec) add the surface pressure forcing + !! 3.4 ! 2011-11 (C. Harris) CICE added as an option + !! 3.5 ! 2012-11 (A. Coward, G. Madec) Rethink of heat, mass and salt surface fluxes + !! 3.6 ! 2014-11 (P. Mathiot, C. Harris) add ice shelves melting + !! 4.0 ! 2016-06 (L. Brodeau) new general bulk formulation + !! 4.0 ! 2019-03 (F. Lemarié & G. Samson) add ABL compatibility (ln_abl=TRUE) + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) modified wave forcing and coupling + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_init : read namsbc namelist + !! sbc : surface ocean momentum, heat and freshwater boundary conditions + !! sbc_final : Finalize CICE ice model (if used) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE closea ! closed seas + USE phycst ! physical constants + USE sbc_phy, ONLY : pp_cldf + USE sbc_oce ! Surface boundary condition: ocean fields + USE trc_oce ! shared ocean-passive tracers variables + USE sbc_ice ! Surface boundary condition: ice fields + USE sbcdcy ! surface boundary condition: diurnal cycle + USE sbcssm ! surface boundary condition: sea-surface mean variables + USE sbcflx ! surface boundary condition: flux formulation + USE sbcblk ! surface boundary condition: bulk formulation + USE sbcabl ! atmospheric boundary layer + USE sbcice_if ! surface boundary condition: ice-if sea-ice model + USE sbcice_cice ! surface boundary condition: CICE sea-ice model + USE sbccpl ! surface boundary condition: coupled formulation + USE cpl_oasis3 ! OASIS routines for coupling + USE sbcclo ! surface boundary condition: closed sea correction + USE sbcssr ! surface boundary condition: sea surface restoring + USE sbcrnf ! surface boundary condition: runoffs + USE sbcapr ! surface boundary condition: atmo pressure + USE sbcfwb ! surface boundary condition: freshwater budget + USE icbstp ! Icebergs + USE icb_oce , ONLY : ln_passive_mode ! iceberg interaction mode + USE traqsr ! active tracers: light penetration + USE sbcwave ! Wave module + USE bdy_oce , ONLY: ln_bdy + USE usrdef_sbc ! user defined: surface boundary condition + USE closea ! closed sea + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + ! + USE prtctl ! Print control (prt_ctl routine) + USE iom ! IOM library + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + USE wet_dry + USE diu_bulk, ONLY: ln_diurnal_only ! diurnal SST diagnostic + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc ! routine called by step.F90 + PUBLIC sbc_init ! routine called by opa.F90 + + INTEGER :: nsbc ! type of surface boundary condition (deduced from namsbc informations) + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcmod.F90 15372 2021-10-14 15:47:24Z davestorkey $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_init( Kbb, Kmm, Kaa ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_init *** + !! + !! ** Purpose : Initialisation of the ocean surface boundary computation + !! + !! ** Method : Read the namsbc namelist and set derived parameters + !! Call init routines for all other SBC modules that have one + !! + !! ** Action : - read namsbc parameters + !! - nsbc: type of sbc + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + INTEGER :: ios, icpt ! local integer + LOGICAL :: ll_purecpl, ll_opa, ll_not_nemo ! local logical + !! + NAMELIST/namsbc/ nn_fsbc , & + & ln_usr , ln_flx , ln_blk , ln_abl, & + & ln_cpl , ln_mixcpl, nn_components, & + & nn_ice , ln_ice_embd, & + & ln_traqsr, ln_dm2dc , & + & ln_rnf , nn_fwb , ln_ssr , ln_apr_dyn, & + & ln_wave , nn_lsm + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_init : surface boundary condition setting' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF + ! + ! !** read Surface Module namelist + READ ( numnam_ref, namsbc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in reference namelist' ) + READ ( numnam_cfg, namsbc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc in configuration namelist' ) + IF(lwm) WRITE( numond, namsbc ) + ! + ncom_fsbc = nn_fsbc ! make nn_fsbc available for lib_mpp + IF( nn_ice == 2 ) nn_ice = 0 ! without key key_si3 you cannot use si3... + ! + ! + IF(lwp) THEN !* Control print + WRITE(numout,*) ' Namelist namsbc (partly overwritten with CPP key setting)' + WRITE(numout,*) ' frequency update of sbc (and ice) nn_fsbc = ', nn_fsbc + WRITE(numout,*) ' Type of air-sea fluxes : ' + WRITE(numout,*) ' user defined formulation ln_usr = ', ln_usr + WRITE(numout,*) ' flux formulation ln_flx = ', ln_flx + WRITE(numout,*) ' bulk formulation ln_blk = ', ln_blk + WRITE(numout,*) ' ABL formulation ln_abl = ', ln_abl + WRITE(numout,*) ' Surface wave (forced or coupled) ln_wave = ', ln_wave + WRITE(numout,*) ' Type of coupling (Ocean/Ice/Atmosphere) : ' + WRITE(numout,*) ' ocean-atmosphere coupled formulation ln_cpl = ', ln_cpl + WRITE(numout,*) ' mixed forced-coupled formulation ln_mixcpl = ', ln_mixcpl +!!gm lk_oasis is controlled by key_oasis3 ===>>> It shoud be removed from the namelist + WRITE(numout,*) ' OASIS coupling (with atm or sas) lk_oasis = ', lk_oasis + WRITE(numout,*) ' components of your executable nn_components = ', nn_components + WRITE(numout,*) ' Sea-ice : ' + WRITE(numout,*) ' ice management in the sbc (=0/1/2/3) nn_ice = ', nn_ice + WRITE(numout,*) ' ice embedded into ocean ln_ice_embd = ', ln_ice_embd + WRITE(numout,*) ' Misc. options of sbc : ' + WRITE(numout,*) ' Light penetration in temperature Eq. ln_traqsr = ', ln_traqsr + WRITE(numout,*) ' daily mean to diurnal cycle qsr ln_dm2dc = ', ln_dm2dc + WRITE(numout,*) ' Sea Surface Restoring on SST and/or SSS ln_ssr = ', ln_ssr + WRITE(numout,*) ' FreshWater Budget control (=0/1/2) nn_fwb = ', nn_fwb + WRITE(numout,*) ' Patm gradient added in ocean & ice Eqs. ln_apr_dyn = ', ln_apr_dyn + WRITE(numout,*) ' runoff / runoff mouths ln_rnf = ', ln_rnf + WRITE(numout,*) ' nb of iterations if land-sea-mask applied nn_lsm = ', nn_lsm + ENDIF + ! + IF( .NOT.ln_usr ) THEN ! the model calendar needs some specificities (except in user defined case) + IF( MOD( rday , rn_Dt ) /= 0. ) CALL ctl_stop( 'the time step must devide the number of second of in a day' ) + IF( MOD( rday , 2. ) /= 0. ) CALL ctl_stop( 'the number of second of in a day must be an even number' ) + IF( MOD( rn_Dt , 2. ) /= 0. ) CALL ctl_stop( 'the time step (in second) must be an even number' ) + ENDIF + ! !** check option consistency + ! + IF(lwp) WRITE(numout,*) !* Single / Multi - executable (NEMO / OCE+SAS) + SELECT CASE( nn_components ) + CASE( jp_iam_nemo ) + IF(lwp) WRITE(numout,*) ' ==>>> NEMO configured as a single executable (i.e. including both OCE and Surface module)' + CASE( jp_iam_oce ) + IF(lwp) WRITE(numout,*) ' ==>>> Multi executable configuration. Here, OCE component' + IF( .NOT.lk_oasis ) CALL ctl_stop( 'sbc_init : OCE-SAS coupled via OASIS, but key_oasis3 disabled' ) + IF( ln_cpl ) CALL ctl_stop( 'sbc_init : OCE-SAS coupled via OASIS, but ln_cpl = T in OCE' ) + IF( ln_mixcpl ) CALL ctl_stop( 'sbc_init : OCE-SAS coupled via OASIS, but ln_mixcpl = T in OCE' ) + CASE( jp_iam_sas ) + IF(lwp) WRITE(numout,*) ' ==>>> Multi executable configuration. Here, SAS component' + IF( .NOT.lk_oasis ) CALL ctl_stop( 'sbc_init : OCE-SAS coupled via OASIS, but key_oasis3 disabled' ) + IF( ln_mixcpl ) CALL ctl_stop( 'sbc_init : OCE-SAS coupled via OASIS, but ln_mixcpl = T in OCE' ) + CASE DEFAULT + CALL ctl_stop( 'sbc_init : unsupported value for nn_components' ) + END SELECT + ! !* coupled options + IF( ln_cpl ) THEN + IF( .NOT. lk_oasis ) CALL ctl_stop( 'sbc_init : coupled mode with an atmosphere model (ln_cpl=T)', & + & ' required to defined key_oasis3' ) + ENDIF + IF( ln_mixcpl ) THEN + IF( .NOT. lk_oasis ) CALL ctl_stop( 'sbc_init : mixed forced-coupled mode (ln_mixcpl=T) ', & + & ' required to defined key_oasis3' ) + IF( .NOT.ln_cpl ) CALL ctl_stop( 'sbc_init : mixed forced-coupled mode (ln_mixcpl=T) requires ln_cpl = T' ) + IF( nn_components /= jp_iam_nemo ) & + & CALL ctl_stop( 'sbc_init : the mixed forced-coupled mode (ln_mixcpl=T) ', & + & ' not yet working with sas-opa coupling via oasis' ) + ENDIF + ! !* sea-ice + SELECT CASE( nn_ice ) + CASE( 0 ) !- no ice in the domain + CASE( 1 ) !- Ice-cover climatology ("Ice-if" model) + CASE( 2 ) !- SI3 ice model + IF( .NOT.( ln_blk .OR. ln_cpl .OR. ln_abl .OR. ln_usr ) ) & + & CALL ctl_stop( 'sbc_init : SI3 sea-ice model requires ln_blk or ln_cpl or ln_abl or ln_usr = T' ) + CASE( 3 ) !- CICE ice model + IF( .NOT.( ln_blk .OR. ln_cpl .OR. ln_abl .OR. ln_usr ) ) & + & CALL ctl_stop( 'sbc_init : CICE sea-ice model requires ln_blk or ln_cpl or ln_abl or ln_usr = T' ) + IF( lk_agrif ) & + & CALL ctl_stop( 'sbc_init : CICE sea-ice model not currently available with AGRIF' ) + CASE DEFAULT !- not supported + END SELECT + IF( ln_diurnal .AND. .NOT. (ln_blk.OR.ln_abl) ) CALL ctl_stop( "sbc_init: diurnal flux processing only implemented for bulk forcing" ) + ! + ! !** allocate and set required variables + ! + ! !* allocate sbc arrays + IF( sbc_oce_alloc() /= 0 ) CALL ctl_stop( 'sbc_init : unable to allocate sbc_oce arrays' ) + IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop( 'sbc_init : unable to allocate sbc_ice arrays' ) + ! + ! + IF( sbc_ssr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_ssr arrays' ) + IF( .NOT.ln_ssr ) THEN !* Initialize qrp and erp if no restoring + qrp(:,:) = 0._wp + erp(:,:) = 0._wp + ENDIF + ! + IF( nn_ice == 0 ) THEN !* No sea-ice in the domain : ice fraction is always zero + IF( nn_components /= jp_iam_oce ) fr_i(:,:) = 0._wp ! except for OCE in SAS-OCE coupled case + ENDIF + ! + sfx (:,:) = 0._wp !* salt flux due to freezing/melting + fmmflx(:,:) = 0._wp !* freezing minus melting flux + cloud_fra(:,:) = pp_cldf !* cloud fraction over sea ice (used in si3) + + taum(:,:) = 0._wp !* wind stress module (needed in GLS in case of reduced restart) + + ! ! Choice of the Surface Boudary Condition (set nsbc) + nday_qsr = -1 ! allow initialization at the 1st call !LB: now warm-layer of COARE* calls "sbc_dcy_param" of sbcdcy.F90! + IF( ln_dm2dc ) THEN !* daily mean to diurnal cycle + !LB:nday_qsr = -1 ! allow initialization at the 1st call + IF( .NOT.( ln_flx .OR. ln_blk .OR. ln_abl ) .AND. nn_components /= jp_iam_oce ) & + & CALL ctl_stop( 'qsr diurnal cycle from daily values requires flux, bulk or abl formulation' ) + ENDIF + ! !* Choice of the Surface Boudary Condition + ! (set nsbc) + ! + ll_purecpl = ln_cpl .AND. .NOT.ln_mixcpl + ll_opa = nn_components == jp_iam_oce + ll_not_nemo = nn_components /= jp_iam_nemo + icpt = 0 + ! + IF( ln_usr ) THEN ; nsbc = jp_usr ; icpt = icpt + 1 ; ENDIF ! user defined formulation + IF( ln_flx ) THEN ; nsbc = jp_flx ; icpt = icpt + 1 ; ENDIF ! flux formulation + IF( ln_blk ) THEN ; nsbc = jp_blk ; icpt = icpt + 1 ; ENDIF ! bulk formulation + IF( ln_abl ) THEN ; nsbc = jp_abl ; icpt = icpt + 1 ; ENDIF ! ABL formulation + IF( ll_purecpl ) THEN ; nsbc = jp_purecpl ; icpt = icpt + 1 ; ENDIF ! Pure Coupled formulation + IF( ll_opa ) THEN ; nsbc = jp_none ; icpt = icpt + 1 ; ENDIF ! opa coupling via SAS module + ! + IF( icpt /= 1 ) CALL ctl_stop( 'sbc_init : choose ONE and only ONE sbc option' ) + ! + IF(lwp) THEN !- print the choice of surface flux formulation + WRITE(numout,*) + SELECT CASE( nsbc ) + CASE( jp_usr ) ; WRITE(numout,*) ' ==>>> user defined forcing formulation' + CASE( jp_flx ) ; WRITE(numout,*) ' ==>>> flux formulation' + CASE( jp_blk ) ; WRITE(numout,*) ' ==>>> bulk formulation' + CASE( jp_abl ) ; WRITE(numout,*) ' ==>>> ABL formulation' + CASE( jp_purecpl ) ; WRITE(numout,*) ' ==>>> pure coupled formulation' +!!gm abusive use of jp_none ?? ===>>> need to be check and changed by adding a jp_sas parameter + CASE( jp_none ) ; WRITE(numout,*) ' ==>>> OCE coupled to SAS via oasis' + IF( ln_mixcpl ) WRITE(numout,*) ' + forced-coupled mixed formulation' + END SELECT + IF( ll_not_nemo ) WRITE(numout,*) ' + OASIS coupled SAS' + ENDIF + ! + ! !* OASIS initialization + ! + IF( lk_oasis ) CALL sbc_cpl_init( nn_ice ) ! Must be done before: (1) first time step + ! ! (2) the use of nn_fsbc + ! nn_fsbc initialization if OCE-SAS coupling via OASIS + ! SAS time-step has to be declared in OASIS (mandatory) -> nn_fsbc has to be modified accordingly + IF( nn_components /= jp_iam_nemo ) THEN + IF( nn_components == jp_iam_oce ) nn_fsbc = cpl_freq('O_SFLX') / NINT(rn_Dt) + IF( nn_components == jp_iam_sas ) nn_fsbc = cpl_freq('I_SFLX') / NINT(rn_Dt) + ! + IF(lwp)THEN + WRITE(numout,*) + WRITE(numout,*)" OCE-SAS coupled via OASIS : nn_fsbc re-defined from OASIS namcouple ", nn_fsbc + WRITE(numout,*) + ENDIF + ENDIF + ! + ! !* check consistency between model timeline and nn_fsbc + IF( ln_rst_list .OR. nn_stock /= -1 ) THEN ! we will do restart files + IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 ) THEN + WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' + CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) + ENDIF + IF( .NOT. ln_rst_list .AND. MOD( nn_stock, nn_fsbc) /= 0 ) THEN ! we don't use nn_stock if ln_rst_list + WRITE(ctmp1,*) 'sbc_init : nn_stock (', nn_stock, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' + CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) + ENDIF + ENDIF + ! + IF( MOD( rday, REAL(nn_fsbc, wp) * rn_Dt ) /= 0 ) & + & CALL ctl_warn( 'sbc_init : nn_fsbc is NOT a multiple of the number of time steps in a day' ) + ! + IF( ln_dm2dc .AND. NINT(rday) / ( nn_fsbc * NINT(rn_Dt) ) < 8 ) & + & CALL ctl_warn( 'sbc_init : diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' ) + ! + + ! !** associated modules : initialization + ! + CALL sbc_ssm_init ( Kbb, Kmm ) ! Sea-surface mean fields initialization + ! + IF( l_sbc_clo ) CALL sbc_clo_init ! closed sea surface initialisation + ! + IF( ln_blk ) CALL sbc_blk_init ! bulk formulae initialization + + IF( ln_abl ) CALL sbc_abl_init ! Atmospheric Boundary Layer (ABL) + + IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialization + ! + ! + CALL sbc_rnf_init( Kmm ) ! Runof initialization + ! + IF( ln_apr_dyn ) CALL sbc_apr_init ! Atmo Pressure Forcing initialization + ! + IF( nn_ice == 3 ) CALL cice_sbc_init( nsbc, Kbb, Kmm ) ! CICE initialization + ! + IF( ln_wave ) THEN + CALL sbc_wave_init ! surface wave initialisation + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' No surface waves : all wave related logical set to false' + ln_sdw = .false. + ln_stcor = .false. + ln_cdgw = .false. + ln_tauoc = .false. + ln_wave_test = .false. + ln_charn = .false. + ln_taw = .false. + ln_phioc = .false. + ln_bern_srfc = .false. + ln_breivikFV_2016 = .false. + ln_vortex_force = .false. + ln_stshear = .false. + ENDIF + ! + END SUBROUTINE sbc_init + + + SUBROUTINE sbc( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc *** + !! + !! ** Purpose : provide at each time-step the ocean surface boundary + !! condition (momentum, heat and freshwater fluxes) + !! + !! ** Method : blah blah to be written ????????? + !! CAUTION : never mask the surface stress field (tke sbc) + !! + !! ** Action : - set the ocean surface boundary condition at before and now + !! time step, i.e. + !! utau_b, vtau_b, qns_b, qsr_b, emp_n, sfx_b, qrp_b, erp_b + !! utau , vtau , qns , qsr , emp , sfx , qrp , erp + !! - updte the ice fraction : fr_i + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + INTEGER :: jj, ji ! dummy loop argument + ! + LOGICAL :: ll_sas, ll_opa ! local logical + ! + REAL(wp) :: zthscl ! wd tanh scale + REAL(wp), DIMENSION(jpi,jpj) :: zwdht, zwght ! wd dep over wd limit, wgt + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! temporary array used for iom_put + + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('sbc') + ! + ! ! ---------------------------------------- ! + IF( kt /= nit000 ) THEN ! Swap of forcing fields ! + ! ! ---------------------------------------- ! + utau_b(:,:) = utau(:,:) ! Swap the ocean forcing fields + vtau_b(:,:) = vtau(:,:) ! (except at nit000 where before fields + qns_b (:,:) = qns (:,:) ! are set at the end of the routine) + emp_b (:,:) = emp (:,:) + sfx_b (:,:) = sfx (:,:) + IF( ln_rnf ) THEN + rnf_b (:,: ) = rnf (:,: ) + rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) + ENDIF + ! + ENDIF + ! ! ---------------------------------------- ! + ! ! forcing field computation ! + ! ! ---------------------------------------- ! + ! + ll_sas = nn_components == jp_iam_sas ! component flags + ll_opa = nn_components == jp_iam_oce + ! + IF( .NOT.ll_sas ) CALL sbc_ssm ( kt, Kbb, Kmm ) ! mean ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m) + ! + ! !== sbc formulation ==! + ! + ! + SELECT CASE( nsbc ) ! Compute ocean surface boundary condition + ! ! (i.e. utau,vtau, qns, qsr, emp, sfx) + CASE( jp_usr ) ; CALL usrdef_sbc_oce( kt, Kbb ) ! user defined formulation + CASE( jp_flx ) ; CALL sbc_flx ( kt ) ! flux formulation + CASE( jp_blk ) + IF( ll_sas ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OCE-SAS coupling: SAS receiving fields from OCE +!!!!!!!!!!! ATTENTION:ln_wave is not only used for oasis coupling !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF( ln_wave ) THEN + IF ( lk_oasis ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OCE-wave coupling + CALL sbc_wave ( kt, Kmm ) + ENDIF + CALL sbc_blk ( kt ) ! bulk formulation for the ocean + ! + CASE( jp_abl ) + IF( ll_sas ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OCE-SAS coupling: SAS receiving fields from OCE + CALL sbc_abl ( kt ) ! ABL formulation for the ocean + ! + CASE( jp_purecpl ) ; CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! pure coupled formulation + CASE( jp_none ) + IF( ll_opa ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OCE-SAS coupling: OCE receiving fields from SAS + END SELECT + ! + IF( ln_mixcpl ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! forced-coupled mixed formulation after forcing + ! + IF( ln_wave .AND. ln_tauoc ) THEN ! Wave stress reduction + DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + utau(ji,jj) = utau(ji,jj) * ( tauoc_wave(ji,jj) + tauoc_wave(ji-1,jj) ) * 0.5_wp + vtau(ji,jj) = vtau(ji,jj) * ( tauoc_wave(ji,jj) + tauoc_wave(ji,jj-1) ) * 0.5_wp + END DO ; END DO + ! + CALL lbc_lnk( 'sbcwave', utau, 'U', -1._wp ) + CALL lbc_lnk( 'sbcwave', vtau, 'V', -1._wp ) + ! + taum(:,:) = taum(:,:)*tauoc_wave(:,:) + ! + IF( kt == nit000 ) CALL ctl_warn( 'sbc: You are subtracting the wave stress to the ocean.', & + & 'If not requested select ln_tauoc=.false.' ) + ! + ELSEIF( ln_wave .AND. ln_taw ) THEN ! Wave stress reduction + utau(:,:) = utau(:,:) - tawx(:,:) + twox(:,:) + vtau(:,:) = vtau(:,:) - tawy(:,:) + twoy(:,:) + CALL lbc_lnk( 'sbcwave', utau, 'U', -1._wp ) + CALL lbc_lnk( 'sbcwave', vtau, 'V', -1._wp ) + ! + DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + taum(ji,jj) = sqrt((.5*(utau(ji-1,jj)+utau(ji,jj)))**2 + (.5*(vtau(ji,jj-1)+vtau(ji,jj)))**2) + END DO ; END DO + ! + IF( kt == nit000 ) CALL ctl_warn( 'sbc: You are subtracting the wave stress to the ocean.', & + & 'If not requested select ln_taw=.false.' ) + ! + ENDIF + CALL lbc_lnk( 'sbcmod', taum(:,:), 'T', 1._wp ) + ! + IF( ln_icebergs ) THEN ! save pure stresses (with no ice-ocean stress) for use by icebergs + utau_icb(:,:) = utau(:,:) ; vtau_icb(:,:) = vtau(:,:) + ENDIF + ! + ! !== Misc. Options ==! + ! + SELECT CASE( nn_ice ) ! Update heat and freshwater fluxes over sea-ice areas + CASE( 1 ) ; CALL sbc_ice_if ( kt, Kbb, Kmm ) ! Ice-cover climatology ("Ice-if" model) + CASE( 3 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model + END SELECT + + IF( ln_icebergs ) CALL icb_stp( kt, Kmm ) ! compute icebergs + + ! Icebergs do not melt over the haloes. + ! So emp values over the haloes are no more consistent with the inner domain values. + ! A lbc_lnk is therefore needed to ensure reproducibility and restartability. + ! see ticket #2113 for discussion about this lbc_lnk. + ! The lbc_lnk is also needed for SI3 with nn_hls > 1 as emp is not yet defined for these points in iceupdate.F90 + IF( (ln_icebergs .AND. .NOT. ln_passive_mode) .OR. (nn_ice == 2 .AND. nn_hls == 2) ) THEN + CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp ) + ENDIF + + IF( ln_rnf ) CALL sbc_rnf( kt ) ! add runoffs to fresh water fluxes + + IF( ln_ssr ) CALL sbc_ssr( kt ) ! add SST/SSS damping term + + IF( nn_fwb /= 0 ) CALL sbc_fwb( kt, nn_fwb, nn_fsbc, Kmm ) ! control the freshwater budget + + ! Special treatment of freshwater fluxes over closed seas in the model domain + ! Should not be run if ln_diurnal_only + IF( l_sbc_clo ) CALL sbc_clo( kt ) + +!!$!RBbug do not understand why see ticket 667 +!!$!clem: it looks like it is necessary for the north fold (in certain circumstances). Don't know why. +!!$ CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp ) + IF( ll_wd ) THEN ! If near WAD point limit the flux for now + zthscl = atanh(rn_wd_sbcfra) ! taper frac default is .999 + zwdht(:,:) = ssh(:,:,Kmm) + ht_0(:,:) - rn_wdmin1 ! do this calc of water + ! depth above wd limit once + WHERE( zwdht(:,:) <= 0.0 ) + taum(:,:) = 0.0 + utau(:,:) = 0.0 + vtau(:,:) = 0.0 + qns (:,:) = 0.0 + qsr (:,:) = 0.0 + emp (:,:) = min(emp(:,:),0.0) !can allow puddles to grow but not shrink + sfx (:,:) = 0.0 + END WHERE + zwght(:,:) = tanh(zthscl*zwdht(:,:)) + WHERE( zwdht(:,:) > 0.0 .and. zwdht(:,:) < rn_wd_sbcdep ) ! 5 m hard limit here is arbitrary + qsr (:,:) = qsr(:,:) * zwght(:,:) + qns (:,:) = qns(:,:) * zwght(:,:) + taum (:,:) = taum(:,:) * zwght(:,:) + utau (:,:) = utau(:,:) * zwght(:,:) + vtau (:,:) = vtau(:,:) * zwght(:,:) + sfx (:,:) = sfx(:,:) * zwght(:,:) + emp (:,:) = emp(:,:) * zwght(:,:) + END WHERE + ENDIF + ! + IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! + ! ! ---------------------------------------- ! + IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN !* Restart: read in restart file + IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields read in the restart file' + CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b ) ! i-stress + CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b ) ! j-stress + CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b ) ! non solar heat flux + CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b ) ! freshwater flux + ! NB: The 3D heat content due to qsr forcing (qsr_hc_b) is treated in traqsr + ! To ensure restart capability with 3.3x/3.4 restart files !! to be removed in v3.6 + IF( iom_varid( numror, 'sfx_b', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b ) ! before salt flux (T-point) + ELSE + sfx_b (:,:) = sfx(:,:) + ENDIF + ELSE !* no restart: set from nit000 values + IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields set to nit000' + utau_b(:,:) = utau(:,:) + vtau_b(:,:) = vtau(:,:) + qns_b (:,:) = qns (:,:) + emp_b (:,:) = emp (:,:) + sfx_b (:,:) = sfx (:,:) + ENDIF + ENDIF + ! ! ---------------------------------------- ! + IF( lrst_oce ) THEN ! Write in the ocean restart file ! + ! ! ---------------------------------------- ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc : ocean surface forcing fields written in ocean restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau ) + CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau ) + CALL iom_rstput( kt, nitrst, numrow, 'qns_b' , qns ) + ! The 3D heat content due to qsr forcing is treated in traqsr + ! CALL iom_rstput( kt, nitrst, numrow, 'qsr_b' , qsr ) + CALL iom_rstput( kt, nitrst, numrow, 'emp_b' , emp ) + CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx ) + ENDIF + ! ! ---------------------------------------- ! + ! ! Outputs and control print ! + ! ! ---------------------------------------- ! + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN + IF( iom_use("empmr") ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj) + END DO ; END DO + CALL iom_put( "empmr" , z2d ) ! upward water flux + ENDIF + IF( iom_use("empbmr") ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = emp_b(ji,jj) - rnf(ji,jj) + END DO ; END DO + CALL iom_put( "empbmr" , z2d ) ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) + ENDIF + CALL iom_put( "saltflx", sfx ) ! downward salt flux (includes virtual salt flux beneath ice in linear free surface case) + CALL iom_put( "fmmflx" , fmmflx ) ! Freezing-melting water flux + IF( iom_use("qt") ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + z2d(ji,jj) = qns(ji,jj) + qsr(ji,jj) + END DO ; END DO + CALL iom_put( "qt" , z2d ) ! total heat flux + ENDIF + CALL iom_put( "qns" , qns ) ! solar heat flux + CALL iom_put( "qsr" , qsr ) ! solar heat flux + IF( nn_ice > 0 .OR. ll_opa ) CALL iom_put( "ice_cover", fr_i ) ! ice fraction + CALL iom_put( "taum" , taum ) ! wind stress module + CALL iom_put( "wspd" , wndm ) ! wind speed module over free ocean or leads in presence of sea-ice + CALL iom_put( "qrp" , qrp ) ! heat flux damping + CALL iom_put( "erp" , erp ) ! freshwater flux damping + ENDIF + ! + ! IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging) + !CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask ) + !CALL prt_ctl(tab2d_1=(emp-rnf) , clinfo1=' emp-rnf - : ', mask1=tmask ) + !CALL prt_ctl(tab2d_1=(sfx-rnf) , clinfo1=' sfx-rnf - : ', mask1=tmask ) + !CALL prt_ctl(tab2d_1=qns , clinfo1=' qns - : ', mask1=tmask ) + !CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask ) + !CALL prt_ctl(tab3d_1=tmask , clinfo1=' tmask - : ', mask1=tmask, kdim=jpk ) + !CALL prt_ctl(tab3d_1=ts(:,:,:,jp_tem,Kmm), clinfo1=' sst - : ', mask1=tmask, kdim=1 ) + !CALL prt_ctl(tab3d_1=ts(:,:,:,jp_sal,Kmm), clinfo1=' sss - : ', mask1=tmask, kdim=1 ) + !CALL prt_ctl(tab2d_1=utau , clinfo1=' utau - : ', mask1=umask, & + ! & tab2d_2=vtau , clinfo2=' vtau - : ', mask2=vmask ) + ! ENDIF + + IF( kt == nitend ) CALL sbc_final ! Close down surface module if necessary + ! + IF( ln_timing ) CALL timing_stop('sbc') + ! + END SUBROUTINE sbc + + + SUBROUTINE sbc_final + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_final *** + !! + !! ** Purpose : Finalize CICE (if used) + !!--------------------------------------------------------------------- + ! + IF( nn_ice == 3 ) CALL cice_sbc_final + ! + END SUBROUTINE sbc_final + + !!====================================================================== +END MODULE sbcmod diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcrnf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcrnf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e1bfb1246a1af4b9a32d3b3943b18da13841753f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcrnf.f90 @@ -0,0 +1,570 @@ + + + + + + + + + + + + + +MODULE sbcrnf + !!====================================================================== + !! *** MODULE sbcrnf *** + !! Ocean forcing: river runoff + !!===================================================================== + !! History : OPA ! 2000-11 (R. Hordoir, E. Durand) NetCDF FORMAT + !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module + !! 3.0 ! 2006-07 (G. Madec) Surface module + !! 3.2 ! 2009-04 (B. Lemaire) Introduce iom_put + !! 3.3 ! 2010-10 (R. Furner, G. Madec) runoff distributed over ocean levels + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_rnf : monthly runoffs read in a NetCDF file + !! sbc_rnf_init : runoffs initialisation + !! rnf_mouth : set river mouth mask + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce ! surface boundary condition variables + USE eosbn2 ! Equation Of State + USE closea, ONLY: l_clo_rnf, clo_rnf ! closed seas + ! + USE in_out_manager ! I/O manager + USE fldread ! read input field at current time step + USE iom ! I/O module + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_rnf ! called in sbcmod module + PUBLIC sbc_rnf_div ! called in divhor module + PUBLIC sbc_rnf_alloc ! called in sbcmod module + PUBLIC sbc_rnf_init ! called in sbcmod module + + ! !!* namsbc_rnf namelist * + CHARACTER(len=100) :: cn_dir !: Root directory for location of rnf files + LOGICAL , PUBLIC :: ln_rnf_depth !: depth river runoffs attribute specified in a file + LOGICAL :: ln_rnf_depth_ini !: depth river runoffs computed at the initialisation + REAL(wp) :: rn_rnf_max !: maximum value of the runoff climatologie (ln_rnf_depth_ini =T) + REAL(wp) :: rn_dep_max !: depth over which runoffs is spread (ln_rnf_depth_ini =T) + INTEGER :: nn_rnf_depth_file !: create (=1) a runoff depth file or not (=0) + LOGICAL , PUBLIC :: ln_rnf_icb !: iceberg flux is specified in a file + LOGICAL :: ln_rnf_tem !: temperature river runoffs attribute specified in a file + LOGICAL , PUBLIC :: ln_rnf_sal !: salinity river runoffs attribute specified in a file + TYPE(FLD_N) , PUBLIC :: sn_rnf !: information about the runoff file to be read + TYPE(FLD_N) :: sn_cnf !: information about the runoff mouth file to be read + TYPE(FLD_N) :: sn_i_rnf !: information about the iceberg flux file to be read + TYPE(FLD_N) :: sn_s_rnf !: information about the salinities of runoff file to be read + TYPE(FLD_N) :: sn_t_rnf !: information about the temperatures of runoff file to be read + TYPE(FLD_N) :: sn_dep_rnf !: information about the depth which river inflow affects + LOGICAL , PUBLIC :: ln_rnf_mouth !: specific treatment in mouths vicinity + REAL(wp) :: rn_hrnf !: runoffs, depth over which enhanced vertical mixing is used + REAL(wp) , PUBLIC :: rn_avt_rnf !: runoffs, value of the additional vertical mixing coef. [m2/s] + REAL(wp) , PUBLIC :: rn_rfact !: multiplicative factor for runoff + + LOGICAL , PUBLIC :: l_rnfcpl = .false. !: runoffs recieved from oasis + INTEGER , PUBLIC :: nkrnf = 0 !: nb of levels over which Kz is increased at river mouths + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnfmsk !: river mouth mask (hori.) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rnfmsk_z !: river mouth mask (vert.) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_rnf !: depth of runoff in m + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nk_rnf !: depth of runoff in model levels + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rnf_tsc_b, rnf_tsc !: before and now T & S runoff contents [K.m/s & PSU.m/s] + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rnf ! structure: river runoff (file information, fields read) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_i_rnf ! structure: iceberg flux (file information, fields read) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_s_rnf ! structure: river runoff salinity (file information, fields read) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_t_rnf ! structure: river runoff temperature (file information, fields read) + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcrnf.F90 15190 2021-08-13 12:52:50Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_rnf_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_rnf_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( rnfmsk(jpi,jpj) , rnfmsk_z(jpk) , & + & h_rnf (jpi,jpj) , nk_rnf (jpi,jpj) , & + & rnf_tsc_b(jpi,jpj,jpts) , rnf_tsc (jpi,jpj,jpts) , STAT=sbc_rnf_alloc ) + ! + CALL mpp_sum ( 'sbcrnf', sbc_rnf_alloc ) + IF( sbc_rnf_alloc > 0 ) CALL ctl_warn('sbc_rnf_alloc: allocation of arrays failed') + END FUNCTION sbc_rnf_alloc + + + SUBROUTINE sbc_rnf( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_rnf *** + !! + !! ** Purpose : Introduce a climatological run off forcing + !! + !! ** Method : Set each river mouth with a monthly climatology + !! provided from different data. + !! CAUTION : upward water flux, runoff forced to be < 0 + !! + !! ** Action : runoff updated runoff field at time-step kt + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: z_err = 0 ! dummy integer for error handling + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point used for temperature correction + ! + ! + ! !-------------------! + ! ! Update runoff ! + ! !-------------------! + ! + ! + IF( .NOT. l_rnfcpl ) THEN + CALL fld_read ( kt, nn_fsbc, sf_rnf ) ! Read Runoffs data and provide it at kt ( runoffs + iceberg ) + IF( ln_rnf_icb ) CALL fld_read ( kt, nn_fsbc, sf_i_rnf ) ! idem for iceberg flux if required + ENDIF + IF( ln_rnf_tem ) CALL fld_read ( kt, nn_fsbc, sf_t_rnf ) ! idem for runoffs temperature if required + IF( ln_rnf_sal ) CALL fld_read ( kt, nn_fsbc, sf_s_rnf ) ! idem for runoffs salinity if required + ! + IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN + ! + IF( .NOT. l_rnfcpl ) THEN + rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt + IF( ln_rnf_icb ) THEN + fwficb(:,:) = rn_rfact * ( sf_i_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt + rnf(:,:) = rnf(:,:) + fwficb(:,:) + qns(:,:) = qns(:,:) - fwficb(:,:) * rLfus + !!qns_tot(:,:) = qns_tot(:,:) - fwficb(:,:) * rLfus + !!qns_oce(:,:) = qns_oce(:,:) - fwficb(:,:) * rLfus + CALL iom_put( 'iceberg_cea' , fwficb(:,:) ) ! output iceberg flux + CALL iom_put( 'hflx_icb_cea' , -fwficb(:,:) * rLfus ) ! output Heat Flux into Sea Water due to Iceberg Thermodynamics --> + ENDIF + ENDIF + ! + ! ! set temperature & salinity content of runoffs + IF( ln_rnf_tem ) THEN ! use runoffs temperature data + rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rho0 + CALL eos_fzp( sss_m(:,:), ztfrz(:,:) ) + WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp ) ! if missing data value use SST as runoffs temperature + rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rho0 + END WHERE + ELSE ! use SST as runoffs temperature + !CEOD River is fresh water so must at least be 0 unless we consider ice + rnf_tsc(:,:,jp_tem) = MAX( sst_m(:,:), 0.0_wp ) * rnf(:,:) * r1_rho0 + ENDIF + ! ! use runoffs salinity data + IF( ln_rnf_sal ) rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rho0 + ! ! else use S=0 for runoffs (done one for all in the init) + CALL iom_put( 'runoffs' , rnf(:,:) ) ! output runoff mass flux + IF( iom_use('hflx_rnf_cea') ) CALL iom_put( 'hflx_rnf_cea', rnf_tsc(:,:,jp_tem) * rho0 * rcp ) ! output runoff sensible heat (W/m2) + IF( iom_use('sflx_rnf_cea') ) CALL iom_put( 'sflx_rnf_cea', rnf_tsc(:,:,jp_sal) * rho0 ) ! output runoff salt flux (g/m2/s) + ENDIF + ! + ! ! ---------------------------------------- ! + IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! + ! ! ---------------------------------------- ! + IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN !* Restart: read in restart file + IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields red in the restart file', lrxios + CALL iom_get( numror, jpdom_auto, 'rnf_b' , rnf_b ) ! before runoff + CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem) ) ! before heat content of runoff + CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) ) ! before salinity content of runoff + ELSE !* no restart: set from nit000 values + IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000' + rnf_b (:,: ) = rnf (:,: ) + rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) + ENDIF + ENDIF + ! ! ---------------------------------------- ! + IF( lrst_oce ) THEN ! Write in the ocean restart file ! + ! ! ---------------------------------------- ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbcrnf : runoff forcing fields written in ocean restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf ) + CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem) ) + CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) + ENDIF + ! + END SUBROUTINE sbc_rnf + + + SUBROUTINE sbc_rnf_div( phdivn, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_rnf *** + !! + !! ** Purpose : update the horizontal divergence with the runoff inflow + !! + !! ** Method : + !! CAUTION : rnf is positive (inflow) decreasing the + !! divergence and expressed in m/s + !! + !! ** Action : phdivn decreased by the runoff inflow + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zfact ! local scalar + !!---------------------------------------------------------------------- + ! + zfact = 0.5_wp + ! + IF( ln_rnf_depth .OR. ln_rnf_depth_ini ) THEN !== runoff distributed over several levels ==! + IF( ln_linssh ) THEN !* constant volume case : just apply the runoff input flow + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls-1)*nthr) + DO jk = 1, nk_rnf(ji,jj) + phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rho0 / h_rnf(ji,jj) + END DO + END DO ; END DO + ELSE !* variable volume case + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) ! update the depth over which runoffs are distributed + h_rnf(ji,jj) = 0._wp + DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres + h_rnf(ji,jj) = h_rnf(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) ! to the bottom of the relevant grid box + END DO + END DO ; END DO + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls-1)*nthr) ! apply the runoff input flow + DO jk = 1, nk_rnf(ji,jj) + phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rho0 / h_rnf(ji,jj) + END DO + END DO ; END DO + ENDIF + ELSE !== runoff put only at the surface ==! + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + h_rnf (ji,jj) = (e3t_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,1))) ! update h_rnf to be depth of top box + END DO ; END DO + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls-1)*nthr) + phdivn(ji,jj,1) = phdivn(ji,jj,1) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rho0 / (e3t_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,1))) + END DO ; END DO + ENDIF + ! + END SUBROUTINE sbc_rnf_div + + + SUBROUTINE sbc_rnf_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_rnf_init *** + !! + !! ** Purpose : Initialisation of the runoffs if (ln_rnf=T) + !! + !! ** Method : - read the runoff namsbc_rnf namelist + !! + !! ** Action : - read parameters + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + CHARACTER(len=32) :: rn_dep_file ! runoff file name + INTEGER :: ji, jj, jk, jm ! dummy loop indices + INTEGER :: ierror, inum ! temporary integer + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: nbrec ! temporary integer + REAL(wp) :: zacoef + REAL(wp), DIMENSION(jpi,jpj,2) :: zrnfcl + !! + NAMELIST/namsbc_rnf/ cn_dir , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal, ln_rnf_icb, & + & sn_rnf, sn_cnf , sn_i_rnf, sn_s_rnf , sn_t_rnf , sn_dep_rnf, & + & ln_rnf_mouth , rn_hrnf , rn_avt_rnf, rn_rfact, & + & ln_rnf_depth_ini , rn_dep_max , rn_rnf_max, nn_rnf_depth_file + !!---------------------------------------------------------------------- + ! + ! !== allocate runoff arrays + IF( sbc_rnf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) + ! + IF( .NOT. ln_rnf ) THEN ! no specific treatment in vicinity of river mouths + ln_rnf_mouth = .FALSE. ! default definition needed for example by sbc_ssr or by tra_adv_muscl + nkrnf = 0 + rnf (:,:) = 0.0_wp + rnf_b (:,:) = 0.0_wp + rnfmsk (:,:) = 0.0_wp + rnfmsk_z(:) = 0.0_wp + RETURN + ENDIF + ! + ! ! ============ + ! ! Namelist + ! ! ============ + ! + READ ( numnam_ref, namsbc_rnf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist' ) + + READ ( numnam_cfg, namsbc_rnf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_rnf ) + ! + ! ! Control print + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_rnf_init : runoff ' + WRITE(numout,*) '~~~~~~~~~~~~ ' + WRITE(numout,*) ' Namelist namsbc_rnf' + WRITE(numout,*) ' specific river mouths treatment ln_rnf_mouth = ', ln_rnf_mouth + WRITE(numout,*) ' river mouth additional Kz rn_avt_rnf = ', rn_avt_rnf + WRITE(numout,*) ' depth of river mouth additional mixing rn_hrnf = ', rn_hrnf + WRITE(numout,*) ' multiplicative factor for runoff rn_rfact = ', rn_rfact + ENDIF + ! ! ================== + ! ! Type of runoff + ! ! ================== + ! + IF( .NOT. l_rnfcpl ) THEN + ALLOCATE( sf_rnf(1), STAT=ierror ) ! Create sf_rnf structure (runoff inflow) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> runoffs inflow read in a file' + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_rnf structure' ) ; RETURN + ENDIF + ALLOCATE( sf_rnf(1)%fnow(jpi,jpj,1) ) + IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_rnf, (/ sn_rnf /), cn_dir, 'sbc_rnf_init', 'read runoffs data', 'namsbc_rnf', no_print ) + ! + IF( ln_rnf_icb ) THEN ! Create (if required) sf_i_rnf structure + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' iceberg flux read in a file' + ALLOCATE( sf_i_rnf(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_i_rnf structure' ) ; RETURN + ENDIF + ALLOCATE( sf_i_rnf(1)%fnow(jpi,jpj,1) ) + IF( sn_i_rnf%ln_tint ) ALLOCATE( sf_i_rnf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill (sf_i_rnf, (/ sn_i_rnf /), cn_dir, 'sbc_rnf_init', 'read iceberg flux data', 'namsbc_rnf' ) + ELSE + fwficb(:,:) = 0._wp + ENDIF + + ENDIF + ! + IF( ln_rnf_tem ) THEN ! Create (if required) sf_t_rnf structure + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> runoffs temperatures read in a file' + ALLOCATE( sf_t_rnf(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' ) ; RETURN + ENDIF + ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1) ) + IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf', no_print ) + ENDIF + ! + IF( ln_rnf_sal ) THEN ! Create (if required) sf_s_rnf and sf_t_rnf structures + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> runoffs salinities read in a file' + ALLOCATE( sf_s_rnf(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' ) ; RETURN + ENDIF + ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1) ) + IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf', no_print ) + ENDIF + ! + IF( ln_rnf_depth ) THEN ! depth of runoffs set from a file + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> runoffs depth read in a file' + rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) + IF( .NOT. sn_dep_rnf%ln_clim ) THEN ; WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear ! add year + IF( sn_dep_rnf%clftyp == 'monthly' ) WRITE(rn_dep_file, '(a,"m",i2)' ) TRIM( rn_dep_file ), nmonth ! add month + ENDIF + CALL iom_open ( rn_dep_file, inum ) ! open file + CALL iom_get ( inum, jpdom_global, sn_dep_rnf%clvar, h_rnf ) ! read the river mouth array + CALL iom_close( inum ) ! close file + ! + nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + IF( h_rnf(ji,jj) > 0._wp ) THEN + jk = 2 + DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 + END DO + nk_rnf(ji,jj) = jk + ELSEIF( h_rnf(ji,jj) == -1._wp ) THEN ; nk_rnf(ji,jj) = 1 + ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN ; nk_rnf(ji,jj) = mbkt(ji,jj) + ELSE + CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999' ) + WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) + ENDIF + END DO ; END DO + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! set the associated depth + h_rnf(ji,jj) = 0._wp + DO jk = 1, nk_rnf(ji,jj) + h_rnf(ji,jj) = h_rnf(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO + END DO ; END DO + ! + ELSE IF( ln_rnf_depth_ini ) THEN ! runoffs applied at the surface + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> depth of runoff computed once from max value of runoff' + IF(lwp) WRITE(numout,*) ' max value of the runoff climatologie (over global domain) rn_rnf_max = ', rn_rnf_max + IF(lwp) WRITE(numout,*) ' depth over which runoffs is spread rn_dep_max = ', rn_dep_max + IF(lwp) WRITE(numout,*) ' create (=1) a runoff depth file or not (=0) nn_rnf_depth_file = ', nn_rnf_depth_file + + CALL iom_open( TRIM( sn_rnf%clname ), inum ) ! open runoff file + nbrec = iom_getszuld( inum ) + zrnfcl(:,:,1) = 0._wp ! init the max to 0. in 1 + DO jm = 1, nbrec + CALL iom_get( inum, jpdom_global, TRIM( sn_rnf%clvar ), zrnfcl(:,:,2), jm ) ! read the value in 2 + zrnfcl(:,:,1) = MAXVAL( zrnfcl(:,:,:), DIM=3 ) ! store the maximum value in time in 1 + END DO + CALL iom_close( inum ) + ! + h_rnf(:,:) = 1. + ! + zacoef = rn_dep_max / rn_rnf_max ! coef of linear relation between runoff and its depth (150m for max of runoff) + ! + WHERE( zrnfcl(:,:,1) > 0._wp ) h_rnf(:,:) = zacoef * zrnfcl(:,:,1) ! compute depth for all runoffs + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! take in account min depth of ocean rn_hmin + IF( zrnfcl(ji,jj,1) > 0._wp ) THEN + jk = mbkt(ji,jj) + h_rnf(ji,jj) = MIN( h_rnf(ji,jj), gdept_0(ji,jj,jk ) ) + ENDIF + END DO ; END DO + ! + nk_rnf(:,:) = 0 ! number of levels on which runoffs are distributed + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + IF( zrnfcl(ji,jj,1) > 0._wp ) THEN + jk = 2 + DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 + END DO + nk_rnf(ji,jj) = jk + ELSE + nk_rnf(ji,jj) = 1 + ENDIF + END DO ; END DO + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! set the associated depth + h_rnf(ji,jj) = 0._wp + DO jk = 1, nk_rnf(ji,jj) + h_rnf(ji,jj) = h_rnf(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO + END DO ; END DO + ! + IF( nn_rnf_depth_file == 1 ) THEN ! save output nb levels for runoff + IF(lwp) WRITE(numout,*) ' ==>>> create runoff depht file' + CALL iom_open ( TRIM( sn_dep_rnf%clname ), inum, ldwrt = .TRUE. ) + CALL iom_rstput( 0, 0, inum, 'rodepth', h_rnf ) + CALL iom_close ( inum ) + ENDIF + ELSE ! runoffs applied at the surface + nk_rnf(:,:) = 1 + h_rnf (:,:) = (e3t_0(:,:,1)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,1))) + ENDIF + ! + rnf(:,:) = 0._wp ! runoff initialisation + rnf_tsc(:,:,:) = 0._wp ! runoffs temperature & salinty contents initilisation + ! + ! ! ======================== + ! ! River mouth vicinity + ! ! ======================== + ! + IF( ln_rnf_mouth ) THEN ! Specific treatment in vicinity of river mouths : + ! ! - Increase Kz in surface layers ( rn_hrnf > 0 ) + ! ! - set to zero SSS damping (ln_ssr=T) + ! ! - mixed upstream-centered (ln_traadv_cen2=T) + ! + IF( ln_rnf_depth ) CALL ctl_warn( 'sbc_rnf_init: increased mixing turned on but effects may already', & + & 'be spread through depth by ln_rnf_depth' ) + ! + nkrnf = 0 ! Number of level over which Kz increase + IF( rn_hrnf > 0._wp ) THEN + nkrnf = 2 + DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf ) ; nkrnf = nkrnf + 1 + END DO + IF( ln_sco ) CALL ctl_warn( 'sbc_rnf_init: number of levels over which Kz is increased is computed for zco...' ) + ENDIF + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> Specific treatment used in vicinity of river mouths :' + IF(lwp) WRITE(numout,*) ' - Increase Kz in surface layers (if rn_hrnf > 0 )' + IF(lwp) WRITE(numout,*) ' by ', rn_avt_rnf,' m2/s over ', nkrnf, ' w-levels' + IF(lwp) WRITE(numout,*) ' - set to zero SSS damping (if ln_ssr=T)' + IF(lwp) WRITE(numout,*) ' - mixed upstream-centered (if ln_traadv_cen2=T)' + ! + CALL rnf_mouth ! set river mouth mask + ! + ELSE ! No treatment at river mouths + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> No specific treatment at river mouths' + rnfmsk (:,:) = 0._wp + rnfmsk_z(:) = 0._wp + nkrnf = 0 + ENDIF + ! + END SUBROUTINE sbc_rnf_init + + + SUBROUTINE rnf_mouth + !!---------------------------------------------------------------------- + !! *** ROUTINE rnf_mouth *** + !! + !! ** Purpose : define the river mouths mask + !! + !! ** Method : read the river mouth mask (=0/1) in the river runoff + !! climatological file. Defined a given vertical structure. + !! CAUTION, the vertical structure is hard coded on the + !! first 5 levels. + !! This fields can be used to: + !! - set an upstream advection scheme + !! (ln_rnf_mouth=T and ln_traadv_cen2=T) + !! - increase vertical on the top nn_krnf vertical levels + !! at river runoff input grid point (nn_krnf>=2, see step.F90) + !! - set to zero SSS restoring flux at river mouth grid points + !! + !! ** Action : rnfmsk set to 1 at river runoff input, 0 elsewhere + !! rnfmsk_z vertical structure + !!---------------------------------------------------------------------- + INTEGER :: inum ! temporary integers + CHARACTER(len=140) :: cl_rnfile ! runoff file name + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' rnf_mouth : river mouth mask' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~ ' + ! + cl_rnfile = TRIM( cn_dir )//TRIM( sn_cnf%clname ) + IF( .NOT. sn_cnf%ln_clim ) THEN ; WRITE(cl_rnfile, '(a,"_y",i4.4)' ) TRIM( cl_rnfile ), nyear ! add year + IF( sn_cnf%clftyp == 'monthly' ) WRITE(cl_rnfile, '(a,"m" ,i2.2)' ) TRIM( cl_rnfile ), nmonth ! add month + ENDIF + ! + ! horizontal mask (read in NetCDF file) + CALL iom_open ( cl_rnfile, inum ) ! open file + CALL iom_get ( inum, jpdom_global, sn_cnf%clvar, rnfmsk ) ! read the river mouth array + CALL iom_close( inum ) ! close file + ! + IF( l_clo_rnf ) CALL clo_rnf( rnfmsk ) ! closed sea inflow set as river mouth + ! + rnfmsk_z(:) = 0._wp ! vertical structure + rnfmsk_z(1) = 1.0 + rnfmsk_z(2) = 1.0 ! ********** + rnfmsk_z(3) = 0.5 ! HARD CODED on the 5 first levels + rnfmsk_z(4) = 0.25 ! ********** + rnfmsk_z(5) = 0.125 + ! + END SUBROUTINE rnf_mouth + + !!====================================================================== +END MODULE sbcrnf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcssm.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcssm.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cd4ae3b6c9508fec4c0ecd86d9e1ba5afd10cc5f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcssm.f90 @@ -0,0 +1,285 @@ + + + + + + + + + + + + + +MODULE sbcssm + !!====================================================================== + !! *** MODULE sbcssm *** + !! Surface module : provide time-mean ocean surface variables + !!====================================================================== + !! History : 9.0 ! 2006-07 (G. Madec) Original code + !! 3.3 ! 2010-10 (C. Bricaud, G. Madec) add the Patm forcing for sea-ice + !! 3.7 ! 2015-11 (G. Madec) non linear free surface by default: e3t_m always computed + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_ssm : calculate sea surface mean currents, temperature, + !! and salinity over nn_fsbc time-step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition: ocean fields + USE sbcapr ! surface boundary condition: atmospheric pressure + USE eosbn2 ! equation of state and related derivatives + USE traqsr, ONLY: ln_traqsr + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE iom ! IOM library + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_ssm ! routine called by step.F90 + PUBLIC sbc_ssm_init ! routine called by sbcmod.F90 + + LOGICAL, SAVE :: l_ssm_mean = .FALSE. ! keep track of whether means have been read from restart file + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcssm.F90 15145 2021-07-26 16:16:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_ssm( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_oce *** + !! + !! ** Purpose : provide ocean surface variable to sea-surface boundary + !! condition computation + !! + !! ** Method : compute mean surface velocity (2 components at U and + !! V-points) [m/s], temperature [Celsius] and salinity [psu] over + !! the periode (kt - nn_fsbc) to kt + !! Note that the inverse barometer ssh (i.e. ssh associated with Patm) + !! is add to ssh_m when ln_apr_dyn = T. Required for sea-ice dynamics. + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + ! + INTEGER :: ji, jj ! loop index + REAL(wp) :: zcoef, zf_sbc ! local scalar + REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts + !!--------------------------------------------------------------------- + ! + ! !* surface T-, U-, V- ocean level variables (T, S, depth, velocity) + zts(:,:,jp_tem) = ts(:,:,1,jp_tem,Kmm) + zts(:,:,jp_sal) = ts(:,:,1,jp_sal,Kmm) + ! + ! ! ---------------------------------------- ! + IF( nn_fsbc == 1 ) THEN ! Instantaneous surface fields ! + ! ! ---------------------------------------- ! + ssu_m(:,:) = uu(:,:,1,Kbb) + ssv_m(:,:) = vv(:,:,1,Kbb) + IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) + ELSE ; sst_m(:,:) = zts(:,:,jp_tem) + ENDIF + sss_m(:,:) = zts(:,:,jp_sal) + ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) + IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = ssh(:,:,Kmm) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE ; ssh_m(:,:) = ssh(:,:,Kmm) + ENDIF + ! + e3t_m(:,:) = (e3t_0(:,:,1)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,1))) + ! + frq_m(:,:) = fraqsr_1lev(:,:) + ! + ELSE + ! ! ----------------------------------------------- ! + IF( kt == nit000 .AND. .NOT. l_ssm_mean ) THEN ! Initialisation: 1st time-step, no input means ! + ! ! ----------------------------------------------- ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_ssm : mean fields initialised to instantaneous values' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + zcoef = REAL( nn_fsbc - 1, wp ) + ssu_m(:,:) = zcoef * uu(:,:,1,Kbb) + ssv_m(:,:) = zcoef * vv(:,:,1,Kbb) + IF( l_useCT ) THEN ; sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) + ELSE ; sst_m(:,:) = zcoef * zts(:,:,jp_tem) + ENDIF + sss_m(:,:) = zcoef * zts(:,:,jp_sal) + ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) + IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = zcoef * ( ssh(:,:,Kmm) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) ) + ELSE ; ssh_m(:,:) = zcoef * ssh(:,:,Kmm) + ENDIF + ! + e3t_m(:,:) = zcoef * (e3t_0(:,:,1)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,1))) + ! + frq_m(:,:) = zcoef * fraqsr_1lev(:,:) + ! ! ---------------------------------------- ! + ELSEIF( MOD( kt - 2 , nn_fsbc ) == 0 ) THEN ! Initialisation: New mean computation ! + ! ! ---------------------------------------- ! + ssu_m(:,:) = 0._wp ! reset to zero ocean mean sbc fields + ssv_m(:,:) = 0._wp + sst_m(:,:) = 0._wp + sss_m(:,:) = 0._wp + ssh_m(:,:) = 0._wp + e3t_m(:,:) = 0._wp + frq_m(:,:) = 0._wp + ENDIF + ! ! ---------------------------------------- ! + ! ! Cumulate at each time step ! + ! ! ---------------------------------------- ! + ssu_m(:,:) = ssu_m(:,:) + uu(:,:,1,Kbb) + ssv_m(:,:) = ssv_m(:,:) + vv(:,:,1,Kbb) + IF( l_useCT ) THEN ; sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) + ELSE ; sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem) + ENDIF + sss_m(:,:) = sss_m(:,:) + zts(:,:,jp_sal) + ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) + IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = ssh_m(:,:) + ssh(:,:,Kmm) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE ; ssh_m(:,:) = ssh_m(:,:) + ssh(:,:,Kmm) + ENDIF + ! + e3t_m(:,:) = e3t_m(:,:) + (e3t_0(:,:,1)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,1))) + ! + frq_m(:,:) = frq_m(:,:) + fraqsr_1lev(:,:) + + ! ! ---------------------------------------- ! + IF( MOD( kt - 1 , nn_fsbc ) == 0 ) THEN ! Mean value at each nn_fsbc time-step ! + ! ! ---------------------------------------- ! + zcoef = 1. / REAL( nn_fsbc, wp ) + sst_m(:,:) = sst_m(:,:) * zcoef ! mean SST [Celsius] + sss_m(:,:) = sss_m(:,:) * zcoef ! mean SSS [psu] + ssu_m(:,:) = ssu_m(:,:) * zcoef ! mean suface current [m/s] + ssv_m(:,:) = ssv_m(:,:) * zcoef ! + ssh_m(:,:) = ssh_m(:,:) * zcoef ! mean SSH [m] + e3t_m(:,:) = e3t_m(:,:) * zcoef ! mean vertical scale factor [m] + frq_m(:,:) = frq_m(:,:) * zcoef ! mean fraction of solar net radiation absorbed in the 1st T level [-] + ! + ENDIF + ! ! ---------------------------------------- ! + IF( lrst_oce ) THEN ! Write in the ocean restart file ! + ! ! ---------------------------------------- ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_ssm : sea surface mean fields written in ocean restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~~~~' + zf_sbc = REAL( nn_fsbc, wp ) + CALL iom_rstput( kt, nitrst, numrow, 'nn_fsbc', zf_sbc ) ! sbc frequency + CALL iom_rstput( kt, nitrst, numrow, 'ssu_m' , ssu_m ) ! sea surface mean fields + CALL iom_rstput( kt, nitrst, numrow, 'ssv_m' , ssv_m ) + CALL iom_rstput( kt, nitrst, numrow, 'sst_m' , sst_m ) + CALL iom_rstput( kt, nitrst, numrow, 'sss_m' , sss_m ) + CALL iom_rstput( kt, nitrst, numrow, 'ssh_m' , ssh_m ) + CALL iom_rstput( kt, nitrst, numrow, 'e3t_m' , e3t_m ) + CALL iom_rstput( kt, nitrst, numrow, 'frq_m' , frq_m ) + ! + ENDIF + ! + ENDIF + ! + IF( MOD( kt - 1 , nn_fsbc ) == 0 ) THEN ! Mean value at each nn_fsbc time-step ! + CALL iom_put( 'ssu_m', ssu_m ) + CALL iom_put( 'ssv_m', ssv_m ) + CALL iom_put( 'sst_m', sst_m ) + CALL iom_put( 'sss_m', sss_m ) + CALL iom_put( 'ssh_m', ssh_m ) + CALL iom_put( 'e3t_m', e3t_m ) + CALL iom_put( 'frq_m', frq_m ) + ENDIF + ! + END SUBROUTINE sbc_ssm + + + SUBROUTINE sbc_ssm_init( Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_ssm_init *** + !! + !! ** Purpose : Initialisation of the sbc data + !! + !! ** Action : - read parameters + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + REAL(wp) :: zcoef, zf_sbc ! local scalar + !!---------------------------------------------------------------------- + ! + IF( nn_fsbc == 1 ) THEN + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_ssm_init : sea surface mean fields, nn_fsbc=1 : instantaneous values' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' + ! + ELSE + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_ssm_init : sea surface mean fields' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' + ! + IF( ln_rstart .AND. iom_varid( numror, 'nn_fsbc', ldstop = .FALSE. ) > 0 ) THEN + l_ssm_mean = .TRUE. + CALL iom_get( numror , 'nn_fsbc', zf_sbc ) ! sbc frequency of previous run + CALL iom_get( numror, jpdom_auto, 'ssu_m' , ssu_m, cd_type = 'U', psgn = -1._dp ) ! sea surface mean velocity (U-point) + CALL iom_get( numror, jpdom_auto, 'ssv_m' , ssv_m, cd_type = 'V', psgn = -1._dp ) ! " " velocity (V-point) + CALL iom_get( numror, jpdom_auto, 'sst_m' , sst_m ) ! " " temperature (T-point) + CALL iom_get( numror, jpdom_auto, 'sss_m' , sss_m ) ! " " salinity (T-point) + CALL iom_get( numror, jpdom_auto, 'ssh_m' , ssh_m ) ! " " height (T-point) + CALL iom_get( numror, jpdom_auto, 'e3t_m' , e3t_m ) ! 1st level thickness (T-point) + ! fraction of solar net radiation absorbed in 1st T level + IF( iom_varid( numror, 'frq_m', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_auto, 'frq_m' , frq_m ) + ELSE + frq_m(:,:) = 1._wp ! default definition + ENDIF + ! + IF( zf_sbc /= REAL( nn_fsbc, wp ) ) THEN ! nn_fsbc has changed between 2 runs + IF(lwp) WRITE(numout,*) ' restart with a change in the frequency of mean from ', zf_sbc, ' to ', nn_fsbc + zcoef = REAL( nn_fsbc - 1, wp ) / zf_sbc + ssu_m(:,:) = zcoef * ssu_m(:,:) + ssv_m(:,:) = zcoef * ssv_m(:,:) + sst_m(:,:) = zcoef * sst_m(:,:) + sss_m(:,:) = zcoef * sss_m(:,:) + ssh_m(:,:) = zcoef * ssh_m(:,:) + e3t_m(:,:) = zcoef * e3t_m(:,:) + frq_m(:,:) = zcoef * frq_m(:,:) + ELSE + IF(lwp) WRITE(numout,*) ' mean fields read in the ocean restart file' + ENDIF + ENDIF + ENDIF + ! + IF( .NOT.l_ssm_mean ) THEN ! default initialisation. needed by iceistate + ! + IF(lwp) WRITE(numout,*) ' default initialisation of ss._m arrays' + ssu_m(:,:) = uu(:,:,1,Kbb) + ssv_m(:,:) = vv(:,:,1,Kbb) + IF( l_useCT ) THEN ; sst_m(:,:) =eos_pt_from_ct( REAL(ts(:,:,1,jp_tem,Kmm),sp), REAL(ts(:,:,1,jp_sal,Kmm),sp) ) + ELSE ; sst_m(:,:) = ts(:,:,1,jp_tem,Kmm) + ENDIF + sss_m(:,:) = ts (:,:,1,jp_sal,Kmm) + ssh_m(:,:) = ssh(:,:,Kmm) + e3t_m(:,:) = (e3t_0(:,:,1)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,1))) + frq_m(:,:) = 1._wp + ! + ENDIF + ! + IF( .NOT. ln_traqsr ) fraqsr_1lev(:,:) = 1._wp ! default definition: qsr 100% in the fisrt level + ! + END SUBROUTINE sbc_ssm_init + + !!====================================================================== +END MODULE sbcssm diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcssr.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcssr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..75d0191798b5b83fb5ea7ffc1d40bc729d859a33 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcssr.f90 @@ -0,0 +1,272 @@ + + + + + + + + + + + + + +MODULE sbcssr + !!====================================================================== + !! *** MODULE sbcssr *** + !! Surface module : heat and fresh water fluxes a restoring term toward observed SST/SSS + !!====================================================================== + !! History : 3.0 ! 2006-06 (G. Madec) Original code + !! 3.2 ! 2009-04 (B. Lemaire) Introduce iom_put + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_ssr : add to sbc a restoring term toward SST/SSS climatology + !! sbc_ssr_init : initialisation of surface restoring + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition + USE phycst ! physical constants + USE sbcrnf ! surface boundary condition : runoffs + ! + USE fldread ! read input fields + USE in_out_manager ! I/O manager + USE iom ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_ssr ! routine called in sbcmod + PUBLIC sbc_ssr_init ! routine called in sbcmod + PUBLIC sbc_ssr_alloc ! routine called in sbcmod + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: erp !: evaporation damping [kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qrp !: heat flux damping [w/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: coefice !: under ice relaxation coefficient + + ! !!* Namelist namsbc_ssr * + INTEGER, PUBLIC :: nn_sstr ! SST/SSS restoring indicator + INTEGER, PUBLIC :: nn_sssr ! SST/SSS restoring indicator + REAL(wp) :: rn_dqdt ! restoring factor on SST and SSS + REAL(wp) :: rn_deds ! restoring factor on SST and SSS + LOGICAL :: ln_sssr_bnd ! flag to bound erp term + REAL(wp) :: rn_sssr_bnd ! ABS(Max./Min.) value of erp term [mm/day] + INTEGER :: nn_sssr_ice ! Control of restoring under ice + + REAL(wp) , ALLOCATABLE, DIMENSION(:) :: buffer ! Temporary buffer for exchange + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sst ! structure of input SST (file informations, fields read) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sss ! structure of input SSS (file informations, fields read) + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcssr.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_ssr( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_ssr *** + !! + !! ** Purpose : Add to heat and/or freshwater fluxes a damping term + !! toward observed SST and/or SSS. + !! + !! ** Method : - Read namelist namsbc_ssr + !! - Read observed SST and/or SSS + !! - at each nscb time step + !! add a retroaction term on qns (nn_sstr = 1) + !! add a damping term on sfx (nn_sssr = 1) + !! add a damping term on emp (nn_sssr = 2) + !!--------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time step + !! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zerp ! local scalar for evaporation damping + REAL(wp) :: zqrp ! local scalar for heat flux damping + REAL(wp) :: zsrp ! local scalar for unit conversion of rn_deds factor + REAL(wp) :: zerp_bnd ! local scalar for unit conversion of rn_epr_max factor + INTEGER :: ierror ! return error code + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N) :: sn_sst, sn_sss ! informations about the fields to be read + !!---------------------------------------------------------------------- + ! + IF( nn_sstr + nn_sssr /= 0 ) THEN + ! + IF( nn_sstr == 1) CALL fld_read( kt, nn_fsbc, sf_sst ) ! Read SST data and provides it at kt + IF( nn_sssr >= 1) CALL fld_read( kt, nn_fsbc, sf_sss ) ! Read SSS data and provides it at kt + ! + ! ! ========================= ! + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! Add restoring term ! + ! ! ========================= ! + ! + qrp(:,:) = 0._wp ! necessary init + erp(:,:) = 0._wp + ! + IF( nn_sstr == 1 ) THEN !* Temperature restoring term + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1) + qns(ji,jj) = qns(ji,jj) + zqrp + qrp(ji,jj) = zqrp + END DO ; END DO + ENDIF + ! + IF( nn_sssr /= 0 .AND. nn_sssr_ice /= 1 ) THEN + ! use fraction of ice ( fr_i ) to adjust relaxation under ice if nn_sssr_ice .ne. 1 + ! n.b. coefice is initialised and fixed to 1._wp if nn_sssr_ice = 1 + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + SELECT CASE ( nn_sssr_ice ) + CASE ( 0 ) ; coefice(ji,jj) = 1._wp - fr_i(ji,jj) ! no/reduced damping under ice + CASE DEFAULT ; coefice(ji,jj) = 1._wp + ( nn_sssr_ice - 1 ) * fr_i(ji,jj) ! reinforced damping (x nn_sssr_ice) under ice ) + END SELECT + END DO ; END DO + ENDIF + ! + IF( nn_sssr == 1 ) THEN !* Salinity damping term (salt flux only (sfx)) + zsrp = rn_deds / rday ! from [mm/day] to [kg/m2/s] + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths + & * coefice(ji,jj) & ! Optional control of damping under sea-ice + & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1) + sfx(ji,jj) = sfx(ji,jj) + zerp ! salt flux + erp(ji,jj) = zerp / MAX( sss_m(ji,jj), 1.e-20 ) ! converted into an equivalent volume flux (diagnostic only) + END DO ; END DO + ! + ELSEIF( nn_sssr == 2 ) THEN !* Salinity damping term (volume flux (emp) and associated heat flux (qns) + zsrp = rn_deds / rday ! from [mm/day] to [kg/m2/s] + zerp_bnd = rn_sssr_bnd / rday ! - - + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths + & * coefice(ji,jj) & ! Optional control of damping under sea-ice + & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) & + & / MAX( sss_m(ji,jj), 1.e-20 ) * tmask(ji,jj,1) + IF( ln_sssr_bnd ) zerp = SIGN( 1.0_wp, zerp ) * MIN( zerp_bnd, ABS(zerp) ) + emp(ji,jj) = emp (ji,jj) + zerp + qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj) + erp(ji,jj) = zerp + qrp(ji,jj) = qrp(ji,jj) - zerp * rcp * sst_m(ji,jj) + END DO ; END DO + ENDIF + ! outputs + CALL iom_put( 'hflx_ssr_cea', qrp(:,:) ) + IF( nn_sssr == 1 ) CALL iom_put( 'sflx_ssr_cea', erp(:,:) * sss_m(:,:) ) + IF( nn_sssr == 2 ) CALL iom_put( 'vflx_ssr_cea', -erp(:,:) ) + ! + ENDIF + ! + ENDIF + ! + END SUBROUTINE sbc_ssr + + + SUBROUTINE sbc_ssr_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_ssr_init *** + !! + !! ** Purpose : initialisation of surface damping term + !! + !! ** Method : - Read namelist namsbc_ssr + !! - Read observed SST and/or SSS if required + !!--------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zerp ! local scalar for evaporation damping + REAL(wp) :: zqrp ! local scalar for heat flux damping + REAL(wp) :: zsrp ! local scalar for unit conversion of rn_deds factor + REAL(wp) :: zerp_bnd ! local scalar for unit conversion of rn_epr_max factor + INTEGER :: ierror ! return error code + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N) :: sn_sst, sn_sss ! informations about the fields to be read + NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, & + & sn_sss, ln_sssr_bnd, rn_sssr_bnd, nn_sssr_ice + INTEGER :: ios + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_ssr : SST and/or SSS damping term ' + WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + READ ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist' ) + + READ ( numnam_cfg, namsbc_ssr, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_ssr ) + + IF(lwp) THEN !* control print + WRITE(numout,*) ' Namelist namsbc_ssr :' + WRITE(numout,*) ' SST restoring term (Yes=1) nn_sstr = ', nn_sstr + WRITE(numout,*) ' dQ/dT (restoring magnitude on SST) rn_dqdt = ', rn_dqdt, ' W/m2/K' + WRITE(numout,*) ' SSS damping term (Yes=1, salt flux) nn_sssr = ', nn_sssr + WRITE(numout,*) ' (Yes=2, volume flux) ' + WRITE(numout,*) ' dE/dS (restoring magnitude on SST) rn_deds = ', rn_deds, ' mm/day' + WRITE(numout,*) ' flag to bound erp term ln_sssr_bnd = ', ln_sssr_bnd + WRITE(numout,*) ' ABS(Max./Min.) erp threshold rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day' + WRITE(numout,*) ' Cntrl of surface restoration under ice nn_sssr_ice = ', nn_sssr_ice + WRITE(numout,*) ' ( 0 = no restoration under ice)' + WRITE(numout,*) ' ( 1 = restoration everywhere )' + WRITE(numout,*) ' (>1 = enhanced restoration under ice )' + ENDIF + ! + IF( nn_sstr == 1 ) THEN !* set sf_sst structure & allocate arrays + ! + ALLOCATE( sf_sst(1), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' ) + ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' ) + ! + ! fill sf_sst with sn_sst and control print + CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr', no_print ) + IF( sf_sst(1)%ln_tint ) ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' ) + ! + ENDIF + ! + IF( nn_sssr >= 1 ) THEN !* set sf_sss structure & allocate arrays + ! + ALLOCATE( sf_sss(1), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' ) + ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' ) + ! + ! fill sf_sss with sn_sss and control print + CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr', no_print ) + IF( sf_sss(1)%ln_tint ) ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' ) + ! + ENDIF + ! + coefice(:,:) = 1._wp ! Initialise coefice to 1._wp ; will not need to be changed if nn_sssr_ice=1 + ! !* Initialize qrp and erp if no restoring + IF( nn_sstr /= 1 ) qrp(:,:) = 0._wp + IF( nn_sssr /= 1 .OR. nn_sssr /= 2 ) erp(:,:) = 0._wp + ! + END SUBROUTINE sbc_ssr_init + + INTEGER FUNCTION sbc_ssr_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_ssr_alloc *** + !!---------------------------------------------------------------------- + sbc_ssr_alloc = 0 ! set to zero if no array to be allocated + IF( .NOT. ALLOCATED( erp ) ) THEN + ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), coefice(jpi,jpj), STAT= sbc_ssr_alloc ) + ! + IF( lk_mpp ) CALL mpp_sum ( 'sbcssr', sbc_ssr_alloc ) + IF( sbc_ssr_alloc /= 0 ) CALL ctl_warn('sbc_ssr_alloc: failed to allocate arrays.') + ! + ENDIF + END FUNCTION + + !!====================================================================== +END MODULE sbcssr diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcwave.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcwave.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c5a5599ffb962fabb78145ed364d339b3972003a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sbcwave.f90 @@ -0,0 +1,562 @@ + + + + + + + + + + + + + +MODULE sbcwave + !!====================================================================== + !! *** MODULE sbcwave *** + !! Wave module + !!====================================================================== + !! History : 3.3 ! 2011-09 (M. Adani) Original code: Drag Coefficient + !! : 3.4 ! 2012-10 (M. Adani) Stokes Drift + !! 3.6 ! 2014-09 (E. Clementi,P. Oddo) New Stokes Drift Computation + !! - ! 2016-12 (G. Madec, E. Clementi) update Stoke drift computation + !! + add sbc_wave_ini routine + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) updates, new Stoke drift computation + !! according to Couvelard et al.,2019 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_stokes : calculate 3D Stokes-drift velocities + !! sbc_wave : wave data from wave model: forced (netcdf files) or coupled mode + !! sbc_wave_init : initialisation fo surface waves + !!---------------------------------------------------------------------- + USE phycst ! physical constants + USE oce ! ocean variables + USE dom_oce ! ocean domain variables + USE sbc_oce ! Surface boundary condition: ocean fields + USE bdy_oce ! open boundary condition variables + USE domvvl ! domain: variable volume layers + USE zdf_oce, ONLY : ln_zdfswm ! Qiao wave enhanced mixing + ! + USE iom ! I/O manager library + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE fldread ! read input fields + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_stokes ! routine called in sbccpl + PUBLIC sbc_wave ! routine called in sbcmod + PUBLIC sbc_wave_init ! routine called in sbcmod + + ! Variables checking if the wave parameters are coupled (if not, they are read from file) + LOGICAL, PUBLIC :: cpl_hsig = .FALSE. + LOGICAL, PUBLIC :: cpl_phioc = .FALSE. + LOGICAL, PUBLIC :: cpl_sdrftx = .FALSE. + LOGICAL, PUBLIC :: cpl_sdrfty = .FALSE. + LOGICAL, PUBLIC :: cpl_wper = .FALSE. + LOGICAL, PUBLIC :: cpl_wnum = .FALSE. + LOGICAL, PUBLIC :: cpl_wstrf = .FALSE. + LOGICAL, PUBLIC :: cpl_wdrag = .FALSE. + LOGICAL, PUBLIC :: cpl_charn = .FALSE. + LOGICAL, PUBLIC :: cpl_taw = .FALSE. + LOGICAL, PUBLIC :: cpl_bhd = .FALSE. + LOGICAL, PUBLIC :: cpl_tusd = .FALSE. + LOGICAL, PUBLIC :: cpl_tvsd = .FALSE. + + INTEGER :: jpfld ! number of files to read for stokes drift + INTEGER :: jp_usd ! index of stokes drift (i-component) (m/s) at T-point + INTEGER :: jp_vsd ! index of stokes drift (j-component) (m/s) at T-point + INTEGER :: jp_hsw ! index of significant wave hight (m) at T-point + INTEGER :: jp_wmp ! index of mean wave period (s) at T-point + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_cd ! structure of input fields (file informations, fields read) Drag Coefficient + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sd ! structure of input fields (file informations, fields read) Stokes Drift + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_wn ! structure of input fields (file informations, fields read) wave number for Qiao + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tauoc ! structure of input fields (file informations, fields read) normalized wave stress into the ocean + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: cdn_wave !: Neutral drag coefficient at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hsw !: Significant Wave Height at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wmp !: Wave Mean Period at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wnum !: Wave Number at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wave !: stress reduction factor at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tsd2d !: Surface Stokes Drift module at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: div_sd !: barotropic stokes drift divergence + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ut0sd, vt0sd !: surface Stokes drift velocities at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: wsd!: Stokes drift velocities at u-, v- & w-points, resp.u + REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: usd, vsd!: Stokes drift velocities at u-, v- & w-points, resp.u +! + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: charn !: charnock coefficient at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tawx !: Net wave-supported stress, u + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tawy !: Net wave-supported stress, v + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: twox !: wave-ocean momentum flux, u + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: twoy !: wave-ocean momentum flux, v + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wavex !: stress reduction factor at, u component + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wavey !: stress reduction factor at, v component + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: phioc !: tke flux from wave model + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: KZN2 !: Kz*N2 + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: bhd_wave !: Bernoulli head. wave induce pression + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tusd, tvsd !: Stokes drift transport + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: ZMX !: Kz*N2 + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcwave.F90 15199 2021-08-19 07:57:52Z amoulin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_stokes( Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_stokes *** + !! + !! ** Purpose : compute the 3d Stokes Drift according to Breivik et al., + !! 2014 (DOI: 10.1175/JPO-D-14-0020.1) + !! + !! ** Method : - Calculate the horizontal Stokes drift velocity (Breivik et al. 2014) + !! - Calculate its horizontal divergence + !! - Calculate the vertical Stokes drift velocity + !! - Calculate the barotropic Stokes drift divergence + !! + !! ** action : - tsd2d : module of the surface Stokes drift velocity + !! - usd, vsd, wsd : 3 components of the Stokes drift velocity + !! - div_sd : barotropic Stokes drift divergence + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + INTEGER :: jj, ji, jk ! dummy loop argument + INTEGER :: ik ! local integer + REAL(wp) :: ztransp, zfac, ztemp, zsp0, zsqrt, zbreiv16_w + REAL(wp) :: zdep_u, zdep_v, zkh_u, zkh_v, zda_u, zda_v, sdtrp + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zk_t, zk_u, zk_v, zu0_sd, zv0_sd ! 2D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3divh, zInt_w ! 3D workspace + !!--------------------------------------------------------------------- + ! + ALLOCATE( ze3divh(jpi,jpj,jpkm1) ) ! jpkm1 -> avoid lbc_lnk on jpk that is not defined + ALLOCATE( zInt_w(jpi,jpj,jpk) ) + ALLOCATE( zk_t(jpi,jpj), zk_u(jpi,jpj), zk_v(jpi,jpj), zu0_sd(jpi,jpj), zv0_sd(jpi,jpj) ) + zk_t (:,:) = 0._wp + zk_u (:,:) = 0._wp + zk_v (:,:) = 0._wp + zu0_sd (:,:) = 0._wp + zv0_sd (:,:) = 0._wp + ze3divh (:,:,:) = 0._wp + + ! + ! select parameterization for the calculation of vertical Stokes drift + ! exp. wave number at t-point + IF( ln_breivikFV_2016 ) THEN + ! Assumptions : ut0sd and vt0sd are surface Stokes drift at T-points + ! sdtrp is the norm of Stokes transport + ! + zfac = 0.166666666667_wp + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) ! In the deep-water limit we have ke = ||ust0||/( 6 * ||transport|| ) + zsp0 = SQRT( ut0sd(ji,jj)*ut0sd(ji,jj) + vt0sd(ji,jj)*vt0sd(ji,jj) ) !<-- norm of Surface Stokes drift + tsd2d(ji,jj) = zsp0 + IF( cpl_tusd .AND. cpl_tvsd ) THEN !stokes transport is provided in coupled mode + sdtrp = SQRT( tusd(ji,jj)*tusd(ji,jj) + tvsd(ji,jj)*tvsd(ji,jj) ) !<-- norm of Surface Stokes drift transport + ELSE + ! Stokes drift transport estimated from Hs and Tmean + sdtrp = 2.0_wp * rpi / 16.0_wp * & + & hsw(ji,jj)*hsw(ji,jj) / MAX( wmp(ji,jj), 0.0000001_wp ) + ENDIF + zk_t (ji,jj) = zfac * zsp0 / MAX ( sdtrp, 0.0000001_wp ) !<-- ke = ||ust0||/( 6 * ||transport|| ) + END DO ; END DO + !# define zInt_w ze3divh + DO jk = 1, jpk ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) ! Compute the primitive of Breivik 2016 function at W-points + zfac = - 2._wp * zk_t (ji,jj) * (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) !<-- zfac should be negative definite + ztemp = EXP ( zfac ) + zsqrt = SQRT( -zfac ) + zbreiv16_w = ztemp - SQRT(rpi)*zsqrt*ERFC(zsqrt) !Eq. 16 Breivik 2016 + zInt_w(ji,jj,jk) = ztemp - 4._wp * zk_t (ji,jj) * (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * zbreiv16_w + END DO ; END DO ; END DO +! + DO jk = 1, jpkm1 + zfac = 0.166666666667_wp + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) !++ Compute the FV Breivik 2016 function at T-points + zsp0 = zfac / MAX(zk_t (ji,jj),0.0000001_wp) + ztemp = zInt_w(ji,jj,jk) - zInt_w(ji,jj,jk+1) + zu0_sd(ji,jj) = ut0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk) + zv0_sd(ji,jj) = vt0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk) + END DO ; END DO + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) ! ++ Interpolate at U/V points + zfac = 1.0_wp / (e3u_0(ji ,jj,jk)*(1._wp+r3u(ji ,jj,Kmm)*umask(ji ,jj,jk))) + usd(ji,jj,jk) = 0.5_wp * zfac * ( zu0_sd(ji,jj)+zu0_sd(ji+1,jj) ) * umask(ji,jj,jk) + zfac = 1.0_wp / (e3v_0(ji ,jj,jk)*(1._wp+r3v(ji ,jj,Kmm)*vmask(ji ,jj,jk))) + vsd(ji,jj,jk) = 0.5_wp * zfac * ( zv0_sd(ji,jj)+zv0_sd(ji,jj+1) ) * vmask(ji,jj,jk) + END DO ; END DO + ENDDO + !# undef zInt_w + ! + ELSE + zfac = 2.0_wp * rpi / 16.0_wp + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ! Stokes drift velocity estimated from Hs and Tmean + ztransp = zfac * hsw(ji,jj)*hsw(ji,jj) / MAX( wmp(ji,jj), 0.0000001_wp ) + ! Stokes surface speed + tsd2d(ji,jj) = SQRT( ut0sd(ji,jj)*ut0sd(ji,jj) + vt0sd(ji,jj)*vt0sd(ji,jj)) + ! Wavenumber scale + zk_t(ji,jj) = ABS( tsd2d(ji,jj) ) / MAX( ABS( 5.97_wp*ztransp ), 0.0000001_wp ) + END DO ; END DO + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) ! exp. wave number & Stokes drift velocity at u- & v-points + zk_u(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji+1,jj) ) + zk_v(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji,jj+1) ) + ! + zu0_sd(ji,jj) = 0.5_wp * ( ut0sd(ji,jj) + ut0sd(ji+1,jj) ) + zv0_sd(ji,jj) = 0.5_wp * ( vt0sd(ji,jj) + vt0sd(ji,jj+1) ) + END DO ; END DO + + ! !== horizontal Stokes Drift 3D velocity ==! + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zdep_u = 0.5_wp * ( (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + (gdept_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kmm))) ) + zdep_v = 0.5_wp * ( (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + (gdept_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kmm))) ) + ! + zkh_u = zk_u(ji,jj) * zdep_u ! k * depth + zkh_v = zk_v(ji,jj) * zdep_v + ! ! Depth attenuation + zda_u = EXP( -2.0_wp*zkh_u ) / ( 1.0_wp + 8.0_wp*zkh_u ) + zda_v = EXP( -2.0_wp*zkh_v ) / ( 1.0_wp + 8.0_wp*zkh_v ) + ! + usd(ji,jj,jk) = zda_u * zu0_sd(ji,jj) * umask(ji,jj,jk) + vsd(ji,jj,jk) = zda_v * zv0_sd(ji,jj) * vmask(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + + CALL lbc_lnk( 'sbcwave', usd, 'U', -1.0_dp, vsd, 'V', -1.0_dp ) + + ! + ! !== vertical Stokes Drift 3D velocity ==! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 1) ; DO ji = ntsi-( 0), ntei+( 1) ! Horizontal e3*divergence + ze3divh(ji,jj,jk) = ( e2u(ji ,jj) * (e3u_0(ji ,jj,jk)*(1._wp+r3u(ji ,jj,Kmm)*umask(ji ,jj,jk))) * usd(ji ,jj,jk) & + & - e2u(ji-1,jj) * (e3u_0(ji-1,jj,jk)*(1._wp+r3u(ji-1,jj,Kmm)*umask(ji-1,jj,jk))) * usd(ji-1,jj,jk) & + & + e1v(ji,jj ) * (e3v_0(ji,jj ,jk)*(1._wp+r3v(ji,jj ,Kmm)*vmask(ji,jj ,jk))) * vsd(ji,jj ,jk) & + & - e1v(ji,jj-1) * (e3v_0(ji,jj-1,jk)*(1._wp+r3v(ji,jj-1,Kmm)*vmask(ji,jj-1,jk))) * vsd(ji,jj-1,jk) ) & + & * r1_e1e2t(ji,jj) + END DO ; END DO ; END DO + ! + CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1.0_wp ) + ! + IF( ln_linssh ) THEN ; ik = 1 ! none zero velocity through the sea surface + ELSE ; ik = 2 ! w=0 at the surface (set one for all in sbc_wave_init) + ENDIF + DO jk = jpkm1, ik, -1 ! integrate from the bottom the hor. divergence (NB: at k=jpk w is always zero) + wsd(:,:,jk) = wsd(:,:,jk+1) - ze3divh(:,:,jk) + END DO + ! + IF( ln_bdy ) THEN + DO jk = 1, jpkm1 + wsd(:,:,jk) = wsd(:,:,jk) * bdytmask(:,:) + END DO + ENDIF + ! !== Horizontal divergence of barotropic Stokes transport ==! + div_sd(:,:) = 0._wp + DO jk = 1, jpkm1 ! + div_sd(:,:) = div_sd(:,:) + ze3divh(:,:,jk) + END DO + ! + CALL iom_put( "ustokes", usd ) + CALL iom_put( "vstokes", vsd ) + CALL iom_put( "wstokes", wsd ) +! ! + DEALLOCATE( ze3divh, zInt_w ) + DEALLOCATE( zk_t, zk_u, zk_v, zu0_sd, zv0_sd ) + ! + END SUBROUTINE sbc_stokes +! +! + SUBROUTINE sbc_wave( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_wave *** + !! + !! ** Purpose : read wave parameters from wave model in netcdf files + !! or from a coupled wave mdoel + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time step + INTEGER, INTENT(in ) :: Kmm ! ocean time index + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_wave : update the read waves fields' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF + ! + IF( ln_cdgw .AND. .NOT. cpl_wdrag ) THEN !== Neutral drag coefficient ==! + CALL fld_read( kt, nn_fsbc, sf_cd ) ! read from external forcing + cdn_wave(:,:) = sf_cd(1)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + + IF( ln_tauoc .AND. .NOT. cpl_wstrf ) THEN !== Wave induced stress ==! + CALL fld_read( kt, nn_fsbc, sf_tauoc ) ! read stress reduction factor due to wave from external forcing + tauoc_wave(:,:) = sf_tauoc(1)%fnow(:,:,1) * tmask(:,:,1) + ELSEIF ( ln_taw .AND. cpl_taw ) THEN + IF (kt < 1) THEN ! The first fields gave by OASIS have very high erroneous values .... + twox(:,:)=0._wp + twoy(:,:)=0._wp + tawx(:,:)=0._wp + tawy(:,:)=0._wp + tauoc_wavex(:,:) = 1._wp + tauoc_wavey(:,:) = 1._wp + ELSE + tauoc_wavex(:,:) = abs(twox(:,:)/tawx(:,:)) + tauoc_wavey(:,:) = abs(twoy(:,:)/tawy(:,:)) + ENDIF + ENDIF + + IF ( ln_phioc .and. cpl_phioc .and. kt == nit000 ) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_wave : PHIOC from wave model' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF + + IF( ln_sdw .AND. .NOT. cpl_sdrftx) THEN !== Computation of the 3d Stokes Drift ==! + ! + IF( jpfld > 0 ) THEN ! Read from file only if the field is not coupled + CALL fld_read( kt, nn_fsbc, sf_sd ) ! read wave parameters from external forcing + ! ! NB: test case mode, not read as jpfld=0 + IF( jp_hsw > 0 ) hsw (:,:) = sf_sd(jp_hsw)%fnow(:,:,1) * tmask(:,:,1) ! significant wave height + IF( jp_wmp > 0 ) wmp (:,:) = sf_sd(jp_wmp)%fnow(:,:,1) * tmask(:,:,1) ! wave mean period + IF( jp_usd > 0 ) ut0sd(:,:) = sf_sd(jp_usd)%fnow(:,:,1) * tmask(:,:,1) ! 2D zonal Stokes Drift at T point + IF( jp_vsd > 0 ) vt0sd(:,:) = sf_sd(jp_vsd)%fnow(:,:,1) * tmask(:,:,1) ! 2D meridional Stokes Drift at T point + ENDIF + + ! Read also wave number if needed, so that it is available in + ! coupling routines + IF( ln_zdfswm .AND. .NOT. cpl_wnum ) THEN !==wavenumber==! + CALL fld_read( kt, nn_fsbc, sf_wn ) ! read wave parameters from external forcing + wnum(:,:) = sf_wn(1)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + + ! + IF( jpfld == 4 .OR. ln_wave_test ) & + & CALL sbc_stokes( Kmm ) ! Calculate only if all required fields are read + ! ! or in wave test case + ! ! ! In coupled case the call is done after (in sbc_cpl) + ENDIF + ! + END SUBROUTINE sbc_wave + + + SUBROUTINE sbc_wave_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_wave_init *** + !! + !! ** Purpose : Initialisation fo surface waves + !! + !! ** Method : - Read namelist namsbc_wave + !! - create the structure used to read required wave fields + !! (its size depends on namelist options) + !! ** action + !!--------------------------------------------------------------------- + INTEGER :: ierror, ios ! local integer + INTEGER :: ifpr + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of drag coefficient files + TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: slf_i ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_cdg, sn_usd, sn_vsd, & + & sn_hsw, sn_wmp, sn_wnum, sn_tauoc ! informations about the fields to be read + ! + NAMELIST/namsbc_wave/ cn_dir, sn_cdg, sn_usd, sn_vsd, sn_hsw, sn_wmp, sn_wnum, sn_tauoc, & + & ln_cdgw, ln_sdw, ln_tauoc, ln_stcor, ln_charn, ln_taw, ln_phioc, & + & ln_wave_test, ln_bern_srfc, ln_breivikFV_2016, ln_vortex_force, ln_stshear + !!--------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_wave_init : surface waves in the system' + WRITE(numout,*) '~~~~~~~~~~~~~ ' + ENDIF + ! + READ ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_wave in reference namelist') + + READ ( numnam_cfg, namsbc_wave, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_wave ) + ! + IF(lwp) THEN + WRITE(numout,*) ' Namelist namsbc_wave' + WRITE(numout,*) ' Stokes drift ln_sdw = ', ln_sdw + WRITE(numout,*) ' Breivik 2016 ln_breivikFV_2016 = ', ln_breivikFV_2016 + WRITE(numout,*) ' Stokes Coriolis & tracer advection terms ln_stcor = ', ln_stcor + WRITE(numout,*) ' Vortex Force ln_vortex_force = ', ln_vortex_force + WRITE(numout,*) ' Bernouilli Head Pressure ln_bern_srfc = ', ln_bern_srfc + WRITE(numout,*) ' wave modified ocean stress ln_tauoc = ', ln_tauoc + WRITE(numout,*) ' neutral drag coefficient (CORE bulk only) ln_cdgw = ', ln_cdgw + WRITE(numout,*) ' charnock coefficient ln_charn = ', ln_charn + WRITE(numout,*) ' Stress modificated by wave ln_taw = ', ln_taw + WRITE(numout,*) ' TKE flux from wave ln_phioc = ', ln_phioc + WRITE(numout,*) ' Surface shear with Stokes drift ln_stshear = ', ln_stshear + WRITE(numout,*) ' Test with constant wave fields ln_wave_test = ', ln_wave_test + ENDIF + + ! ! option check + IF( .NOT.( ln_cdgw .OR. ln_sdw .OR. ln_tauoc .OR. ln_stcor .OR. ln_charn) ) & + & CALL ctl_warn( 'Ask for wave coupling but ln_cdgw=F, ln_sdw=F, ln_tauoc=F, ln_stcor=F') + IF( ln_cdgw .AND. ln_blk ) & + & CALL ctl_stop( 'drag coefficient read from wave model NOT available yet with aerobulk package') + IF( ln_stcor .AND. .NOT.ln_sdw ) & + & CALL ctl_stop( 'Stokes-Coriolis term calculated only if activated Stokes Drift ln_sdw=T') + + ! !== Allocate wave arrays ==! + ALLOCATE( ut0sd (jpi,jpj) , vt0sd (jpi,jpj) ) + ALLOCATE( hsw (jpi,jpj) , wmp (jpi,jpj) ) + ALLOCATE( wnum (jpi,jpj) ) + ALLOCATE( tsd2d (jpi,jpj) , div_sd(jpi,jpj) , bhd_wave(jpi,jpj) ) + ALLOCATE( usd (jpi,jpj,jpk), vsd (jpi,jpj,jpk), wsd (jpi,jpj,jpk) ) + ALLOCATE( tusd (jpi,jpj) , tvsd (jpi,jpj) , ZMX (jpi,jpj,jpk) ) + usd (:,:,:) = 0._wp + vsd (:,:,:) = 0._wp + wsd (:,:,:) = 0._wp + hsw (:,:) = 0._wp + wmp (:,:) = 0._wp + ut0sd (:,:) = 0._wp + vt0sd (:,:) = 0._wp + tusd (:,:) = 0._wp + tvsd (:,:) = 0._wp + bhd_wave(:,:) = 0._wp + ZMX (:,:,:) = 0._wp +! + IF( ln_wave_test ) THEN !== Wave TEST case ==! set uniform waves fields + jpfld = 0 ! No field read + ln_cdgw = .FALSE. ! No neutral wave drag input + ln_tauoc = .FALSE. ! No wave induced drag reduction factor + ut0sd(:,:) = 0.13_wp * tmask(:,:,1) ! m/s + vt0sd(:,:) = 0.00_wp ! m/s + hsw (:,:) = 2.80_wp ! meters + wmp (:,:) = 8.00_wp ! seconds + ! + ELSE !== create the structure associated with fields to be read ==! + IF( ln_cdgw ) THEN ! wave drag + IF( .NOT. cpl_wdrag ) THEN + ALLOCATE( sf_cd(1), STAT=ierror ) !* allocate and fill sf_wave with sn_cdg + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) + ! + ALLOCATE( sf_cd(1)%fnow(jpi,jpj,1) ) + IF( sn_cdg%ln_tint ) ALLOCATE( sf_cd(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_cd, (/ sn_cdg /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) + ENDIF + ALLOCATE( cdn_wave(jpi,jpj) ) + cdn_wave(:,:) = 0._wp + ENDIF + IF( ln_charn ) THEN ! wave drag + IF( .NOT. cpl_charn ) THEN + CALL ctl_stop( 'STOP', 'Charnock based wind stress can be used in coupled mode only' ) + ENDIF + ALLOCATE( charn(jpi,jpj) ) + charn(:,:) = 0._wp + ENDIF + IF( ln_taw ) THEN ! wind stress + IF( .NOT. cpl_taw ) THEN + CALL ctl_stop( 'STOP', 'wind stress from wave model can be used in coupled mode only, use ln_cdgw instead' ) + ENDIF + ALLOCATE( tawx(jpi,jpj) ) + ALLOCATE( tawy(jpi,jpj) ) + ALLOCATE( twox(jpi,jpj) ) + ALLOCATE( twoy(jpi,jpj) ) + ALLOCATE( tauoc_wavex(jpi,jpj) ) + ALLOCATE( tauoc_wavey(jpi,jpj) ) + tawx(:,:) = 0._wp + tawy(:,:) = 0._wp + twox(:,:) = 0._wp + twoy(:,:) = 0._wp + tauoc_wavex(:,:) = 1._wp + tauoc_wavey(:,:) = 1._wp + ENDIF + + IF( ln_phioc ) THEN ! TKE flux + IF( .NOT. cpl_phioc ) THEN + CALL ctl_stop( 'STOP', 'phioc can be used in coupled mode only' ) + ENDIF + ALLOCATE( phioc(jpi,jpj) ) + phioc(:,:) = 0._wp + ENDIF + + IF( ln_tauoc ) THEN ! normalized wave stress into the ocean + IF( .NOT. cpl_wstrf ) THEN + ALLOCATE( sf_tauoc(1), STAT=ierror ) !* allocate and fill sf_wave with sn_tauoc + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_tauoc structure' ) + ! + ALLOCATE( sf_tauoc(1)%fnow(jpi,jpj,1) ) + IF( sn_tauoc%ln_tint ) ALLOCATE( sf_tauoc(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_tauoc, (/ sn_tauoc /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' ) + ENDIF + ALLOCATE( tauoc_wave(jpi,jpj) ) + tauoc_wave(:,:) = 0._wp + ENDIF + + IF( ln_sdw ) THEN ! Stokes drift + ! 1. Find out how many fields have to be read from file if not coupled + jpfld=0 + jp_usd=0 ; jp_vsd=0 ; jp_hsw=0 ; jp_wmp=0 + IF( .NOT. cpl_sdrftx ) THEN + jpfld = jpfld + 1 + jp_usd = jpfld + ENDIF + IF( .NOT. cpl_sdrfty ) THEN + jpfld = jpfld + 1 + jp_vsd = jpfld + ENDIF + IF( .NOT. cpl_hsig ) THEN + jpfld = jpfld + 1 + jp_hsw = jpfld + ENDIF + IF( .NOT. cpl_wper ) THEN + jpfld = jpfld + 1 + jp_wmp = jpfld + ENDIF + ! 2. Read from file only the non-coupled fields + IF( jpfld > 0 ) THEN + ALLOCATE( slf_i(jpfld) ) + IF( jp_usd > 0 ) slf_i(jp_usd) = sn_usd + IF( jp_vsd > 0 ) slf_i(jp_vsd) = sn_vsd + IF( jp_hsw > 0 ) slf_i(jp_hsw) = sn_hsw + IF( jp_wmp > 0 ) slf_i(jp_wmp) = sn_wmp + ALLOCATE( sf_sd(jpfld), STAT=ierror ) !* allocate and fill sf_sd with stokes drift + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) + ! + DO ifpr= 1, jpfld + ALLOCATE( sf_sd(ifpr)%fnow(jpi,jpj,1) ) + IF( slf_i(ifpr)%ln_tint ) ALLOCATE( sf_sd(ifpr)%fdta(jpi,jpj,1,2) ) + END DO + ! + CALL fld_fill( sf_sd, slf_i, cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) + sf_sd(jp_usd)%zsgn = -1._wp ; sf_sd(jp_vsd)%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn + ENDIF + ! + ! 3. Wave number (only needed for Qiao parametrisation, ln_zdfswm=T) + IF( .NOT. cpl_wnum ) THEN + ALLOCATE( sf_wn(1), STAT=ierror ) !* allocate and fill sf_wave with sn_wnum + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wn structure' ) + ALLOCATE( sf_wn(1)%fnow(jpi,jpj,1) ) + IF( sn_wnum%ln_tint ) ALLOCATE( sf_wn(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_wn, (/ sn_wnum /), cn_dir, 'sbc_wave', 'Wave module', 'namsbc_wave' ) + ENDIF + ! + ENDIF + ! + ENDIF + ! + END SUBROUTINE sbc_wave_init + + !!====================================================================== +END MODULE sbcwave diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/solfrac_mod.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/solfrac_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4c6e38609ab3542466a37441979a63216fdf995b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/solfrac_mod.f90 @@ -0,0 +1,69 @@ + + + + + + + + + + + + + +MODULE solfrac_mod + !!====================================================================== + !! *** MODULE solfrac *** + !! POSH representation of solar absorption (Gntermann, 2009) + !!===================================================================== + !! History : ! 11-10 (J. While) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! solfrac : function to calculate the solar fraction + !!---------------------------------------------------------------------- + + USE par_kind + IMPLICIT NONE + + ! Parameters + REAL(wp), PRIVATE, PARAMETER, DIMENSION(9) :: & + & pp_wgt = (/0.2370, 0.36, 0.1790, & + & 0.087, 0.08, 0.025, & + & 0.025, 0.007, 0.0004/) + REAL(wp), PRIVATE, PARAMETER, DIMENSION(9) :: & + & pp_len = (/34.84, 2.266, 0.0315, & + & 0.0055, 8.32e-4, 1.26e-4, & + & 3.13e-4, 7.82e-4, 1.44e-5/) + + PUBLIC solfrac + +CONTAINS + + REAL(dp) FUNCTION solfrac(ptop,pbottom) + !!---------------------------------------------------------------------- + !! *** ROUTINE solfrac *** + !! + !! ** Purpose : Calculate the solar fraction absorbed between two + !! layers + !! + !! ** Reference : POSH a model of diurnal warming, Gentemann et al, + !! JGR, 2009 + !!---------------------------------------------------------------------- + + ! Dummy variabes + REAL(wp), INTENT(IN) :: ptop, pbottom ! Top and bottom of layer + + ! local variables + INTEGER :: jt + + ! Calculate the solar fraction absorbed between the two layers + solfrac = 0._wp + DO jt = 1, 9 + solfrac = solfrac + pp_wgt(jt) * ( exp ( -ptop / pp_len(jt) ) & + & - exp ( -pbottom / pp_len(jt) ) ) + END DO + + END FUNCTION solfrac + +END MODULE solfrac_mod diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sshwzv.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sshwzv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1d868205ba3e629e3c794784108c2c6b06665218 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/sshwzv.f90 @@ -0,0 +1,420 @@ + + + + + + + + + + + + + +MODULE sshwzv + !!============================================================================== + !! *** MODULE sshwzv *** + !! Ocean dynamics : sea surface height and vertical velocity + !!============================================================================== + !! History : 3.1 ! 2009-02 (G. Madec, M. Leclair) Original code + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) modified LF-RA + !! - ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface + !! - ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module + !! 3.3 ! 2011-10 (M. Leclair) split former ssh_wzv routine and remove all vvl related work + !! 4.0 ! 2018-12 (A. Coward) add mixed implicit/explicit advection + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename ssh_nxt -> ssh_atf. Now only does time filtering. + !! - ! 2020-08 (S. Techene, G. Madec) add here ssh initiatlisation + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ssh_nxt : after ssh + !! ssh_atf : time filter the ssh arrays + !! wzv : compute now vertical velocity + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE isf_oce ! ice shelf + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! surface boundary condition: ocean + USE domvvl ! Variable volume + USE divhor ! horizontal divergence + USE phycst ! physical constants + USE bdy_oce , ONLY : ln_bdy, bdytmask ! Open BounDarY + USE bdydyn2d ! bdy_ssh routine + USE wet_dry ! Wetting/Drying flux limiting + ! + USE iom + USE in_out_manager ! I/O manager + USE restart ! only for lrst_oce + USE prtctl ! Print control + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC ssh_nxt ! called by step.F90 + PUBLIC wzv ! called by step.F90 + PUBLIC wAimp ! called by step.F90 + PUBLIC ssh_atf ! called by step.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sshwzv.F90 15150 2021-07-27 10:38:24Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ssh_nxt( kt, Kbb, Kmm, pssh, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ssh_nxt *** + !! + !! ** Purpose : compute the after ssh (ssh(Kaa)) + !! + !! ** Method : - Using the incompressibility hypothesis, the ssh increment + !! is computed by integrating the horizontal divergence and multiply by + !! by the time step. + !! + !! ** action : ssh(:,:,Kaa), after sea surface height + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpt), INTENT(inout) :: pssh ! sea-surface height + ! + INTEGER :: ji, jj, jk ! dummy loop index + REAL(wp) :: zcoef ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zhdiv ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('ssh_nxt') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ssh_nxt : after sea surface height' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + zcoef = 0.5_wp * r1_rho0 + + ! !------------------------------! + ! ! After Sea Surface Height ! + ! !------------------------------! + IF(ln_wd_il) THEN + CALL wad_lmt(pssh(:,:,Kbb), zcoef * (emp_b(:,:) + emp(:,:)), rDt, Kmm, uu, vv ) + ENDIF + + CALL div_hor( kt, Kbb, Kmm ) ! Horizontal divergence + ! + zhdiv(:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( nn_hls) ; DO ji = ntsi-( 1), ntei+( nn_hls) ! Horizontal divergence of barotropic transports + zhdiv(ji,jj) = zhdiv(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * hdiv(ji,jj,jk) + END DO ; END DO ; END DO + ! ! Sea surface elevation time stepping + ! In time-split case we need a first guess of the ssh after (using the baroclinic timestep) in order to + ! compute the vertical velocity which can be used to compute the non-linear terms of the momentum equations. + ! + DO jj = ntsj-( 1-( 1+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + 1)*ntht) ; DO ji = ntsi-( 1-( 1+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ 1)*nthr) ! Loop bounds limited by hdiv definition in div_hor + pssh(ji,jj,Kaa) = ( pssh(ji,jj,Kbb) - rDt * ( zcoef * ( emp_b(ji,jj) + emp(ji,jj) ) + zhdiv(ji,jj) ) ) * ssmask(ji,jj) + END DO ; END DO + ! pssh must be defined everywhere (true for dyn_spg_ts, not for dyn_spg_exp) + IF ( .NOT. ln_dynspg_ts .AND. nn_hls == 2 ) CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1.0_dp ) + ! + ! + IF ( .NOT.ln_dynspg_ts ) THEN + IF( ln_bdy ) THEN + IF (nn_hls==1) CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1.0_dp ) ! Not sure that's necessary + CALL bdy_ssh( pssh(:,:,Kaa) ) ! Duplicate sea level across open boundaries + ENDIF + ENDIF + ! !------------------------------! + ! ! outputs ! + ! !------------------------------! + ! + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pssh(:,:,Kaa), clinfo1=' pssh(:,:,Kaa) - : ', mask1=tmask ) + ! + IF( ln_timing ) CALL timing_stop('ssh_nxt') + ! + END SUBROUTINE ssh_nxt + + + SUBROUTINE wzv( kt, Kbb, Kmm, Kaa, pww ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wzv *** + !! + !! ** Purpose : compute the now vertical velocity + !! + !! ** Method : - Using the incompressibility hypothesis, the vertical + !! velocity is computed by integrating the horizontal divergence + !! from the bottom to the surface minus the scale factor evolution. + !! The boundary conditions are w=0 at the bottom (no flux) and. + !! + !! ** action : pww : now vertical velocity + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step + INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! time level indices + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pww ! vertical velocity at Kmm + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zhdiv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('wzv') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'wzv : now vertical velocity ' + IF(lwp) WRITE(numout,*) '~~~~~ ' + ! + pww(:,:,jpk) = 0._wp ! bottom boundary condition: w=0 (set once for all) + ENDIF + ! !------------------------------! + ! ! Now Vertical Velocity ! + ! !------------------------------! + ! + ! !===============================! + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN !== z_tilde and layer cases ==! + ! !===============================! + ALLOCATE( zhdiv(jpi,jpj,jpk) ) + ! + DO jk = 1, jpkm1 + ! horizontal divergence of thickness diffusion transport ( velocity multiplied by e3t) + ! - ML - note: computation already done in dom_vvl_sf_nxt. Could be optimized (not critical and clearer this way) + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls) + zhdiv(ji,jj,jk) = r1_e1e2t(ji,jj) * ( un_td(ji,jj,jk) - un_td(ji-1,jj,jk) + vn_td(ji,jj,jk) - vn_td(ji,jj-1,jk) ) + END DO ; END DO + END DO + IF( nn_hls == 1) CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.0_wp) ! - ML - Perhaps not necessary: not used for horizontal "connexions" + ! ! Is it problematic to have a wrong vertical velocity in boundary cells? + ! ! Same question holds for hdiv. Perhaps just for security + ! ! clem: yes it is a problem because ww is used in many other places where we need the halos + ! + DO jk = jpkm1, 1, -1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls) ! integrate from the bottom the hor. divergence + ! computation of w + pww(ji,jj,jk) = pww(ji,jj,jk+1) - ( (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * hdiv(ji,jj,jk) & + & + zhdiv(ji,jj,jk) & + & + r1_Dt * ( (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kaa)*tmask(ji,jj,jk))) & + & - (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kbb)*tmask(ji,jj,jk))) ) ) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! IF( ln_vvl_layer ) pww(:,:,:) = 0.e0 + DEALLOCATE( zhdiv ) + ! !=================================! + ELSEIF( ln_linssh ) THEN !== linear free surface cases ==! + ! !=================================! + DO jk = jpkm1, 1, -1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls) ! integrate from the bottom the hor. divergence + pww(ji,jj,jk) = pww(ji,jj,jk+1) - ( (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * hdiv(ji,jj,jk) ) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! !==========================================! + ELSE !== Quasi-Eulerian vertical coordinate ==! ('key_qco') + ! !==========================================! + DO jk = jpkm1, 1, -1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls) ! integrate from the bottom the hor. divergence + pww(ji,jj,jk) = pww(ji,jj,jk+1) - ( (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * hdiv(ji,jj,jk) & + & + r1_Dt * ( (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kaa)*tmask(ji,jj,jk))) & + & - (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kbb)*tmask(ji,jj,jk))) ) ) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + + IF( ln_bdy ) THEN + DO jk = 1, jpkm1 + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls) + pww(ji,jj,jk) = pww(ji,jj,jk) * bdytmask(ji,jj) + END DO ; END DO + END DO + ENDIF + ! + ! + IF( ln_timing ) CALL timing_stop('wzv') + ! + END SUBROUTINE wzv + + + SUBROUTINE ssh_atf( kt, Kbb, Kmm, Kaa, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ssh_atf *** + !! + !! ** Purpose : Apply Asselin time filter to now SSH. + !! + !! ** Method : - apply Asselin time fiter to now ssh (excluding the forcing + !! from the filter, see Leclair and Madec 2010) and swap : + !! pssh(:,:,Kmm) = pssh(:,:,Kaa) + rn_atfp * ( pssh(:,:,Kbb) -2 pssh(:,:,Kmm) + pssh(:,:,Kaa) ) + !! - rn_atfp * rn_Dt * ( emp_b - emp ) / rho0 + !! + !! ** action : - pssh(:,:,Kmm) time filtered + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpt), INTENT(inout) :: pssh ! SSH field + ! + REAL(wp) :: zcoef ! local scalar + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('ssh_atf') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ssh_atf : Asselin time filter of sea surface height' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + IF( .NOT.l_1st_euler ) THEN ! Apply Asselin time filter on Kmm field (not on euler 1st) + ! + IF( ln_linssh ) THEN ! filtered "now" field + pssh(:,:,Kmm) = pssh(:,:,Kmm) + rn_atfp * ( pssh(:,:,Kbb) - 2 * pssh(:,:,Kmm) + pssh(:,:,Kaa) ) + ! + ELSE ! filtered "now" field with forcing removed + zcoef = rn_atfp * rn_Dt * r1_rho0 + pssh(:,:,Kmm) = pssh(:,:,Kmm) + rn_atfp * ( pssh(:,:,Kbb) - 2 * pssh(:,:,Kmm) + pssh(:,:,Kaa) ) & + & - zcoef * ( emp_b(:,:) - emp(:,:) & + & - rnf_b(:,:) + rnf(:,:) & + & - fwfisf_cav_b(:,:) + fwfisf_cav(:,:) & + & - fwfisf_par_b(:,:) + fwfisf_par(:,:) ) * ssmask(:,:) + + ! ice sheet coupling + IF( ln_isf .AND. ln_isfcpl .AND. kt == nit000+1 ) & + & pssh(:,:,Kbb) = pssh(:,:,Kbb) - rn_atfp * rn_Dt * ( risfcpl_ssh(:,:) - 0._wp ) * ssmask(:,:) + + ENDIF + ENDIF + ! + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pssh(:,:,Kmm), clinfo1=' atf - pssh(:,:,Kmm): ', mask1=tmask ) + ! + IF( ln_timing ) CALL timing_stop('ssh_atf') + ! + END SUBROUTINE ssh_atf + + + SUBROUTINE wAimp( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wAimp *** + !! + !! ** Purpose : compute the Courant number and partition vertical velocity + !! if a proportion needs to be treated implicitly + !! + !! ** Method : - + !! + !! ** action : ww : now vertical velocity (to be handled explicitly) + !! : wi : now vertical velocity (for implicit treatment) + !! + !! Reference : Shchepetkin, A. F. (2015): An adaptive, Courant-number-dependent + !! implicit scheme for vertical advection in oceanic modeling. + !! Ocean Modelling, 91, 38-69. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zCu, zcff, z1_e3t, zdt ! local scalars + REAL(wp) , PARAMETER :: Cu_min = 0.15_wp ! local parameters + REAL(wp) , PARAMETER :: Cu_max = 0.30_wp ! local parameters + REAL(wp) , PARAMETER :: Cu_cut = 2._wp*Cu_max - Cu_min ! local parameters + REAL(wp) , PARAMETER :: Fcu = 4._wp*Cu_max*(Cu_max-Cu_min) ! local parameters + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('wAimp') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'wAimp : Courant number-based partitioning of now vertical velocity ' + IF(lwp) WRITE(numout,*) '~~~~~ ' + ENDIF + ! + ! Calculate Courant numbers + zdt = 2._wp * rn_Dt ! 2*rn_Dt and not rDt (for restartability) + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls) + z1_e3t = 1._wp / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + Cu_adv(ji,jj,jk) = zdt * & + & ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) ) & + & + ( MAX( e2u(ji ,jj) * (e3u_0(ji ,jj,jk)*(1._wp+r3u(ji ,jj,Kmm)*umask(ji ,jj,jk))) & + & * uu (ji ,jj,jk,Kmm) + un_td(ji ,jj,jk), 0._wp ) - & + & MIN( e2u(ji-1,jj) * (e3u_0(ji-1,jj,jk)*(1._wp+r3u(ji-1,jj,Kmm)*umask(ji-1,jj,jk))) & + & * uu (ji-1,jj,jk,Kmm) + un_td(ji-1,jj,jk), 0._wp ) ) & + & * r1_e1e2t(ji,jj) & + & + ( MAX( e1v(ji,jj ) * (e3v_0(ji,jj ,jk)*(1._wp+r3v(ji,jj ,Kmm)*vmask(ji,jj ,jk))) & + & * vv (ji,jj ,jk,Kmm) + vn_td(ji,jj ,jk), 0._wp ) - & + & MIN( e1v(ji,jj-1) * (e3v_0(ji,jj-1,jk)*(1._wp+r3v(ji,jj-1,Kmm)*vmask(ji,jj-1,jk))) & + & * vv (ji,jj-1,jk,Kmm) + vn_td(ji,jj-1,jk), 0._wp ) ) & + & * r1_e1e2t(ji,jj) & + & ) * z1_e3t + END DO ; END DO ; END DO + ELSE + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls) + z1_e3t = 1._wp / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + Cu_adv(ji,jj,jk) = zdt * & + & ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) ) & + & + ( MAX( e2u(ji ,jj)*(e3u_0(ji ,jj,jk)*(1._wp+r3u(ji ,jj,Kmm)*umask(ji ,jj,jk)))*uu(ji ,jj,jk,Kmm), 0._wp ) - & + & MIN( e2u(ji-1,jj)*(e3u_0(ji-1,jj,jk)*(1._wp+r3u(ji-1,jj,Kmm)*umask(ji-1,jj,jk)))*uu(ji-1,jj,jk,Kmm), 0._wp ) ) & + & * r1_e1e2t(ji,jj) & + & + ( MAX( e1v(ji,jj )*(e3v_0(ji,jj ,jk)*(1._wp+r3v(ji,jj ,Kmm)*vmask(ji,jj ,jk)))*vv(ji,jj ,jk,Kmm), 0._wp ) - & + & MIN( e1v(ji,jj-1)*(e3v_0(ji,jj-1,jk)*(1._wp+r3v(ji,jj-1,Kmm)*vmask(ji,jj-1,jk)))*vv(ji,jj-1,jk,Kmm), 0._wp ) ) & + & * r1_e1e2t(ji,jj) & + & ) * z1_e3t + END DO ; END DO ; END DO + ENDIF + CALL iom_put("Courant",Cu_adv) + ! + IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN ! Quick check if any breaches anywhere + DO jk = jpkm1, 2, -1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls) ! or scan Courant criterion and partition ! w where necessary + ! + zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) +! alt: +! IF ( ww(ji,jj,jk) > 0._wp ) THEN +! zCu = Cu_adv(ji,jj,jk) +! ELSE +! zCu = Cu_adv(ji,jj,jk-1) +! ENDIF + ! + IF( zCu <= Cu_min ) THEN !<-- Fully explicit + zcff = 0._wp + ELSEIF( zCu < Cu_cut ) THEN !<-- Mixed explicit + zcff = ( zCu - Cu_min )**2 + zcff = zcff / ( Fcu + zcff ) + ELSE !<-- Mostly implicit + zcff = ( zCu - Cu_max )/ zCu + ENDIF + zcff = MIN(1._wp, zcff) + ! + wi(ji,jj,jk) = zcff * ww(ji,jj,jk) + ww(ji,jj,jk) = ( 1._wp - zcff ) * ww(ji,jj,jk) + ! + Cu_adv(ji,jj,jk) = zcff ! Reuse array to output coefficient below and in stp_ctl + END DO ; END DO ; END DO + Cu_adv(:,:,1) = 0._wp + ELSE + ! Fully explicit everywhere + Cu_adv(:,:,:) = 0._wp ! Reuse array to output coefficient below and in stp_ctl + wi (:,:,:) = 0._wp + ENDIF + CALL iom_put("wimp",wi) + CALL iom_put("wi_cff",Cu_adv) + CALL iom_put("wexp",ww) + ! + IF( ln_timing ) CALL timing_stop('wAimp') + ! + END SUBROUTINE wAimp + + !!====================================================================== +END MODULE sshwzv diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/step.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/step.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d448b0042314867b7965b0e88f9f60135d3205a4 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/step.f90 @@ -0,0 +1,55 @@ + + + + + + + + + + + + + +MODULE step + !!====================================================================== + !! *** MODULE step *** + !! Time-stepping : manager of the ocean, tracer and ice time stepping + !!====================================================================== + !! History : OPA ! 1991-03 (G. Madec) Original code + !! - ! 1991-11 (G. Madec) + !! - ! 1992-06 (M. Imbard) add a first output record + !! - ! 1996-04 (G. Madec) introduction of dynspg + !! - ! 1996-04 (M.A. Foujols) introduction of passive tracer + !! 8.0 ! 1997-06 (G. Madec) new architecture of call + !! 8.2 ! 1997-06 (G. Madec, M. Imbard, G. Roullet) free surface + !! - ! 1999-02 (G. Madec, N. Grima) hpg implicit + !! - ! 2000-07 (J-M Molines, M. Imbard) Open Bondary Conditions + !! NEMO 1.0 ! 2002-06 (G. Madec) free form, suppress macro-tasking + !! - ! 2004-08 (C. Talandier) New trends organization + !! - ! 2005-01 (C. Ethe) Add the KPP closure scheme + !! - ! 2005-11 (G. Madec) Reorganisation of tra and dyn calls + !! - ! 2006-01 (L. Debreu, C. Mazauric) Agrif implementation + !! - ! 2006-07 (S. Masson) restart using iom + !! 3.2 ! 2009-02 (G. Madec, R. Benshila) reintroduicing z*-coordinate + !! - ! 2009-06 (S. Masson, G. Madec) TKE restart compatible with key_cpl + !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface + !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA + !! 3.4 ! 2011-04 (G. Madec, C. Ethe) Merge of dtatem and dtasal + !! 3.6 ! 2012-07 (J. Simeon, G. Madec. C. Ethe) Online coarsening of outputs + !! 3.6 ! 2014-04 (F. Roquet, G. Madec) New equations of state + !! 3.6 ! 2014-10 (E. Clementi, P. Oddo) Add Qiao vertical mixing in case of waves + !! 3.7 ! 2014-10 (G. Madec) LDF simplication + !! - ! 2014-12 (G. Madec) remove KPP scheme + !! - ! 2015-11 (J. Chanut) free surface simplification (remove filtered free surface) + !! 4.0 ! 2017-05 (G. Madec) introduction of the vertical physics manager (zdfphy) + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rewrite in preparation for new timestepping scheme + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordinate + !! OR + !! 'key_linssh EMPTY MODULE Fixed in time vertical coordinate + !!---------------------------------------------------------------------- + !!====================================================================== +END MODULE step diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/step_diu.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/step_diu.f90 new file mode 100644 index 0000000000000000000000000000000000000000..685cdf94806d3ac204a2e8c445820a0518ae4c08 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/step_diu.f90 @@ -0,0 +1,95 @@ + + + + + + + + + + + + + +MODULE step_diu + !!====================================================================== + !! *** MODULE stp_diu *** + !! Time-stepping of diurnal cycle models + !!====================================================================== + !! History : 3.7 ! 2015-11 (J. While) Original code + + USE diu_layers ! diurnal SST bulk and coolskin routines + USE iom + USE sbc_oce + USE sbcmod ! surface boundary condition (sbc routine) + USE diaobs ! Observation operator + USE oce + USE daymod + USE restart ! ocean restart (rst_wri routine) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC stp_diurnal ! called by nemogcm.F90 or step.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: step_diu.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + CONTAINS + + SUBROUTINE stp_diurnal( kstp ) + INTEGER, INTENT(in) :: kstp ! ocean time-step index + !!---------------------------------------------------------------------- + !! *** ROUTINE stp_diurnal *** + !! + !! ** Purpose : - Time stepping of diurnal SST model only + !! + !! ** Method : -1- Update forcings and data + !! -2- Update ocean physics + !! -3- Compute the t and s trends + !! -4- Update t and s + !! -5- Compute the momentum trends + !! -6- Update the horizontal velocity + !! -7- Compute the diagnostics variables (rd,N2, div,cur,w) + !! -8- Outputs and diagnostics + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indices + INTEGER :: indic ! error indicator if < 0 + REAL(wp), DIMENSION(jpi,jpj) :: z_fvel_bkginc, z_hflux_bkginc + INTEGER :: Nbb, Nnn, Naa, Nrhs ! local definitions as placeholders for now + !! --------------------------------------------------------------------- + + IF(ln_diurnal_only) THEN + indic = 0 ! reset to no error condition + IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) + + CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell iom we are at time step kstp + IF( ln_crs ) THEN + CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" ) ! tell iom we are at time step kstp + ENDIF + + CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Conditions + ENDIF + + call diurnal_layers( kstp ) ! coolskin and warm layer calculations + + IF( ln_diurnal_only ) THEN + ! WILL HAVE TO INCREMENT Nbb and Nnn here in ln_diurnal_only case ! + IF( ln_diaobs ) CALL dia_obs( kstp, Nnn ) ! obs-minus-model (assimilation) diagnostics (call after dynamics update) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Control and restarts + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file + IF( lrst_oce ) CALL rst_write ( kstp, Nbb, Nnn ) ! write output ocean restart file + + IF( ln_timing .AND. kstp == nit000 ) CALL timing_reset + ENDIF + + END SUBROUTINE stp_diurnal + +END MODULE step_diu diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/step_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/step_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dc1e7d926b09650f779c9460a6eb10a495aa1b17 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/step_oce.f90 @@ -0,0 +1,126 @@ + + + + + + + + + + + + + +MODULE step_oce + !!====================================================================== + !! *** MODULE step_oce *** + !! Ocean time-stepping : module used in both initialisation phase and time stepping + !! (i.e. nemo_init and stp or stp_MLF routines) + !!====================================================================== + !! History : 3.3 ! 2010-08 (C. Ethe) Original code - reorganisation of the initial phase + !! 3.7 ! 2014-01 (G. Madec) LDF simplication + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE domtile + + USE daymod ! calendar (day routine) + + USE sbc_oce ! surface boundary condition: ocean + USE sbcmod ! surface boundary condition (sbc routine) + USE sbcrnf ! surface boundary condition: runoff variables + USE sbccpl ! surface boundary condition: coupled formulation (call send at end of step) + USE sbcapr ! surface boundary condition: atmospheric pressure + USE sbcwave ! Wave intialisation + USE tide_mod ! tides + + USE bdy_oce , ONLY : ln_bdy + USE bdydta ! open boundary condition data (bdy_dta routine) + USE bdytra ! bdy cond. for tracers (bdy_tra routine) + USE bdydyn3d ! bdy cond. for baroclinic vel. (bdy_dyn3d routine) + + USE isf_oce ! ice shelf boundary condition + USE isfstp ! ice shelf boundary condition (isf_stp routine) + + USE sshwzv ! vertical velocity and ssh (ssh_nxt routine) + ! (ssh_swp routine) + ! (wzv routine) + USE domvvl ! variable vertical scale factors (dom_vvl_sf_nxt routine) + ! (dom_vvl_sf_swp routine) + + USE divhor ! horizontal divergence (div_hor routine) + USE dynadv ! advection (dyn_adv routine) + USE dynvor ! vorticity term (dyn_vor routine) + USE dynhpg ! hydrostatic pressure grad. (dyn_hpg routine) + USE dynldf ! lateral momentum diffusion (dyn_ldf routine) + USE dynzdf ! vertical diffusion (dyn_zdf routine) + USE dynspg ! surface pressure gradient (dyn_spg routine) + USE dynatf ! time-filtering (dyn_atf routine) + USE dyndmp ! current damping (dyn_dmp routine) + + USE traqsr ! solar radiation penetration (tra_qsr routine) + USE traisf ! ice shelf (tra_isf routine) + USE trasbc ! surface boundary condition (tra_sbc routine) + USE trabbc ! bottom boundary condition (tra_bbc routine) + USE trabbl ! bottom boundary layer (tra_bbl routine) + USE tradmp ! internal damping (tra_dmp routine) + USE traadv ! advection scheme control (tra_adv_ctl routine) + USE traldf ! lateral mixing (tra_ldf routine) + USE trazdf ! vertical mixing (tra_zdf routine) + USE traatf ! time filtering (tra_atf routine) + USE tranpc ! non-penetrative convection (tra_npc routine) + + USE eosbn2 ! equation of state (eos_bn2 routine) + + USE stopar ! Stochastic parametrization (sto_par routine) + USE stopts + + USE ldfslp ! iso-neutral slopes (ldf_slp routine) + USE ldfdyn ! lateral eddy viscosity coef. (ldf_dyn routine) + USE ldftra ! lateral eddy diffusive coef. (ldf_tra routine) + + USE zdf_oce ! ocean vertical physics variables + USE zdfphy ! vertical physics manager (zdf_phy_init routine) + USE zdfdrg , ONLY : ln_drgimp ! implicit top/bottom friction + USE zdfosm , ONLY : osm_rst, dyn_osm, tra_osm ! OSMOSIS routines used in step.F90 + USE zdfmfc ! Mass FLux Convection routine used in step.F90 + + USE diu_layers ! diurnal SST bulk and coolskin routines + USE sbc_oce ! surface fluxes + + USE zpshde ! partial step: hor. derivative (zps_hde routine) + + USE diawri ! Standard run outputs (dia_wri routine) + USE diaptr ! poleward transports (dia_ptr routine) + USE diadct ! sections transports (dia_dct routine) + USE diaar5 ! AR5 diagnosics (dia_ar5 routine) + USE diahth ! thermocline depth (dia_hth routine) + USE diahsb ! heat, salt and volume budgets (dia_hsb routine) + USE diacfl ! CFL diagnostics (dia_cfl routine) + USE diaobs ! Observation operator (dia_obs routine) + USE diadetide ! Weights computation for daily detiding of model diagnostics + USE diamlr ! IOM context management for multiple-linear-regression analysis + USE flo_oce ! floats variables + USE floats ! floats computation (flo_stp routine) + + USE crsfld ! Standard output on coarse grid (crs_fld routine) + + USE asminc ! assimilation increments (tra_asm_inc routine) + ! (dyn_asm_inc routine) + USE asmbkg ! writing out state trajectory + USE stpctl ! time stepping control (stp_ctl routine) + USE restart ! ocean restart (rst_wri routine) + USE prtctl ! Print control (prt_ctl routine) + + USE in_out_manager ! I/O manager + USE iom ! + USE lbclnk + USE timing ! Timing + + USE xios ! I/O server + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: step_oce.F90 15023 2021-06-18 14:35:25Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE step_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stopar.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stopar.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8d1f95bc4083eef011ee419d4dc53e230edcaccf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stopar.f90 @@ -0,0 +1,933 @@ + + + + + + + + + + + + + +MODULE stopar + !!====================================================================== + !! *** MODULE stopar *** + !! Stochastic parameters : definition and time stepping + !!===================================================================== + !! History : 3.3 ! 2011-10 (J.-M. Brankart) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sto_par : update the stochastic parameters + !! sto_par_init : define the stochastic parameterization + !! sto_rst_read : read restart file for stochastic parameters + !! sto_rst_write : write restart file for stochastic parameters + !! sto_par_white : fill input array with white Gaussian noise + !! sto_par_flt : apply horizontal Laplacian filter to input array + !!---------------------------------------------------------------------- + USE storng ! random number generator (external module) + USE par_oce ! ocean parameters + USE dom_oce ! ocean space and time domain variables + USE lbclnk ! lateral boundary conditions (or mpp link) + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE lib_mpp + + + IMPLICIT NONE + PRIVATE + + PUBLIC sto_par_init ! called by nemogcm.F90 + PUBLIC sto_par ! called by step.F90 + PUBLIC sto_rst_write ! called by step.F90 + + LOGICAL :: ln_rststo = .FALSE. ! restart stochastic parameters from restart file + LOGICAL :: ln_rstseed = .FALSE. ! read seed of RNG from restart file + CHARACTER(len=32) :: cn_storst_in = "restart_sto" ! suffix of sto restart name (input) + CHARACTER(len=32) :: cn_storst_out = "restart_sto" ! suffix of sto restart name (output) + INTEGER :: numstor, numstow ! logical unit for restart (read and write) + + INTEGER :: jpsto2d = 0 ! number of 2D stochastic parameters + INTEGER :: jpsto3d = 0 ! number of 3D stochastic parameters + + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: sto2d ! 2D stochastic parameters + REAL(wp), PUBLIC, DIMENSION(:,:,:,:), ALLOCATABLE :: sto3d ! 3D stochastic parameters + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sto_tmp ! temporary workspace + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sto2d_abc ! a, b, c parameters (for 2D arrays) + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sto3d_abc ! a, b, c parameters (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_ave ! mean value (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_ave ! mean value (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_std ! standard deviation (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_std ! standard deviation (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_lim ! limitation factor (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_lim ! limitation factor (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_tcor ! time correlation (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_tcor ! time correlation (for 3D arrays) + INTEGER, DIMENSION(:), ALLOCATABLE :: sto2d_ord ! order of autoregressive process + INTEGER, DIMENSION(:), ALLOCATABLE :: sto3d_ord ! order of autoregressive process + + CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: sto2d_typ ! nature of grid point (T, U, V, W, F, I) + CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: sto3d_typ ! nature of grid point (T, U, V, W, F, I) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_sgn ! control of the sign accross the north fold + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_sgn ! control of the sign accross the north fold + INTEGER, DIMENSION(:), ALLOCATABLE :: sto2d_flt ! number of passes of Laplacian filter + INTEGER, DIMENSION(:), ALLOCATABLE :: sto3d_flt ! number of passes of Laplacian filter + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_fac ! factor to restore std after filtering + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_fac ! factor to restore std after filtering + + LOGICAL, PUBLIC :: ln_sto_ldf = .FALSE. ! stochastic lateral diffusion + INTEGER, PUBLIC :: jsto_ldf ! index of lateral diffusion stochastic parameter + REAL(wp) :: rn_ldf_std ! lateral diffusion standard deviation (in percent) + REAL(wp) :: rn_ldf_tcor ! lateral diffusion correlation timescale (in timesteps) + + LOGICAL, PUBLIC :: ln_sto_hpg = .FALSE. ! stochastic horizontal pressure gradient + INTEGER, PUBLIC :: jsto_hpgi ! index of stochastic hpg parameter (i direction) + INTEGER, PUBLIC :: jsto_hpgj ! index of stochastic hpg parameter (j direction) + REAL(wp) :: rn_hpg_std ! density gradient standard deviation (in percent) + REAL(wp) :: rn_hpg_tcor ! density gradient correlation timescale (in timesteps) + + LOGICAL, PUBLIC :: ln_sto_pstar = .FALSE. ! stochastic ice strength + INTEGER, PUBLIC :: jsto_pstar ! index of stochastic ice strength + REAL(wp), PUBLIC:: rn_pstar_std ! ice strength standard deviation (in percent) + REAL(wp) :: rn_pstar_tcor ! ice strength correlation timescale (in timesteps) + INTEGER :: nn_pstar_flt = 0 ! number of passes of Laplacian filter + INTEGER :: nn_pstar_ord = 1 ! order of autoregressive processes + + LOGICAL, PUBLIC :: ln_sto_trd = .FALSE. ! stochastic model trend + INTEGER, PUBLIC :: jsto_trd ! index of stochastic trend parameter + REAL(wp) :: rn_trd_std ! trend standard deviation (in percent) + REAL(wp) :: rn_trd_tcor ! trend correlation timescale (in timesteps) + + LOGICAL, PUBLIC :: ln_sto_eos = .FALSE. ! stochastic equation of state + INTEGER, PUBLIC :: nn_sto_eos = 1 ! number of degrees of freedom in stochastic equation of state + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosi ! index of stochastic eos parameter (i direction) + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosj ! index of stochastic eos parameter (j direction) + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosk ! index of stochastic eos parameter (k direction) + REAL(wp) :: rn_eos_stdxy ! random walk horz. standard deviation (in grid points) + REAL(wp) :: rn_eos_stdz ! random walk vert. standard deviation (in grid points) + REAL(wp) :: rn_eos_tcor ! random walk correlation timescale (in timesteps) + REAL(wp) :: rn_eos_lim = 3.0_wp ! limitation factor + INTEGER :: nn_eos_flt = 0 ! number of passes of Laplacian filter + INTEGER :: nn_eos_ord = 1 ! order of autoregressive processes + + LOGICAL, PUBLIC :: ln_sto_trc = .FALSE. ! stochastic tracer dynamics + INTEGER, PUBLIC :: nn_sto_trc = 1 ! number of degrees of freedom in stochastic tracer dynamics + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trci ! index of stochastic trc parameter (i direction) + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trcj ! index of stochastic trc parameter (j direction) + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trck ! index of stochastic trc parameter (k direction) + REAL(wp) :: rn_trc_stdxy ! random walk horz. standard deviation (in grid points) + REAL(wp) :: rn_trc_stdz ! random walk vert. standard deviation (in grid points) + REAL(wp) :: rn_trc_tcor ! random walk correlation timescale (in timesteps) + REAL(wp) :: rn_trc_lim = 3.0_wp ! limitation factor + INTEGER :: nn_trc_flt = 0 ! number of passes of Laplacian filter + INTEGER :: nn_trc_ord = 1 ! order of autoregressive processes + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: stopar.F90 13295 2020-07-10 18:24:21Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sto_par( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_par *** + !! + !! ** Purpose : update the stochastic parameters + !! + !! ** Method : model basic stochastic parameters + !! as a first order autoregressive process AR(1), + !! governed by the equation: + !! X(t) = a * X(t-1) + b * w + c + !! where the parameters a, b and c are related + !! to expected value, standard deviation + !! and time correlation (all stationary in time) by: + !! E [X(t)] = c / ( 1 - a ) + !! STD [X(t)] = b / SQRT( 1 - a * a ) + !! COR [X(t),X(t-k)] = a ** k + !! and w is a Gaussian white noise. + !! + !! Higher order autoregressive proces can be optionally generated + !! by replacing the white noise by a lower order process. + !! + !! 1) The statistics of the stochastic parameters (X) are assumed + !! constant in space (homogeneous) and time (stationary). + !! This could be generalized by replacing the constant + !! a, b, c parameters by functions of space and time. + !! + !! 2) The computation is performed independently for every model + !! grid point, which corresponds to assume that the stochastic + !! parameters are uncorrelated in space. + !! This could be generalized by including a spatial filter: Y = Filt[ X ] + !! (possibly non-homgeneous and non-stationary) in the computation, + !! or by solving an elliptic equation: L[ Y ] = X. + !! + !! 3) The stochastic model for the parameters could also + !! be generalized to depend on the current state of the ocean (not done here). + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk, jsto, jflt + REAL(wp) :: stomax + !!---------------------------------------------------------------------- + ! + ! Update 2D stochastic arrays + ! + DO jsto = 1, jpsto2d + ! Store array from previous time step + sto_tmp(:,:) = sto2d(:,:,jsto) + + IF ( sto2d_ord(jsto) == 1 ) THEN + ! Draw new random numbers from N(0,1) --> w + CALL sto_par_white( sto2d(:,:,jsto) ) + ! Apply horizontal Laplacian filter to w + DO jflt = 1, sto2d_flt(jsto) + CALL lbc_lnk( 'stopar', sto2d(:,:,jsto), sto2d_typ(jsto), sto2d_sgn(jsto) ) + CALL sto_par_flt( sto2d(:,:,jsto) ) + END DO + ! Factor to restore standard deviation after filtering + sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_fac(jsto) + ELSE + ! Use previous process (one order lower) instead of white noise + sto2d(:,:,jsto) = sto2d(:,:,jsto-1) + ENDIF + + ! Multiply white noise (or lower order process) by b --> b * w + sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_abc(jsto,2) + ! Update autoregressive processes --> a * X(t-1) + b * w + sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto_tmp(:,:) * sto2d_abc(jsto,1) + ! Add parameter c --> a * X(t-1) + b * w + c + sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto2d_abc(jsto,3) + ! Limit random parameter anomalies to std times the limitation factor + stomax = sto2d_std(jsto) * sto2d_lim(jsto) + sto2d(:,:,jsto) = sto2d(:,:,jsto) - sto2d_ave(jsto) + sto2d(:,:,jsto) = SIGN(MIN(stomax,ABS(sto2d(:,:,jsto))),sto2d(:,:,jsto)) + sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto2d_ave(jsto) + + ! Lateral boundary conditions on sto2d + CALL lbc_lnk( 'stopar', sto2d(:,:,jsto), sto2d_typ(jsto), sto2d_sgn(jsto) ) + END DO + ! + ! Update 3D stochastic arrays + ! + DO jsto = 1, jpsto3d + DO jk = 1, jpk + ! Store array from previous time step + sto_tmp(:,:) = sto3d(:,:,jk,jsto) + + IF ( sto3d_ord(jsto) == 1 ) THEN + ! Draw new random numbers from N(0,1) --> w + CALL sto_par_white( sto3d(:,:,jk,jsto) ) + ! Apply horizontal Laplacian filter to w + DO jflt = 1, sto3d_flt(jsto) + CALL lbc_lnk( 'stopar', sto3d(:,:,jk,jsto), sto3d_typ(jsto), sto3d_sgn(jsto) ) + CALL sto_par_flt( sto3d(:,:,jk,jsto) ) + END DO + ! Factor to restore standard deviation after filtering + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_fac(jsto) + ELSE + ! Use previous process (one order lower) instead of white noise + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto-1) + ENDIF + + ! Multiply white noise by b --> b * w + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_abc(jsto,2) + ! Update autoregressive processes --> a * X(t-1) + b * w + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto_tmp(:,:) * sto3d_abc(jsto,1) + ! Add parameter c --> a * X(t-1) + b * w + c + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto3d_abc(jsto,3) + ! Limit random parameters anomalies to std times the limitation factor + stomax = sto3d_std(jsto) * sto3d_lim(jsto) + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) - sto3d_ave(jsto) + sto3d(:,:,jk,jsto) = SIGN(MIN(stomax,ABS(sto3d(:,:,jk,jsto))),sto3d(:,:,jk,jsto)) + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto3d_ave(jsto) + END DO + ! Lateral boundary conditions on sto3d + CALL lbc_lnk( 'stopar', sto3d(:,:,:,jsto), sto3d_typ(jsto), sto3d_sgn(jsto) ) + END DO + ! + END SUBROUTINE sto_par + + + SUBROUTINE sto_par_init + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_par_init *** + !! + !! ** Purpose : define the stochastic parameterization + !!---------------------------------------------------------------------- + NAMELIST/namsto/ ln_sto_ldf, rn_ldf_std, rn_ldf_tcor, & + & ln_sto_hpg, rn_hpg_std, rn_hpg_tcor, & + & ln_sto_pstar, rn_pstar_std, rn_pstar_tcor, nn_pstar_flt, nn_pstar_ord, & + & ln_sto_trd, rn_trd_std, rn_trd_tcor, & + & ln_sto_eos, nn_sto_eos, rn_eos_stdxy, rn_eos_stdz, & + & rn_eos_tcor, nn_eos_ord, nn_eos_flt, rn_eos_lim, & + & ln_sto_trc, nn_sto_trc, rn_trc_stdxy, rn_trc_stdz, & + & rn_trc_tcor, nn_trc_ord, nn_trc_flt, rn_trc_lim, & + & ln_rststo, ln_rstseed, cn_storst_in, cn_storst_out + !!---------------------------------------------------------------------- + INTEGER :: jsto, jmem, jarea, jdof, jord, jordm1, jk, jflt + INTEGER(KIND=8) :: zseed1, zseed2, zseed3, zseed4 + REAL(wp) :: rinflate + INTEGER :: ios ! Local integer output status for namelist read + + ! Read namsto namelist : stochastic parameterization + READ ( numnam_ref, namsto, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsto in reference namelist' ) + + READ ( numnam_cfg, namsto, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsto in configuration namelist' ) + IF(lwm) WRITE ( numond, namsto ) + + IF( .NOT.ln_sto_eos ) THEN ! no use of stochastic parameterization + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sto_par_init : NO use of stochastic parameterization' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + RETURN + ENDIF + + !IF(ln_ens_rst_in) cn_storst_in = cn_mem//cn_storst_in + + ! Parameter print + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sto_par_init : stochastic parameterization' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namsto : stochastic parameterization' + WRITE(numout,*) ' restart stochastic parameters ln_rststo = ', ln_rststo + WRITE(numout,*) ' read seed of RNG from restart file ln_rstseed = ', ln_rstseed + WRITE(numout,*) ' suffix of sto restart name (input) cn_storst_in = ', cn_storst_in + WRITE(numout,*) ' suffix of sto restart name (output) cn_storst_out = ', cn_storst_out + + ! WRITE(numout,*) ' stochastic lateral diffusion ln_sto_ldf = ', ln_sto_ldf + ! WRITE(numout,*) ' lateral diffusion std (in percent) rn_ldf_std = ', rn_ldf_std + ! WRITE(numout,*) ' lateral diffusion tcor (in timesteps) rn_ldf_tcor = ', rn_ldf_tcor + + ! WRITE(numout,*) ' stochastic horizontal pressure gradient ln_sto_hpg = ', ln_sto_hpg + ! WRITE(numout,*) ' density gradient std (in percent) rn_hpg_std = ', rn_hpg_std + ! WRITE(numout,*) ' density gradient tcor (in timesteps) rn_hpg_tcor = ', rn_hpg_tcor + + ! WRITE(numout,*) ' stochastic ice strength ln_sto_pstar = ', ln_sto_pstar + ! WRITE(numout,*) ' ice strength std (in percent) rn_pstar_std = ', rn_pstar_std + ! WRITE(numout,*) ' ice strength tcor (in timesteps) rn_pstar_tcor = ', rn_pstar_tcor + ! WRITE(numout,*) ' order of autoregressive processes nn_pstar_ord = ', nn_pstar_ord + ! WRITE(numout,*) ' passes of Laplacian filter nn_pstar_flt = ', nn_pstar_flt + + !WRITE(numout,*) ' stochastic trend ln_sto_trd = ', ln_sto_trd + !WRITE(numout,*) ' trend std (in percent) rn_trd_std = ', rn_trd_std + !WRITE(numout,*) ' trend tcor (in timesteps) rn_trd_tcor = ', rn_trd_tcor + + WRITE(numout,*) ' stochastic equation of state ln_sto_eos = ', ln_sto_eos + WRITE(numout,*) ' number of degrees of freedom nn_sto_eos = ', nn_sto_eos + WRITE(numout,*) ' random walk horz. std (in grid points) rn_eos_stdxy = ', rn_eos_stdxy + WRITE(numout,*) ' random walk vert. std (in grid points) rn_eos_stdz = ', rn_eos_stdz + WRITE(numout,*) ' random walk tcor (in timesteps) rn_eos_tcor = ', rn_eos_tcor + WRITE(numout,*) ' order of autoregressive processes nn_eos_ord = ', nn_eos_ord + WRITE(numout,*) ' passes of Laplacian filter nn_eos_flt = ', nn_eos_flt + WRITE(numout,*) ' limitation factor rn_eos_lim = ', rn_eos_lim + + ! WRITE(numout,*) ' stochastic tracers dynamics ln_sto_trc = ', ln_sto_trc + ! WRITE(numout,*) ' number of degrees of freedom nn_sto_trc = ', nn_sto_trc + ! WRITE(numout,*) ' random walk horz. std (in grid points) rn_trc_stdxy = ', rn_trc_stdxy + ! WRITE(numout,*) ' random walk vert. std (in grid points) rn_trc_stdz = ', rn_trc_stdz + ! WRITE(numout,*) ' random walk tcor (in timesteps) rn_trc_tcor = ', rn_trc_tcor + ! WRITE(numout,*) ' order of autoregressive processes nn_trc_ord = ', nn_trc_ord + ! WRITE(numout,*) ' passes of Laplacian filter nn_trc_flt = ', nn_trc_flt + ! WRITE(numout,*) ' limitation factor rn_trc_lim = ', rn_trc_lim + + ENDIF + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' stochastic parameterization :' + + ! Set number of 2D stochastic arrays + jpsto2d = 0 + IF( ln_sto_ldf ) THEN + IF(lwp) WRITE(numout,*) ' - stochastic lateral diffusion' + jpsto2d = jpsto2d + 1 + jsto_ldf = jpsto2d + ENDIF + IF( ln_sto_pstar ) THEN + IF(lwp) WRITE(numout,*) ' - stochastic ice strength' + jpsto2d = jpsto2d + 1 * nn_pstar_ord + jsto_pstar = jpsto2d + ENDIF + IF( ln_sto_eos ) THEN + IF ( lk_agrif ) CALL ctl_stop('EOS stochastic parametrization is not compatible with AGRIF') + IF(lwp) WRITE(numout,*) ' - stochastic equation of state' + ALLOCATE(jsto_eosi(nn_sto_eos)) + ALLOCATE(jsto_eosj(nn_sto_eos)) + ALLOCATE(jsto_eosk(nn_sto_eos)) + DO jdof = 1, nn_sto_eos + jpsto2d = jpsto2d + 3 * nn_eos_ord + jsto_eosi(jdof) = jpsto2d - 2 * nn_eos_ord + jsto_eosj(jdof) = jpsto2d - 1 * nn_eos_ord + jsto_eosk(jdof) = jpsto2d + END DO + ELSE + nn_sto_eos = 0 + ENDIF + IF( ln_sto_trc ) THEN + IF(lwp) WRITE(numout,*) ' - stochastic tracers dynamics' + ALLOCATE(jsto_trci(nn_sto_trc)) + ALLOCATE(jsto_trcj(nn_sto_trc)) + ALLOCATE(jsto_trck(nn_sto_trc)) + DO jdof = 1, nn_sto_trc + jpsto2d = jpsto2d + 3 * nn_trc_ord + jsto_trci(jdof) = jpsto2d - 2 * nn_trc_ord + jsto_trcj(jdof) = jpsto2d - 1 * nn_trc_ord + jsto_trck(jdof) = jpsto2d + END DO + ELSE + nn_sto_trc = 0 + ENDIF + + ! Set number of 3D stochastic arrays + jpsto3d = 0 + IF( ln_sto_hpg ) THEN + IF(lwp) WRITE(numout,*) ' - stochastic horizontal pressure gradient' + jpsto3d = jpsto3d + 2 + jsto_hpgi = jpsto3d - 1 + jsto_hpgj = jpsto3d + ENDIF + IF( ln_sto_trd ) THEN + IF(lwp) WRITE(numout,*) ' - stochastic trend' + jpsto3d = jpsto3d + 1 + jsto_trd = jpsto3d + ENDIF + + ! Allocate 2D stochastic arrays + IF ( jpsto2d > 0 ) THEN + ALLOCATE ( sto2d(jpi,jpj,jpsto2d) ) + ALLOCATE ( sto2d_abc(jpsto2d,3) ) + ALLOCATE ( sto2d_ave(jpsto2d) ) + ALLOCATE ( sto2d_std(jpsto2d) ) + ALLOCATE ( sto2d_lim(jpsto2d) ) + ALLOCATE ( sto2d_tcor(jpsto2d) ) + ALLOCATE ( sto2d_ord(jpsto2d) ) + ALLOCATE ( sto2d_typ(jpsto2d) ) + ALLOCATE ( sto2d_sgn(jpsto2d) ) + ALLOCATE ( sto2d_flt(jpsto2d) ) + ALLOCATE ( sto2d_fac(jpsto2d) ) + ENDIF + + ! Allocate 3D stochastic arrays + IF ( jpsto3d > 0 ) THEN + ALLOCATE ( sto3d(jpi,jpj,jpk,jpsto3d) ) + ALLOCATE ( sto3d_abc(jpsto3d,3) ) + ALLOCATE ( sto3d_ave(jpsto3d) ) + ALLOCATE ( sto3d_std(jpsto3d) ) + ALLOCATE ( sto3d_lim(jpsto3d) ) + ALLOCATE ( sto3d_tcor(jpsto3d) ) + ALLOCATE ( sto3d_ord(jpsto3d) ) + ALLOCATE ( sto3d_typ(jpsto3d) ) + ALLOCATE ( sto3d_sgn(jpsto3d) ) + ALLOCATE ( sto3d_flt(jpsto3d) ) + ALLOCATE ( sto3d_fac(jpsto3d) ) + ENDIF + + ! Allocate temporary workspace + IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN + ALLOCATE ( sto_tmp(jpi,jpj) ) ; sto_tmp(:,:) = 0._wp + ENDIF + + ! 1) For every stochastic parameter: + ! ---------------------------------- + ! - set nature of grid point and control of the sign + ! across the north fold (sto2d_typ, sto2d_sgn) + ! - set number of passes of Laplacian filter (sto2d_flt) + ! - set order of every autoregressive process (sto2d_ord) + DO jsto = 1, jpsto2d + sto2d_typ(jsto) = 'T' + sto2d_sgn(jsto) = 1._wp + sto2d_flt(jsto) = 0 + sto2d_ord(jsto) = 1 + DO jord = 0, nn_pstar_ord-1 + IF ( jsto+jord == jsto_pstar ) THEN ! Stochastic ice strength (ave=1) + sto2d_ord(jsto) = nn_pstar_ord - jord + sto2d_flt(jsto) = nn_pstar_flt + ENDIF + ENDDO + DO jdof = 1, nn_sto_eos + DO jord = 0, nn_eos_ord-1 + IF ( jsto+jord == jsto_eosi(jdof) ) THEN ! Stochastic equation of state i (ave=0) + sto2d_ord(jsto) = nn_eos_ord - jord + sto2d_sgn(jsto) = -1._wp + sto2d_flt(jsto) = nn_eos_flt + ENDIF + IF ( jsto+jord == jsto_eosj(jdof) ) THEN ! Stochastic equation of state j (ave=0) + sto2d_ord(jsto) = nn_eos_ord - jord + sto2d_sgn(jsto) = -1._wp + sto2d_flt(jsto) = nn_eos_flt + ENDIF + IF ( jsto+jord == jsto_eosk(jdof) ) THEN ! Stochastic equation of state k (ave=0) + sto2d_ord(jsto) = nn_eos_ord - jord + sto2d_flt(jsto) = nn_eos_flt + ENDIF + END DO + END DO + DO jdof = 1, nn_sto_trc + DO jord = 0, nn_trc_ord-1 + IF ( jsto+jord == jsto_trci(jdof) ) THEN ! Stochastic tracers dynamics i (ave=0) + sto2d_ord(jsto) = nn_trc_ord - jord + sto2d_sgn(jsto) = -1._wp + sto2d_flt(jsto) = nn_trc_flt + ENDIF + IF ( jsto+jord == jsto_trcj(jdof) ) THEN ! Stochastic tracers dynamics j (ave=0) + sto2d_ord(jsto) = nn_trc_ord - jord + sto2d_sgn(jsto) = -1._wp + sto2d_flt(jsto) = nn_trc_flt + ENDIF + IF ( jsto+jord == jsto_trck(jdof) ) THEN ! Stochastic tracers dynamics k (ave=0) + sto2d_ord(jsto) = nn_trc_ord - jord + sto2d_flt(jsto) = nn_trc_flt + ENDIF + END DO + END DO + + sto2d_fac(jsto) = sto_par_flt_fac ( sto2d_flt(jsto) ) + END DO + ! + DO jsto = 1, jpsto3d + sto3d_typ(jsto) = 'T' + sto3d_sgn(jsto) = 1._wp + sto3d_flt(jsto) = 0 + sto3d_ord(jsto) = 1 + IF ( jsto == jsto_hpgi ) THEN ! Stochastic density gradient i (ave=1) + sto3d_typ(jsto) = 'U' + ENDIF + IF ( jsto == jsto_hpgj ) THEN ! Stochastic density gradient j (ave=1) + sto3d_typ(jsto) = 'V' + ENDIF + sto3d_fac(jsto) = sto_par_flt_fac ( sto3d_flt(jsto) ) + END DO + + ! 2) For every stochastic parameter: + ! ---------------------------------- + ! set average, standard deviation and time correlation + DO jsto = 1, jpsto2d + sto2d_ave(jsto) = 0._wp + sto2d_std(jsto) = 1._wp + sto2d_tcor(jsto) = 1._wp + sto2d_lim(jsto) = 3._wp + IF ( jsto == jsto_ldf ) THEN ! Stochastic lateral diffusion (ave=1) + sto2d_ave(jsto) = 1._wp + sto2d_std(jsto) = rn_ldf_std + sto2d_tcor(jsto) = rn_ldf_tcor + ENDIF + DO jord = 0, nn_pstar_ord-1 + IF ( jsto+jord == jsto_pstar ) THEN ! Stochastic ice strength (ave=1) + sto2d_std(jsto) = 1._wp + sto2d_tcor(jsto) = rn_pstar_tcor + ENDIF + ENDDO + DO jdof = 1, nn_sto_eos + DO jord = 0, nn_eos_ord-1 + IF ( jsto+jord == jsto_eosi(jdof) ) THEN ! Stochastic equation of state i (ave=0) + sto2d_std(jsto) = rn_eos_stdxy + sto2d_tcor(jsto) = rn_eos_tcor + sto2d_lim(jsto) = rn_eos_lim + ENDIF + IF ( jsto+jord == jsto_eosj(jdof) ) THEN ! Stochastic equation of state j (ave=0) + sto2d_std(jsto) = rn_eos_stdxy + sto2d_tcor(jsto) = rn_eos_tcor + sto2d_lim(jsto) = rn_eos_lim + ENDIF + IF ( jsto+jord == jsto_eosk(jdof) ) THEN ! Stochastic equation of state k (ave=0) + sto2d_std(jsto) = rn_eos_stdz + sto2d_tcor(jsto) = rn_eos_tcor + sto2d_lim(jsto) = rn_eos_lim + ENDIF + END DO + END DO + DO jdof = 1, nn_sto_trc + DO jord = 0, nn_trc_ord-1 + IF ( jsto+jord == jsto_trci(jdof) ) THEN ! Stochastic tracer dynamics i (ave=0) + sto2d_std(jsto) = rn_trc_stdxy + sto2d_tcor(jsto) = rn_trc_tcor + sto2d_lim(jsto) = rn_trc_lim + ENDIF + IF ( jsto+jord == jsto_trcj(jdof) ) THEN ! Stochastic tracer dynamics j (ave=0) + sto2d_std(jsto) = rn_trc_stdxy + sto2d_tcor(jsto) = rn_trc_tcor + sto2d_lim(jsto) = rn_trc_lim + ENDIF + IF ( jsto+jord == jsto_trck(jdof) ) THEN ! Stochastic tracer dynamics k (ave=0) + sto2d_std(jsto) = rn_trc_stdz + sto2d_tcor(jsto) = rn_trc_tcor + sto2d_lim(jsto) = rn_trc_lim + ENDIF + END DO + END DO + + END DO + ! + DO jsto = 1, jpsto3d + sto3d_ave(jsto) = 0._wp + sto3d_std(jsto) = 1._wp + sto3d_tcor(jsto) = 1._wp + sto3d_lim(jsto) = 3._wp + IF ( jsto == jsto_hpgi ) THEN ! Stochastic density gradient i (ave=1) + sto3d_ave(jsto) = 1._wp + sto3d_std(jsto) = rn_hpg_std + sto3d_tcor(jsto) = rn_hpg_tcor + ENDIF + IF ( jsto == jsto_hpgj ) THEN ! Stochastic density gradient j (ave=1) + sto3d_ave(jsto) = 1._wp + sto3d_std(jsto) = rn_hpg_std + sto3d_tcor(jsto) = rn_hpg_tcor + ENDIF + IF ( jsto == jsto_trd ) THEN ! Stochastic trend (ave=1) + sto3d_ave(jsto) = 1._wp + sto3d_std(jsto) = rn_trd_std + sto3d_tcor(jsto) = rn_trd_tcor + ENDIF + END DO + + ! 3) For every stochastic parameter: + ! ---------------------------------- + ! - compute parameters (a, b, c) of the AR1 autoregressive process + ! from expected value (ave), standard deviation (std) + ! and time correlation (tcor): + ! a = EXP ( - 1 / tcor ) --> sto2d_abc(:,1) + ! b = std * SQRT( 1 - a * a ) --> sto2d_abc(:,2) + ! c = ave * ( 1 - a ) --> sto2d_abc(:,3) + ! - for higher order processes (ARn, n>1), use approximate formula + ! for the b parameter (valid for tcor>>1 time step) + DO jsto = 1, jpsto2d + IF ( sto2d_tcor(jsto) == 0._wp ) THEN + sto2d_abc(jsto,1) = 0._wp + ELSE + sto2d_abc(jsto,1) = EXP ( - 1._wp / sto2d_tcor(jsto) ) + ENDIF + IF ( sto2d_ord(jsto) == 1 ) THEN ! Exact formula for 1st order process + rinflate = sto2d_std(jsto) + ELSE + ! Approximate formula, valid for tcor >> 1 + jordm1 = sto2d_ord(jsto) - 1 + rinflate = SQRT ( REAL( jordm1 , wp ) / REAL( 2*(2*jordm1-1) , wp ) ) + ENDIF + sto2d_abc(jsto,2) = rinflate * SQRT ( 1._wp - sto2d_abc(jsto,1) & + * sto2d_abc(jsto,1) ) + sto2d_abc(jsto,3) = sto2d_ave(jsto) * ( 1._wp - sto2d_abc(jsto,1) ) + END DO + ! + DO jsto = 1, jpsto3d + IF ( sto3d_tcor(jsto) == 0._wp ) THEN + sto3d_abc(jsto,1) = 0._wp + ELSE + sto3d_abc(jsto,1) = EXP ( - 1._wp / sto3d_tcor(jsto) ) + ENDIF + IF ( sto3d_ord(jsto) == 1 ) THEN ! Exact formula for 1st order process + rinflate = sto3d_std(jsto) + ELSE + ! Approximate formula, valid for tcor >> 1 + jordm1 = sto3d_ord(jsto) - 1 + rinflate = SQRT ( REAL( jordm1 , wp ) / REAL( 2*(2*jordm1-1) , wp ) ) + ENDIF + sto3d_abc(jsto,2) = rinflate * SQRT ( 1._wp - sto3d_abc(jsto,1) & + * sto3d_abc(jsto,1) ) + sto3d_abc(jsto,3) = sto3d_ave(jsto) * ( 1._wp - sto3d_abc(jsto,1) ) + END DO + + ! 4) Initialize seeds for random number generator + ! ----------------------------------------------- + ! using different seeds for different processors (jarea) + ! and different ensemble members (jmem) + CALL kiss_reset( ) + DO jarea = 1, narea + !DO jmem = 0, nmember + zseed1 = kiss() ; zseed2 = kiss() ; zseed3 = kiss() ; zseed4 = kiss() + !END DO + END DO + CALL kiss_seed( zseed1, zseed2, zseed3, zseed4 ) + + ! 5) Initialize stochastic parameters to: ave + std * w + ! ----------------------------------------------------- + DO jsto = 1, jpsto2d + ! Draw random numbers from N(0,1) --> w + CALL sto_par_white( sto2d(:,:,jsto) ) + ! Apply horizontal Laplacian filter to w + DO jflt = 1, sto2d_flt(jsto) + CALL lbc_lnk( 'stopar', sto2d(:,:,jsto), sto2d_typ(jsto), sto2d_sgn(jsto) ) + CALL sto_par_flt( sto2d(:,:,jsto) ) + END DO + ! Factor to restore standard deviation after filtering + sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_fac(jsto) + ! Limit random parameter to the limitation factor + sto2d(:,:,jsto) = SIGN(MIN(sto2d_lim(jsto),ABS(sto2d(:,:,jsto))),sto2d(:,:,jsto)) + ! Multiply by standard devation and add average value + sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_std(jsto) + sto2d_ave(jsto) + END DO + ! + DO jsto = 1, jpsto3d + DO jk = 1, jpk + ! Draw random numbers from N(0,1) --> w + CALL sto_par_white( sto3d(:,:,jk,jsto) ) + ! Apply horizontal Laplacian filter to w + DO jflt = 1, sto3d_flt(jsto) + CALL lbc_lnk( 'stopar', sto3d(:,:,jk,jsto), sto3d_typ(jsto), sto3d_sgn(jsto) ) + CALL sto_par_flt( sto3d(:,:,jk,jsto) ) + END DO + ! Factor to restore standard deviation after filtering + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_fac(jsto) + ! Limit random parameter to the limitation factor + sto3d(:,:,jk,jsto) = SIGN(MIN(sto3d_lim(jsto),ABS(sto3d(:,:,jk,jsto))),sto3d(:,:,jk,jsto)) + ! Multiply by standard devation and add average value + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_std(jsto) + sto3d_ave(jsto) + END DO + END DO + + ! 6) Restart stochastic parameters from file + ! ------------------------------------------ + IF( ln_rststo ) CALL sto_rst_read + + END SUBROUTINE sto_par_init + + + SUBROUTINE sto_rst_read + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_rst_read *** + !! + !! ** Purpose : read stochastic parameters from restart file + !!---------------------------------------------------------------------- + INTEGER :: jsto, jseed + INTEGER :: idg ! number of digits + INTEGER(KIND=8) :: ziseed(4) ! RNG seeds in integer type + REAL(KIND=dp) :: zrseed(4) ! RNG seeds in double-precision (with same bits to save in restart) + CHARACTER(LEN=9) :: clsto2d='sto2d_000' ! stochastic parameter variable name + CHARACTER(LEN=9) :: clsto3d='sto3d_000' ! stochastic parameter variable name + CHARACTER(LEN=15) :: clseed='seed0_0000' ! seed variable name + CHARACTER(LEN=6) :: clfmt ! writing format + !!---------------------------------------------------------------------- + + IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sto_rst_read : read stochastic parameters from restart file' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + + ! Open the restart file + CALL iom_open( cn_storst_in, numstor ) + + ! Get stochastic parameters from restart file: + ! 2D stochastic parameters + DO jsto = 1 , jpsto2d + WRITE(clsto2d(7:9),'(i3.3)') jsto + CALL iom_get( numstor, jpdom_auto, clsto2d, sto2d(:,:, jsto) ) + END DO + ! 3D stochastic parameters + DO jsto = 1 , jpsto3d + WRITE(clsto3d(7:9),'(i3.3)') jsto + CALL iom_get( numstor, jpdom_auto, clsto3d, sto3d(:,:,:,jsto) ) + END DO + + IF (ln_rstseed) THEN + ! Get saved state of the random number generator + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(i', i1, '.', i1, ')')") idg, idg ! "(ix.x)" + DO jseed = 1 , 4 + WRITE(clseed(5:5) ,'(i1.1)') jseed + WRITE(clseed(7:7+idg-1), clfmt ) narea + CALL iom_get( numstor, clseed(1:7+idg-1) , zrseed(jseed) ) + END DO + ziseed = TRANSFER( zrseed , ziseed) + CALL kiss_seed( ziseed(1) , ziseed(2) , ziseed(3) , ziseed(4) ) + ENDIF + + ! Close the restart file + CALL iom_close( numstor ) + + ENDIF + + END SUBROUTINE sto_rst_read + + + SUBROUTINE sto_rst_write( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_rst_write *** + !! + !! ** Purpose : write stochastic parameters in restart file + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step + !! + INTEGER :: jsto, jseed + INTEGER :: idg ! number of digits + INTEGER(KIND=8) :: ziseed(4) ! RNG seeds in integer type + REAL(KIND=dp) :: zrseed(4) ! RNG seeds in double-precision (with same bits to save in restart) + CHARACTER(LEN=20) :: clkt ! ocean time-step defined as a character + CHARACTER(LEN=50) :: clname ! restart file name + CHARACTER(LEN=9) :: clsto2d='sto2d_000' ! stochastic parameter variable name + CHARACTER(LEN=9) :: clsto3d='sto3d_000' ! stochastic parameter variable name + CHARACTER(LEN=15) :: clseed='seed0_0000' ! seed variable name + CHARACTER(LEN=6) :: clfmt ! writing format + !!---------------------------------------------------------------------- + + IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart + + IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN + + IF( kt == nitrst .OR. kt == nitend ) THEN + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sto_rst_write : write stochastic parameters in restart file' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ENDIF + + ! Put stochastic parameters in restart files + ! (as opened at previous timestep, see below) + IF( kt > nit000) THEN + IF( kt == nitrst .OR. kt == nitend ) THEN + ! get and save current state of the random number generator + CALL kiss_state( ziseed(1) , ziseed(2) , ziseed(3) , ziseed(4) ) + zrseed = TRANSFER( ziseed , zrseed) + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(i', i1, '.', i1, ')')") idg, idg ! "(ix.x)" + DO jseed = 1 , 4 + WRITE(clseed(5:5) ,'(i1.1)') jseed + WRITE(clseed(7:7+idg-1), clfmt ) narea + CALL iom_rstput( kt, nitrst, numstow, clseed(1:7+idg-1), zrseed(jseed) ) + END DO + ! 2D stochastic parameters + DO jsto = 1 , jpsto2d + WRITE(clsto2d(7:9),'(i3.3)') jsto + CALL iom_rstput( kt, nitrst, numstow, clsto2d , sto2d(:,:,jsto) ) + END DO + ! 3D stochastic parameters + DO jsto = 1 , jpsto3d + WRITE(clsto3d(7:9),'(i3.3)') jsto + CALL iom_rstput( kt, nitrst, numstow, clsto3d , sto3d(:,:,:,jsto) ) + END DO + ! close the restart file + CALL iom_close( numstow ) + ENDIF + ENDIF + + ! Open the restart file one timestep before writing restart + IF( kt < nitend) THEN + IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. kt == nitend-1 ) THEN + ! create the filename + IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst + ELSE ; WRITE(clkt, '(i8.8)') nitrst + ENDIF + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_storst_out) + ! print information + IF(lwp) THEN + WRITE(numout,*) ' open stochastic parameters restart file: '//clname + IF( kt == nitrst - 1 ) THEN + WRITE(numout,*) ' kt = nitrst - 1 = ', kt + ELSE + WRITE(numout,*) ' kt = ' , kt + ENDIF + ENDIF + ! open the restart file + CALL iom_open( clname, numstow, ldwrt = .TRUE. ) + ENDIF + ENDIF + + ENDIF + + END SUBROUTINE sto_rst_write + + + SUBROUTINE sto_par_white( psto ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_par_white *** + !! + !! ** Purpose : fill input array with white Gaussian noise + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: psto + !! + INTEGER :: ji, jj + REAL(wp) :: gran ! Gaussian random number (forced KIND=8 as in kiss_gaussian) + + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + CALL kiss_gaussian( gran ) + psto(ji,jj) = gran + END DO ; END DO + + END SUBROUTINE sto_par_white + + + SUBROUTINE sto_par_flt( psto ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_par_flt *** + !! + !! ** Purpose : apply horizontal Laplacian filter to input array + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: psto + !! + INTEGER :: ji, jj + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + psto(ji,jj) = 0.5_wp * psto(ji,jj) + 0.125_wp * & + & ( psto(ji-1,jj) + psto(ji+1,jj) + & + & psto(ji,jj-1) + psto(ji,jj+1) ) + END DO ; END DO + + END SUBROUTINE sto_par_flt + + + FUNCTION sto_par_flt_fac( kpasses ) + !!---------------------------------------------------------------------- + !! *** FUNCTION sto_par_flt_fac *** + !! + !! ** Purpose : compute factor to restore standard deviation + !! as a function of the number of passes + !! of the Laplacian filter + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kpasses + REAL(wp) :: sto_par_flt_fac + !! + INTEGER :: jpasses, ji, jj, jflti, jfltj + INTEGER, DIMENSION(-1:1,-1:1) :: pflt0 + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pfltb + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pflta + REAL(wp) :: ratio + + pflt0(-1,-1) = 0 ; pflt0(-1,0) = 1 ; pflt0(-1,1) = 0 + pflt0( 0,-1) = 1 ; pflt0( 0,0) = 4 ; pflt0( 0,1) = 1 + pflt0( 1,-1) = 0 ; pflt0( 1,0) = 1 ; pflt0( 1,1) = 0 + + ALLOCATE(pfltb(-kpasses-1:kpasses+1,-kpasses-1:kpasses+1)) + ALLOCATE(pflta(-kpasses-1:kpasses+1,-kpasses-1:kpasses+1)) + + pfltb(:,:) = 0 + pfltb(0,0) = 1 + DO jpasses = 1, kpasses + pflta(:,:) = 0 + DO jflti= -1, 1 + DO jfltj= -1, 1 + DO ji= -kpasses, kpasses + DO jj= -kpasses, kpasses + pflta(ji,jj) = pflta(ji,jj) + pfltb(ji+jflti,jj+jfltj) * pflt0(jflti,jfltj) + ENDDO + ENDDO + ENDDO + ENDDO + pfltb(:,:) = pflta(:,:) + ENDDO + + ratio = SUM(pfltb(:,:)) + ratio = ratio * ratio / SUM(pfltb(:,:)*pfltb(:,:)) + ratio = SQRT(ratio) + + DEALLOCATE(pfltb,pflta) + + sto_par_flt_fac = ratio + + END FUNCTION sto_par_flt_fac + + +END MODULE stopar diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stopts.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stopts.f90 new file mode 100644 index 0000000000000000000000000000000000000000..40d915b51b1a64fe92e20877e0a43ddce7f95622 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stopts.f90 @@ -0,0 +1,158 @@ + + + + + + + + + + + + + +MODULE stopts + !!============================================================================== + !! *** MODULE stopts *** + !! Stochastic parameterization: compute stochastic tracer fluctuations + !!============================================================================== + !! History : 3.3 ! 2011-12 (J.-M. Brankart) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sto_pts : compute current stochastic tracer fluctuations + !! sto_pts_init : initialisation for stochastic tracer fluctuations + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE lbclnk ! lateral boundary conditions (or mpp link) + USE phycst ! physical constants + USE stopar ! stochastic parameterization + + IMPLICIT NONE + PRIVATE + + PUBLIC sto_pts ! called by step.F90 + PUBLIC sto_pts_init ! called by nemogcm.F90 + + ! Public array with random tracer fluctuations + REAL(wp), PUBLIC, DIMENSION(:,:,:,:,:), ALLOCATABLE :: pts_ran + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: stopts.F90 13295 2020-07-10 18:24:21Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sto_pts( pts ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_pts *** + !! + !! ** Purpose : Compute current stochastic tracer fluctuations + !! + !! ** Method : Compute tracer differences from a random walk + !! around every model grid point + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + INTEGER :: ji, jj, jk, jts, jdof ! dummy loop indices + INTEGER :: jim1, jjm1, jkm1 ! incremented indices + INTEGER :: jip1, jjp1, jkp1 ! - - + REAL(wp) :: zdtsim, zdtsjm, zdtskm ! temporary scalars + REAL(wp) :: zdtsip, zdtsjp, zdtskp, zdts ! - - + !!---------------------------------------------------------------------- + + DO jts = 1, jpts + CALL lbc_lnk( 'stopts', pts(:,:,:,jts), 'T' , 1._dp ) + ENDDO + + DO jdof = 1, nn_sto_eos + DO jts = 1, jpts + DO jk = 1, jpkm1 + jkm1 = MAX(jk-1,1) ; jkp1 = MIN(jk+1,jpkm1) + DO jj = 1, jpj + jjm1 = MAX(jj-1,1) ; jjp1 = MIN(jj+1,jpj) + DO ji = 1, jpi + jim1 = MAX(ji-1,1) ; jip1 = MIN(ji+1,jpi) + ! + ! compute tracer gradient + zdtsip = ( pts(jip1,jj,jk,jts) - pts(ji,jj,jk,jts) ) * tmask(jip1,jj,jk) + zdtsim = ( pts(ji,jj,jk,jts) - pts(jim1,jj,jk,jts) ) * tmask(jim1,jj,jk) + zdtsjp = ( pts(ji,jjp1,jk,jts) - pts(ji,jj,jk,jts) ) * tmask(ji,jjp1,jk) + zdtsjm = ( pts(ji,jj,jk,jts) - pts(ji,jjm1,jk,jts) ) * tmask(ji,jjm1,jk) + zdtskp = ( pts(ji,jj,jkp1,jts) - pts(ji,jj,jk,jts) ) * tmask(ji,jj,jkp1) + zdtskm = ( pts(ji,jj,jk,jts) - pts(ji,jj,jkm1,jts) ) * tmask(ji,jj,jkm1) + ! + ! compute random tracer fluctuation (zdts) + zdts = ( zdtsip + zdtsim ) * sto2d(ji,jj,jsto_eosi(jdof)) + & + & ( zdtsjp + zdtsjm ) * sto2d(ji,jj,jsto_eosj(jdof)) + & + & ( zdtskp + zdtskm ) * sto2d(ji,jj,jsto_eosk(jdof)) +! zdts = zdtsip * MAX(sto2d(ji,jj,jsto_eosi),0._wp) + & +! & zdtsim * MIN(sto2d(ji,jj,jsto_eosi),0._wp) + & +! & zdtsjp * MAX(sto2d(ji,jj,jsto_eosj),0._wp) + & +! & zdtsjm * MIN(sto2d(ji,jj,jsto_eosj),0._wp) + & +! & zdtskp * MAX(sto2d(ji,jj,jsto_eosk),0._wp) + & +! & zdtskm * MIN(sto2d(ji,jj,jsto_eosk),0._wp) + zdts = zdts * tmask(ji,jj,jk) *SIN( gphit(ji,jj) * rad ) + pts_ran(ji,jj,jk,jts,jdof) = zdts * 0.5_wp + ! + END DO + END DO + END DO + END DO + END DO + + ! Eliminate any possible negative salinity + DO jdof = 1, nn_sto_eos + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + pts_ran(ji,jj,jk,jp_sal,jdof) = MIN( ABS(pts_ran(ji,jj,jk,jp_sal,jdof)) , & + & MAX(pts(ji,jj,jk,jp_sal),0._wp) ) & + & * SIGN(1._wp,pts_ran(ji,jj,jk,jp_sal,jdof)) + END DO ; END DO ; END DO + END DO + + ! Eliminate any temperature lower than -2 degC +! DO jdof = 1, nn_sto_eos +! DO jk = 1, jpkm1 +! DO jj = 1, jpj +! DO ji = 1, jpi +! pts_ran(ji,jj,jk,jp_tem,jdof) = MIN( ABS(pts_ran(ji,jj,jk,jp_tem,jdof)) , & +! & MAX(pts(ji,jj,jk,jp_tem)+2._wp,0._wp) ) & +! & * SIGN(1._wp,pts_ran(ji,jj,jk,jp_tem,jdof)) +! END DO +! END DO +! END DO +! END DO + + + ! Lateral boundary conditions on pts_ran + DO jdof = 1, nn_sto_eos + DO jts = 1, jpts + CALL lbc_lnk( 'stopts', pts_ran(:,:,:,jts,jdof), 'T' , 1._wp ) + END DO + END DO + + END SUBROUTINE sto_pts + + + SUBROUTINE sto_pts_init + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_pts_init *** + !! + !! ** Purpose : Initialisation for stochastic tracer fluctuations + !! + !! ** Method : Allocate required array + !! + !!---------------------------------------------------------------------- + + ALLOCATE(pts_ran(jpi,jpj,jpk,jpts,nn_sto_eos)) + + END SUBROUTINE sto_pts_init + +END MODULE stopts diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/storng.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/storng.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b27f702268ce216c00e204021a6a908e722a7396 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/storng.f90 @@ -0,0 +1,424 @@ + + + + + + + + + + + + + +MODULE storng +!$AGRIF_DO_NOT_TREAT + !!====================================================================== + !! *** MODULE storng *** + !! Random number generator, used in NEMO stochastic parameterization + !! + !!===================================================================== + !! History : 3.3 ! 2011-10 (J.-M. Brankart) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! The module is based on (and includes) the + !! 64-bit KISS (Keep It Simple Stupid) random number generator + !! distributed by George Marsaglia : + !! http://groups.google.com/group/comp.lang.fortran/ + !! browse_thread/thread/a85bf5f2a97f5a55 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! kiss : 64-bit KISS random number generator (period ~ 2^250) + !! kiss_seed : Define seeds for KISS random number generator + !! kiss_state : Get current state of KISS random number generator + !! kiss_save : Save current state of KISS (for future restart) + !! kiss_load : Load the saved state of KISS + !! kiss_reset : Reset the default seeds + !! kiss_check : Check the KISS pseudo-random sequence + !! kiss_uniform : Real random numbers with uniform distribution in [0,1] + !! kiss_gaussian : Real random numbers with Gaussian distribution N(0,1) + !! kiss_gamma : Real random numbers with Gamma distribution Gamma(k,1) + !! kiss_sample : Select a random sample from a set of integers + !! + !! ---CURRENTLY NOT USED IN NEMO : + !! kiss_save, kiss_load, kiss_check, kiss_gamma, kiss_sample + !!---------------------------------------------------------------------- + USE par_kind + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + ! Public functions/subroutines + PUBLIC :: kiss, kiss_seed, kiss_state, kiss_reset ! kiss_save, kiss_load, kiss_check + PUBLIC :: kiss_uniform, kiss_gaussian, kiss_gamma, kiss_sample + + ! Default/initial seeds + INTEGER(KIND=i8) :: x=1234567890987654321_8 + INTEGER(KIND=i8) :: y=362436362436362436_8 + INTEGER(KIND=i8) :: z=1066149217761810_8 + INTEGER(KIND=i8) :: w=123456123456123456_8 + + ! Parameters to generate real random variates + REAL(KIND=wp), PARAMETER :: zero=0.0, half=0.5, one=1.0, two=2.0 + + ! Variables to store 2 Gaussian random numbers with current index (ig) + INTEGER(KIND=i8), SAVE :: ig=1 + REAL(KIND=wp), SAVE :: gran1, gran2 + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: storng.F90 12649 2020-04-03 07:11:57Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + FUNCTION kiss() + !! -------------------------------------------------------------------- + !! *** FUNCTION kiss *** + !! + !! ** Purpose : 64-bit KISS random number generator + !! + !! ** Method : combine several random number generators: + !! (1) Xorshift (XSH), period 2^64-1, + !! (2) Multiply-with-carry (MWC), period (2^121+2^63-1) + !! (3) Congruential generator (CNG), period 2^64. + !! + !! overall period: + !! (2^250+2^192+2^64-2^186-2^129)/6 + !! ~= 2^(247.42) or 10^(74.48) + !! + !! set your own seeds with 'kiss_seed' + ! -------------------------------------------------------------------- + IMPLICIT NONE + INTEGER(KIND=i8) :: kiss, t + + t = ISHFT(x,58) + w + IF (s(x).eq.s(t)) THEN + w = ISHFT(x,-6) + s(x) + ELSE + w = ISHFT(x,-6) + 1 - s(x+t) + ENDIF + x = t + x + y = m( m( m(y,13_8), -17_8 ), 43_8 ) + z = 6906969069_8 * z + 1234567_8 + + kiss = x + y + z + + CONTAINS + + FUNCTION s(k) + INTEGER(KIND=i8) :: s, k + s = ISHFT(k,-63) + END FUNCTION s + + FUNCTION m(k, n) + INTEGER(KIND=i8) :: m, k, n + m = IEOR(k, ISHFT(k, n) ) + END FUNCTION m + + END FUNCTION kiss + + + SUBROUTINE kiss_seed(ix, iy, iz, iw) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_seed *** + !! + !! ** Purpose : Define seeds for KISS random number generator + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + INTEGER(KIND=i8) :: ix, iy, iz, iw + + x = ix + y = iy + z = iz + w = iw + + END SUBROUTINE kiss_seed + + + SUBROUTINE kiss_state(ix, iy, iz, iw) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_state *** + !! + !! ** Purpose : Get current state of KISS random number generator + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + INTEGER(KIND=i8) :: ix, iy, iz, iw + + ix = x + iy = y + iz = z + iw = w + + END SUBROUTINE kiss_state + + + SUBROUTINE kiss_reset() + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_reset *** + !! + !! ** Purpose : Reset the default seeds for KISS random number generator + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + + x=1234567890987654321_8 + y=362436362436362436_8 + z=1066149217761810_8 + w=123456123456123456_8 + + END SUBROUTINE kiss_reset + + + ! SUBROUTINE kiss_check(check_type) + ! !! -------------------------------------------------------------------- + ! !! *** ROUTINE kiss_check *** + ! !! + ! !! ** Purpose : Check the KISS pseudo-random sequence + ! !! + ! !! ** Method : Check that it reproduces the correct sequence + ! !! from the default seed + ! !! + ! !! -------------------------------------------------------------------- + ! IMPLICIT NONE + ! INTEGER(KIND=i8) :: iter, niter, correct, iran + ! CHARACTER(LEN=*) :: check_type + ! LOGICAL :: print_success + + ! ! Save current state of KISS + ! CALL kiss_save() + ! ! Reset the default seed + ! CALL kiss_reset() + + ! ! Select check type + ! SELECT CASE(check_type) + ! CASE('short') + ! niter = 5_8 + ! correct = 542381058189297533 + ! print_success = .FALSE. + ! CASE('long') + ! niter = 100000000_8 + ! correct = 1666297717051644203 ! Check provided by G. Marsaglia + ! print_success = .TRUE. + ! CASE('default') + ! CASE DEFAULT + ! STOP 'Bad check type in kiss_check' + ! END SELECT + + ! ! Run kiss for the required number of iterations (niter) + ! DO iter=1,niter + ! iran = kiss() + ! ENDDO + + ! ! Check that last iterate is correct + ! IF (iran.NE.correct) THEN + ! STOP 'Check failed: KISS internal error !!' + ! ELSE + ! IF (print_success) PRINT *, 'Check successful: 100 million calls to KISS OK' + ! ENDIF + + ! ! Reload the previous state of KISS + ! CALL kiss_load() + + ! END SUBROUTINE kiss_check + + + ! SUBROUTINE kiss_save + ! !! -------------------------------------------------------------------- + ! !! *** ROUTINE kiss_save *** + ! !! + ! !! ** Purpose : Save current state of KISS random number generator + ! !! + ! !! -------------------------------------------------------------------- + ! INTEGER :: inum !! Local integer + + ! IMPLICIT NONE + + ! CALL ctl_opn( inum, '.kiss_restart', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + + ! ! OPEN(UNIT=30,FILE='.kiss_restart') + ! WRITE(inum,*) x + ! WRITE(inum,*) y + ! WRITE(inum,*) z + ! WRITE(inum,*) w + ! CALL flush(inum) + + ! END SUBROUTINE kiss_save + + + ! SUBROUTINE kiss_load + ! !! -------------------------------------------------------------------- + ! !! *** ROUTINE kiss_load *** + ! !! + ! !! ** Purpose : Load the saved state of KISS random number generator + ! !! + ! !! -------------------------------------------------------------------- + ! IMPLICIT NONE + ! LOGICAL :: filexists + ! Use ctl_opn routine rather than fortran intrinsic functions + ! INQUIRE(FILE='.kiss_restart',EXIST=filexists) + ! IF (filexists) THEN + ! OPEN(UNIT=30,FILE='.kiss_restart') + ! READ(30,*) x + ! READ(30,*) y + ! READ(30,*) z + ! READ(30,*) w + ! CLOSE(30) + ! ENDIF + + ! END SUBROUTINE kiss_load + + + SUBROUTINE kiss_uniform(uran) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_uniform *** + !! + !! ** Purpose : Real random numbers with uniform distribution in [0,1] + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + REAL(KIND=wp) :: uran + + uran = half * ( one + REAL(kiss(),wp) / HUGE(1._wp) ) + + END SUBROUTINE kiss_uniform + + + SUBROUTINE kiss_gaussian(gran) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_gaussian *** + !! + !! ** Purpose : Real random numbers with Gaussian distribution N(0,1) + !! + !! ** Method : Generate 2 new Gaussian draws (gran1 and gran2) + !! from 2 uniform draws on [-1,1] (u1 and u2), + !! using the Marsaglia polar method + !! (see Devroye, Non-Uniform Random Variate Generation, p. 235-236) + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + REAL(KIND=wp) :: gran, u1, u2, rsq, fac + + IF (ig.EQ.1) THEN + rsq = two + DO WHILE ( (rsq.GE.one).OR. (rsq.EQ.zero) ) + u1 = REAL(kiss(),wp) / HUGE(1._wp) + u2 = REAL(kiss(),wp) / HUGE(1._wp) + rsq = u1*u1 + u2*u2 + ENDDO + fac = SQRT(-two*LOG(rsq)/rsq) + gran1 = u1 * fac + gran2 = u2 * fac + ENDIF + + ! Output one of the 2 draws + IF (ig.EQ.1) THEN + gran = gran1 ; ig = 2 + ELSE + gran = gran2 ; ig = 1 + ENDIF + + END SUBROUTINE kiss_gaussian + + + SUBROUTINE kiss_gamma(gamr,k) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_gamma *** + !! + !! ** Purpose : Real random numbers with Gamma distribution Gamma(k,1) + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + REAL(KIND=wp), PARAMETER :: p1 = 4.5_8 + REAL(KIND=wp), PARAMETER :: p2 = 2.50407739677627_8 ! 1+LOG(9/2) + REAL(KIND=wp), PARAMETER :: p3 = 1.38629436111989_8 ! LOG(4) + REAL(KIND=wp) :: gamr, k, u1, u2, b, c, d, xx, yy, zz, rr, ee + LOGICAL :: accepted + + IF (k.GT.one) THEN + ! Cheng's rejection algorithm + ! (see Devroye, Non-Uniform Random Variate Generation, p. 413) + b = k - p3 ; d = SQRT(two*k-one) ; c = k + d + + accepted=.FALSE. + DO WHILE (.NOT.accepted) + CALL kiss_uniform(u1) + yy = LOG(u1/(one-u1)) / d ! Mistake in Devroye: "* k" instead of "/ d" + xx = k * EXP(yy) + rr = b + c * yy - xx + CALL kiss_uniform(u2) + zz = u1 * u1 * u2 + + accepted = rr .GE. (zz*p1-p2) + IF (.NOT.accepted) accepted = rr .GE. LOG(zz) + ENDDO + + gamr = xx + + ELSEIF (k.LT.one) THEN + ! Rejection from the Weibull density + ! (see Devroye, Non-Uniform Random Variate Generation, p. 415) + c = one/k ; d = (one-k) * EXP( (k/(one-k)) * LOG(k) ) + + accepted=.FALSE. + DO WHILE (.NOT.accepted) + CALL kiss_uniform(u1) + zz = -LOG(u1) + xx = EXP( c * LOG(zz) ) + CALL kiss_uniform(u2) + ee = -LOG(u2) + + accepted = (zz+ee) .GE. (d+xx) ! Mistake in Devroye: "LE" instead of "GE" + ENDDO + + gamr = xx + + ELSE + ! Exponential distribution + CALL kiss_uniform(u1) + gamr = -LOG(u1) + + ENDIF + + END SUBROUTINE kiss_gamma + + + SUBROUTINE kiss_sample(a,n,k) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_sample *** + !! + !! ** Purpose : Select a random sample of size k from a set of n integers + !! + !! ** Method : The sample is output in the first k elements of a + !! Set k equal to n to obtain a random permutation + !! of the whole set of integers + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + INTEGER(KIND=i8), DIMENSION(:) :: a + INTEGER(KIND=i8) :: n, k, i, j, atmp + REAL(KIND=wp) :: uran + + ! Select the sample using the swapping method + ! (see Devroye, Non-Uniform Random Variate Generation, p. 612) + DO i=1,k + ! Randomly select the swapping element between i and n (inclusive) + CALL kiss_uniform(uran) + j = i - 1 + CEILING( REAL(n-i+1,8) * uran ) + ! Swap elements i and j + atmp = a(i) ; a(i) = a(j) ; a(j) = atmp + ENDDO + + END SUBROUTINE kiss_sample +!$AGRIF_END_DO_NOT_TREAT +END MODULE storng diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stpctl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stpctl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0d71d3dda7b1de05b3ee2a051880f3d41725ab79 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stpctl.f90 @@ -0,0 +1,344 @@ + + + + + + + + + + + + + +MODULE stpctl + !!====================================================================== + !! *** MODULE stpctl *** + !! Ocean run control : gross check of the ocean time stepping + !!====================================================================== + !! History : OPA ! 1991-03 (G. Madec) Original code + !! 6.0 ! 1992-06 (M. Imbard) + !! 8.0 ! 1997-06 (A.M. Treguier) + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 2.0 ! 2009-07 (G. Madec) Add statistic for time-spliting + !! 3.7 ! 2016-09 (G. Madec) Remove solver + !! 4.0 ! 2017-04 (G. Madec) regroup global communications + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! stp_ctl : Control the run + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE zdf_oce , ONLY : ln_zad_Aimp ! ocean vertical physics variables + USE wet_dry, ONLY : ll_wd, ssh_ref ! reference depth for negative bathy + ! + USE diawri ! Standard run outputs (dia_wri_state routine) + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing + USE eosbn2, ONLY: ln_SEOS, rn_b0 + ! + USE netcdf ! NetCDF library + IMPLICIT NONE + PRIVATE + + PUBLIC stp_ctl ! routine called by step.F90 + + INTEGER, PARAMETER :: jpvar = 8 + INTEGER :: nrunid ! netcdf file id + INTEGER, DIMENSION(jpvar) :: nvarid ! netcdf variable id + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: stpctl.F90 15023 2021-06-18 14:35:25Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + +CONTAINS + + SUBROUTINE stp_ctl( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE stp_ctl *** + !! + !! ** Purpose : Control the run + !! + !! ** Method : - Save the time step in numstp + !! - Stop the run IF problem encountered by setting nstop > 0 + !! Problems checked: |ssh| maximum larger than 10 m + !! |U| maximum larger than 10 m/s + !! negative sea surface salinity + !! + !! ** Actions : "time.step" file = last ocean time-step + !! "run.stat" file = run statistics + !! nstop indicator sheared among all local domain + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kmm ! ocean time level index + !! + INTEGER, PARAMETER :: jptst = 4 + INTEGER :: ji ! dummy loop indices + INTEGER :: idtime, istatus + INTEGER , DIMENSION(jptst) :: iareasum, iareamin, iareamax + INTEGER , DIMENSION(3,jptst) :: iloc ! min/max loc indices + REAL(wp) :: zzz, zminsal, zmaxsal ! local real + REAL(wp), DIMENSION(jpvar+1) :: zmax + REAL(wp), DIMENSION(jptst) :: zmaxlocal + LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce + LOGICAL, DIMENSION(jpi,jpj,jpk) :: llmsk + CHARACTER(len=20) :: clname + !!---------------------------------------------------------------------- + IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid + ! + ll_wrtstp = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) + ll_colruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. jpnij > 1 + ll_wrtruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. lwm + ! + IF( kt == nit000 ) THEN + ! + IF( lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'stp_ctl : time-stepping control' + WRITE(numout,*) '~~~~~~~' + ENDIF + ! ! open time.step ascii file, done only by 1st subdomain + IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + ! + IF( ll_wrtruns ) THEN + ! ! open run.stat ascii file, done only by 1st subdomain + CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + ! ! open run.stat.nc netcdf file, done only by 1st subdomain + clname = 'run.stat.nc' + IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) + istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid ) + istatus = NF90_DEF_DIM( nrunid, 'time', NF90_UNLIMITED, idtime ) + istatus = NF90_DEF_VAR( nrunid, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), nvarid(1) ) + istatus = NF90_DEF_VAR( nrunid, 'abs_u_max', NF90_DOUBLE, (/ idtime /), nvarid(2) ) + istatus = NF90_DEF_VAR( nrunid, 's_min', NF90_DOUBLE, (/ idtime /), nvarid(3) ) + istatus = NF90_DEF_VAR( nrunid, 's_max', NF90_DOUBLE, (/ idtime /), nvarid(4) ) + istatus = NF90_DEF_VAR( nrunid, 't_min', NF90_DOUBLE, (/ idtime /), nvarid(5) ) + istatus = NF90_DEF_VAR( nrunid, 't_max', NF90_DOUBLE, (/ idtime /), nvarid(6) ) + IF( ln_zad_Aimp ) THEN + istatus = NF90_DEF_VAR( nrunid, 'Cf_max', NF90_DOUBLE, (/ idtime /), nvarid(7) ) + istatus = NF90_DEF_VAR( nrunid,'abs_wi_max',NF90_DOUBLE, (/ idtime /), nvarid(8) ) + ENDIF + istatus = NF90_ENDDEF(nrunid) + ENDIF + ! + ENDIF + ! + ! !== write current time step ==! + ! !== done only by 1st subdomain at writting timestep ==! + IF( lwm .AND. ll_wrtstp ) THEN + WRITE ( numstp, '(1x, i8)' ) kt + REWIND( numstp ) + ENDIF + ! !== test of local extrema ==! + ! !== done by all processes at every time step ==! + ! + llmsk( 1:nn_hls,:,:) = .FALSE. ! exclude halos from the checked region + llmsk(Nie0+1: jpi,:,:) = .FALSE. + llmsk(:, 1:nn_hls,:) = .FALSE. + llmsk(:,Nje0+1: jpj,:) = .FALSE. + ! + llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp ! define only the inner domain + ! + ll_0oce = .NOT. ANY( llmsk(:,:,1) ) ! no ocean point in the inner domain? + ! + IF( ll_wd ) THEN + zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref ), mask = llmsk(:,:,1) ) ! ssh max + ELSE + zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max + ENDIF + llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk ) ! velocity max (zonal only) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! minus salinity max + zmax(4) = MAXVAL( ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! salinity max + IF( ll_colruns .OR. jpnij == 1 ) THEN ! following variables are used only in the netcdf file + zmax(5) = MAXVAL( -ts(:,:,:,jp_tem,Kmm), mask = llmsk ) ! minus temperature max + zmax(6) = MAXVAL( ts(:,:,:,jp_tem,Kmm), mask = llmsk ) ! temperature max + IF( ln_zad_Aimp ) THEN + zmax(7) = MAXVAL( Cu_adv(:,:,:) , mask = llmsk ) ! partitioning coeff. max + llmsk(:,:,:) = wmask(:,:,:) == 1._wp + zmax(8) = MAXVAL( ABS( wi(:,:,:) ) , mask = llmsk ) ! implicit vertical vel. max + ELSE + zmax(7:8) = 0._wp + ENDIF + ELSE + zmax(5:8) = 0._wp + ENDIF + zmax(jpvar+1) = REAL( nstop, wp ) ! stop indicator + ! + ! !== get global extrema ==! + ! !== done by all processes if writting run.stat ==! + IF( ll_colruns ) THEN + zmaxlocal(:) = zmax(1:jptst) + CALL mpp_max( "stpctl", zmax ) ! max over the global domain: ok even of ll_0oce = .true. + nstop = NINT( zmax(jpvar+1) ) ! update nstop indicator (now sheared among all local domains) + ELSE + ! if no ocean point: MAXVAL returns -HUGE => we must overwrite this value to avoid error handling bellow. + IF( ll_0oce ) zmax(1:jptst) = (/ 0._wp, 0._wp, -1._wp, 1._wp /) ! default "valid" values... + ENDIF + ! + zmax(3) = -zmax(3) ! move back from max(-zz) to min(zz) : easier to manage! + zmax(5) = -zmax(5) ! move back from max(-zz) to min(zz) : easier to manage! + IF( ll_colruns ) zmaxlocal(3) = -zmaxlocal(3) ! move back from max(-zz) to min(zz) : easier to manage! + ! + ! !== write "run.stat" files ==! + ! !== done only by 1st subdomain at writting timestep ==! + IF( ll_wrtruns ) THEN + WRITE(numrun,9500) kt, zmax(1:jptst) + IF( jpnij == 1 ) CALL FLUSH(numrun) + DO ji = 1, jpvar - 2 * COUNT( .NOT. (/ln_zad_Aimp/) ) + istatus = NF90_PUT_VAR( nrunid, nvarid(ji), (/zmax(ji)/), (/kt/), (/1/) ) + END DO + IF( kt == nitend ) istatus = NF90_CLOSE(nrunid) + END IF + ! !== error handling ==! + ! !== done by all processes at every time step ==! + ! + IF ( ln_SEOS.AND.(rn_b0==0._wp) ) THEN ! Discard checks on salinity + zmaxsal = HUGE(1._wp) ! if not used in eos + zminsal = -HUGE(1._wp) + ELSE + zmaxsal = 100._wp + zminsal = 0._wp + ENDIF + ! + IF( zmax(1) > 20._wp .OR. & ! too large sea surface height ( > 20 m ) + & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s) + & zmax(3) <= zminsal .OR. & ! negative or zero sea surface salinity + & zmax(4) >= zmaxsal .OR. & ! too large sea surface salinity ( > 100 ) + & zmax(4) < zminsal .OR. & ! too large sea surface salinity (keep this line for sea-ice) + & ISNAN( SUM(zmax(1:jptst)) ) .OR. & ! NaN encounter in the tests + & ABS( SUM(zmax(1:jptst)) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests + ! + iloc(:,:) = 0 + IF( ll_colruns ) THEN ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc + ! first: close the netcdf file, so we can read it + IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid) + ! get global loc on the min/max + llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain + CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), llmsk(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F + llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL mpp_maxloc( 'stpctl', REAL(ABS( uu(:,:,:, Kmm)),dp), llmsk(:,:,:), zzz, iloc(1:3,2) ) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,3) ) + CALL mpp_maxloc( 'stpctl', REAL(ts(:,:,:,jp_sal,Kmm),dp) , llmsk(:,:,:), zzz, iloc(1:3,4) ) + ! find which subdomain has the max. + iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 + DO ji = 1, jptst + IF( zmaxlocal(ji) == zmax(ji) ) THEN + iareamin(ji) = narea ; iareamax(ji) = narea ; iareasum(ji) = 1 + ENDIF + END DO + CALL mpp_min( "stpctl", iareamin ) ! min over the global domain + CALL mpp_max( "stpctl", iareamax ) ! max over the global domain + CALL mpp_sum( "stpctl", iareasum ) ! sum over the global domain + ELSE ! find local min and max locations: + ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc + llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain + iloc(1:2,1) = MAXLOC( ABS( ssh(:,:, Kmm)), mask = llmsk(:,:,1) ) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + iloc(1:3,2) = MAXLOC( ABS( uu(:,:,:, Kmm)), mask = llmsk(:,:,:) ) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + iloc(1:3,3) = MINLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) + iloc(1:3,4) = MAXLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) + DO ji = 1, jptst ! local domain indices ==> global domain indices, excluding halos + iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) + END DO + iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information + ENDIF + ! + WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100 or NaN encounter in the tests' + CALL wrt_line( ctmp2, kt, '|ssh| max', zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) + CALL wrt_line( ctmp3, kt, '|U| max', zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) + CALL wrt_line( ctmp4, kt, 'Sal min', zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) ) + CALL wrt_line( ctmp5, kt, 'Sal max', zmax(4), iloc(:,4), iareasum(4), iareamin(4), iareamax(4) ) + IF( Agrif_Root() ) THEN + WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files' + ELSE + WRITE(ctmp6,*) ' ===> output of last computed fields in '//TRIM(Agrif_CFixed())//'_output.abort* files' + ENDIF + ! + CALL dia_wri_state( Kmm, 'output.abort' ) ! create an output.abort file + ! + IF( ll_colruns .OR. jpnij == 1 ) THEN ! all processes synchronized -> use lwp to print in opened ocean.output files + IF(lwp) THEN ; CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) + ELSE ; nstop = MAX(1, nstop) ! make sure nstop > 0 (automatically done when calling ctl_stop) + ENDIF + ELSE ! only mpi subdomains with errors are here -> STOP now + CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) + ENDIF + ! + ENDIF + ! + IF( nstop > 0 ) THEN ! an error was detected and we did not abort yet... + ngrdstop = Agrif_Fixed() ! store which grid got this error + IF( .NOT. ll_colruns .AND. jpnij > 1 ) CALL ctl_stop( 'STOP' ) ! we must abort here to avoid MPI deadlock + ENDIF + ! +9500 FORMAT(' it :', i8, ' |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16) + ! + END SUBROUTINE stp_ctl + + + SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wrt_line *** + !! + !! ** Purpose : write information line + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT( out) :: cdline + CHARACTER(len=*), INTENT(in ) :: cdprefix + REAL(wp), INTENT(in ) :: pval + INTEGER, DIMENSION(3), INTENT(in ) :: kloc + INTEGER, INTENT(in ) :: kt, ksum, kmin, kmax + ! + CHARACTER(len=80) :: clsuff + CHARACTER(len=9 ) :: clkt, clsum, clmin, clmax + CHARACTER(len=9 ) :: cli, clj, clk + CHARACTER(len=1 ) :: clfmt + CHARACTER(len=4 ) :: cl4 ! needed to be able to compile with Agrif, I don't know why + INTEGER :: ifmtk + !!---------------------------------------------------------------------- + WRITE(clkt , '(i9)') kt + + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij ,wp))) + 1 ! how many digits to we need to write ? (we decide max = 9) + !!! WRITE(clsum, '(i'//clfmt//')') ksum ! this is creating a compilation error with AGRIF + cl4 = '(i'//clfmt//')' ; WRITE(clsum, cl4) ksum + WRITE(clfmt, '(i1)') INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1 ! how many digits to we need to write ? (we decide max = 9) + cl4 = '(i'//clfmt//')' ; WRITE(clmin, cl4) kmin-1 + WRITE(clmax, cl4) kmax-1 + ! + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1 ! how many digits to we need to write jpiglo? (we decide max = 9) + cl4 = '(i'//clfmt//')' ; WRITE(cli, cl4) kloc(1) ! this is ok with AGRIF + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1 ! how many digits to we need to write jpjglo? (we decide max = 9) + cl4 = '(i'//clfmt//')' ; WRITE(clj, cl4) kloc(2) ! this is ok with AGRIF + ! + IF( ksum == 1 ) THEN ; WRITE(clsuff,9100) TRIM(clmin) + ELSE ; WRITE(clsuff,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax) + ENDIF + IF(kloc(3) == 0) THEN + ifmtk = INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9) + clk = REPEAT(' ', ifmtk) ! create the equivalent in blank string + WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(clsuff) + ELSE + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9) + !!! WRITE(clk, '(i'//clfmt//')') kloc(3) ! this is creating a compilation error with AGRIF + cl4 = '(i'//clfmt//')' ; WRITE(clk, cl4) kloc(3) ! this is ok with AGRIF + WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), TRIM(clk), TRIM(clsuff) + ENDIF + ! +9100 FORMAT('MPI rank ', a) +9200 FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a) +9300 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j ', a, ' ', a, ' ', a, ' ', a) +9400 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a) + ! + END SUBROUTINE wrt_line + + + !!====================================================================== +END MODULE stpctl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stpmlf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stpmlf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..49ec29b02a65433ca165030ebcf116bb43cb4559 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/stpmlf.f90 @@ -0,0 +1,522 @@ + + + + + + + + + + + + + +MODULE stpmlf + !!====================================================================== + !! *** MODULE stpMLF *** + !! Time-stepping : manager of the ocean, tracer and ice time stepping + !! using Modified Leap Frog for OCE + !!====================================================================== + !! History : OPA ! 1991-03 (G. Madec) Original code + !! - ! 1991-11 (G. Madec) + !! - ! 1992-06 (M. Imbard) add a first output record + !! - ! 1996-04 (G. Madec) introduction of dynspg + !! - ! 1996-04 (M.A. Foujols) introduction of passive tracer + !! 8.0 ! 1997-06 (G. Madec) new architecture of call + !! 8.2 ! 1997-06 (G. Madec, M. Imbard, G. Roullet) free surface + !! - ! 1999-02 (G. Madec, N. Grima) hpg implicit + !! - ! 2000-07 (J-M Molines, M. Imbard) Open Bondary Conditions + !! NEMO 1.0 ! 2002-06 (G. Madec) free form, suppress macro-tasking + !! - ! 2004-08 (C. Talandier) New trends organization + !! - ! 2005-01 (C. Ethe) Add the KPP closure scheme + !! - ! 2005-11 (G. Madec) Reorganisation of tra and dyn calls + !! - ! 2006-01 (L. Debreu, C. Mazauric) Agrif implementation + !! - ! 2006-07 (S. Masson) restart using iom + !! 3.2 ! 2009-02 (G. Madec, R. Benshila) reintroduicing z*-coordinate + !! - ! 2009-06 (S. Masson, G. Madec) TKE restart compatible with key_cpl + !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface + !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA + !! 3.4 ! 2011-04 (G. Madec, C. Ethe) Merge of dtatem and dtasal + !! 3.6 ! 2012-07 (J. Simeon, G. Madec. C. Ethe) Online coarsening of outputs + !! 3.6 ! 2014-04 (F. Roquet, G. Madec) New equations of state + !! 3.6 ! 2014-10 (E. Clementi, P. Oddo) Add Qiao vertical mixing in case of waves + !! 3.7 ! 2014-10 (G. Madec) LDF simplication + !! - ! 2014-12 (G. Madec) remove KPP scheme + !! - ! 2015-11 (J. Chanut) free surface simplification (remove filtered free surface) + !! 4.0 ! 2017-05 (G. Madec) introduction of the vertical physics manager (zdfphy) + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rewrite in preparation for new timestepping scheme + !! 4.x ! 2020-08 (S. Techene, G. Madec) quasi eulerian coordinate time stepping + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! 'key_qco' Quasi-Eulerian vertical coordinate + !! OR + !! 'key_linssh Fixed in time vertical coordinate + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + !! stp_MLF : NEMO modified Leap Frog time-stepping with qco or linssh + !!---------------------------------------------------------------------- + USE step_oce ! time stepping definition modules + ! + USE domqco ! quasi-eulerian coordinate + USE traatf_qco ! time filtering (tra_atf_qco routine) + USE dynatf_qco ! time filtering (dyn_atf_qco routine) + + IMPLICIT NONE + PRIVATE + + PUBLIC stp_MLF ! called by nemogcm.F90 + + ! !** time level indices **! + INTEGER, PUBLIC :: Nbb, Nnn, Naa, Nrhs !: used by nemo_init + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: step.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE stp_MLF( kstp ) + INTEGER, INTENT(in) :: kstp ! ocean time-step index + !!---------------------------------------------------------------------- + !! *** ROUTINE stp_MLF *** + !! + !! ** Purpose : - Time stepping of OCE (momentum and active tracer eqs.) + !! - Time stepping of SI3 (dynamic and thermodynamic eqs.) + !! - Time stepping of TRC (passive tracer eqs.) + !! + !! ** Method : -1- Update forcings and data + !! -2- Update ocean physics + !! -3- Compute the t and s trends + !! -4- Update t and s + !! -5- Compute the momentum trends + !! -6- Update the horizontal velocity + !! -7- Compute the diagnostics variables (rd,N2, hdiv,w) + !! -8- Outputs and diagnostics + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk, jtile ! dummy loop indice + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zgdept + !! --------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('stp_MLF') + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! model timestep + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + IF( l_1st_euler ) THEN ! start or restart with Euler 1st time-step + rDt = rn_Dt + r1_Dt = 1._wp / rDt + ENDIF + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! update I/O and calendar + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + IF( kstp == nit000 ) THEN ! initialize IOM context (must be done after nemo_init for AGRIF+XIOS+OASIS) + CALL iom_init( cxios_context, ld_closedef=.FALSE. ) ! for model grid (including possible AGRIF zoom) + IF( lk_diamlr ) CALL dia_mlr_iom_init ! with additional setup for multiple-linear-regression analysis + CALL iom_init_closedef + IF( ln_crs ) CALL iom_init( TRIM(cxios_context)//"_crs" ) ! for coarse grid + ENDIF + IF( kstp == nitrst .AND. lwxios ) THEN + CALL iom_swap( cw_ocerst_cxt ) + CALL iom_init_closedef( cw_ocerst_cxt ) + CALL iom_setkt( kstp - nit000 + 1, cw_ocerst_cxt ) + ENDIF + IF( kstp + nn_fsbc - 1 == nitrst .AND. lwxios ) THEN + IF( ln_abl ) THEN + CALL iom_swap( cw_ablrst_cxt ) + CALL iom_init_closedef( cw_ablrst_cxt ) + CALL iom_setkt( kstp - nit000 + 1, cw_ablrst_cxt ) + ENDIF + ENDIF + IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) + CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell IOM we are at time step kstp + IF( ln_crs ) CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" ) ! tell IOM we are at time step kstp + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Update external forcing (tides, open boundaries, ice shelf interaction and surface boundary condition (including sea-ice) + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_tide ) CALL tide_update( kstp ) ! update tide potential + IF( ln_apr_dyn ) CALL sbc_apr ( kstp ) ! atmospheric pressure (NB: call before bdy_dta which needs ssh_ib) + IF( ln_bdy ) CALL bdy_dta ( kstp, Nnn ) ! update dynamic & tracer data at open boundaries + IF( ln_isf ) CALL isf_stp ( kstp, Nnn ) + CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Condition (including sea-ice) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Update stochastic parameters and random T/S fluctuations + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF( ln_sto_eos ) CALL sto_par( kstp ) ! Stochastic parameters + IF( ln_sto_eos ) CALL sto_pts( ts(:,:,:,:,Nnn) ) ! Random T/S fluctuations + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Ocean physics update + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! THERMODYNAMICS + CALL eos_rab( ts(:,:,:,:,Nbb), rab_b, Nnn ) ! before local thermal/haline expension ratio at T-points + CALL eos_rab( ts(:,:,:,:,Nnn), rab_n, Nnn ) ! now local thermal/haline expension ratio at T-points + CALL bn2 ( ts(:,:,:,:,Nbb), rab_b, rn2b, Nnn ) ! before Brunt-Vaisala frequency + CALL bn2 ( ts(:,:,:,:,Nnn), rab_n, rn2, Nnn ) ! now Brunt-Vaisala frequency + + ! VERTICAL PHYSICS + IF( ln_tile ) CALL dom_tile_start ! [tiling] ZDF tiling loop + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + CALL zdf_phy( kstp, Nbb, Nnn, Nrhs ) ! vertical physics update (top/bot drag, avt, avs, avm + MLD) + END DO + IF( ln_tile ) CALL dom_tile_stop + + ! LATERAL PHYSICS + ! + IF( ln_zps .OR. l_ldfslp ) CALL eos( ts(:,:,:,:,Nbb), rhd, gdept_0(:,:,:) ) ! before in situ density + + IF( ln_zps .AND. .NOT. ln_isfcav) & + & CALL zps_hde ( kstp, Nnn, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient + & rhd, gru , grv ) ! of t, s, rd at the last ocean level + + IF( ln_zps .AND. ln_isfcav) & + & CALL zps_hde_isf( kstp, Nnn, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) + & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level + + IF( l_ldfslp ) THEN ! slope of lateral mixing + IF( ln_traldf_triad ) THEN + CALL ldf_slp_triad( kstp, Nbb, Nnn ) ! before slope for triad operator + ELSE + CALL ldf_slp ( kstp, rhd, rn2b, Nbb, Nnn ) ! before slope for standard operator + ENDIF + ENDIF + ! ! eddy diffusivity coeff. + IF( l_ldftra_time .OR. l_ldfeiv_time ) CALL ldf_tra( kstp, Nbb, Nnn ) ! and/or eiv coeff. + IF( l_ldfdyn_time ) CALL ldf_dyn( kstp, Nbb ) ! eddy viscosity coeff. + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Ocean dynamics : hdiv, ssh, e3, u, v, w + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + CALL ssh_nxt ( kstp, Nbb, Nnn, ssh, Naa ) ! after ssh (includes call to div_hor) + IF( .NOT.lk_linssh ) THEN + CALL dom_qco_r3c( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa) ) ! "after" ssh/h_0 ratio at t,u,v pts + IF( ln_dynspg_exp ) & + & CALL dom_qco_r3c( ssh(:,:,Nnn), r3t(:,:,Nnn), r3u(:,:,Nnn), r3v(:,:,Nnn), r3f(:,:) ) ! spg_exp : needed only for "now" ssh/h_0 ratio at f point + ENDIF + CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! Nnn cross-level velocity + IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning + ALLOCATE( zgdept(jpi,jpj,jpk) ) + DO jk = 1, jpk + zgdept(:,:,jk) = (gdept_0(:,:,jk)*(1._wp+r3t(:,:,Nnn))) + END DO + CALL eos ( ts(:,:,:,:,Nnn), rhd, rhop, zgdept ) ! now in situ density for hpg computation + DEALLOCATE( zgdept ) + + uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero + vv(:,:,:,Nrhs) = 0._wp + + IF( ln_dyndmp .AND. ln_c1d ) CALL dyn_dmp( kstp, Nbb, Nnn, uu(:,:,:,Nrhs), vv(:,:,:,Nrhs), Nrhs ) ! internal damping trends- momentum + + IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (1) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + IF( lk_asminc .AND. ln_asmiau .AND. ln_dyninc ) & + & CALL dyn_asm_inc ( kstp, Nbb, Nnn, uu, vv, Nrhs ) ! apply dynamics assimilation increment + IF( ln_bkgwri ) CALL asm_bkg_wri( kstp, Nnn ) ! output background fields + IF( ln_bdy ) CALL bdy_dyn3d_dmp ( kstp, Nbb, uu, vv, Nrhs ) ! bdy damping trends + CALL dyn_adv( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! advection (VF or FF) ==> RHS + CALL dyn_vor( kstp, Nnn , uu, vv, Nrhs ) ! vorticity ==> RHS + CALL dyn_ldf( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! lateral mixing + IF( ln_zdfosm ) CALL dyn_osm( kstp, Nnn , uu, vv, Nrhs ) ! OSMOSIS non-local velocity fluxes ==> RHS + CALL dyn_hpg( kstp, Nnn , uu, vv, Nrhs ) ! horizontal gradient of Hydrostatic pressure + END DO + IF( ln_tile ) CALL dom_tile_stop + + CALL dyn_spg( kstp, Nbb, Nnn, Nrhs, uu, vv, ssh, uu_b, vv_b, Naa ) ! surface pressure gradient + + IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (2) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + IF( ln_dynspg_ts ) THEN ! With split-explicit free surface, since now transports have been updated and ssh(:,:,Nrhs) + ! as well as vertical scale factors and vertical velocity need to be updated + CALL div_hor ( kstp, Nbb, Nnn ) ! Horizontal divergence (2nd call in time-split case) + IF(.NOT.lk_linssh) CALL dom_qco_r3c( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa), r3f(:,:) ) ! update ssh/h_0 ratio at t,u,v,f pts + ENDIF + CALL dyn_zdf ( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa ) ! vertical diffusion + END DO + IF( ln_tile ) CALL dom_tile_stop + + IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated + CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! Nnn cross-level velocity + IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning + ENDIF + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! cool skin + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF ( ln_diurnal ) CALL diurnal_layers( kstp ) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! diagnostics and outputs + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_floats ) CALL flo_stp ( kstp, Nbb, Nnn ) ! drifting Floats + IF( ln_diacfl ) CALL dia_cfl ( kstp, Nnn ) ! Courant number diagnostics + CALL dia_hth ( kstp, Nnn ) ! Thermocline depth (20 degres isotherm depth) + IF( ln_diadct ) CALL dia_dct ( kstp, Nnn ) ! Transports + CALL dia_ar5 ( kstp, Nnn ) ! ar5 diag + CALL dia_ptr ( kstp, Nnn ) ! Poleward adv/ldf TRansports diagnostics + CALL dia_wri ( kstp, Nnn ) ! ocean model: outputs + IF( ln_crs ) CALL crs_fld ( kstp, Nnn ) ! ocean model: online field coarsening & output + IF( lk_diadetide ) CALL dia_detide( kstp ) ! Weights computation for daily detiding of model diagnostics + IF( lk_diamlr ) CALL dia_mlr ! Update time used in multiple-linear-regression analysis + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Now ssh filtering + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height + IF(.NOT.lk_linssh) CALL dom_qco_r3c( ssh(:,:,Nnn), r3t_f, r3u_f, r3v_f ) ! "now" ssh/h_0 ratio from filtrered ssh + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Active tracers + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ts(:,:,:,:,Nrhs) = 0._wp ! set tracer trends to zero + + IF( ln_tile ) CALL dom_tile_start ! [tiling] TRA tiling loop (1) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + IF( lk_asminc .AND. ln_asmiau .AND. & + & ln_trainc ) CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs ) ! apply tracer assimilation increment + CALL tra_sbc ( kstp, Nnn, ts, Nrhs ) ! surface boundary condition + IF( ln_traqsr ) CALL tra_qsr ( kstp, Nnn, ts, Nrhs ) ! penetrative solar radiation qsr + IF( ln_isf ) CALL tra_isf ( kstp, Nnn, ts, Nrhs ) ! ice shelf heat flux + IF( ln_trabbc ) CALL tra_bbc ( kstp, Nnn, ts, Nrhs ) ! bottom heat flux + IF( ln_trabbl ) CALL tra_bbl ( kstp, Nbb, Nnn, ts, Nrhs ) ! advective (and/or diffusive) bottom boundary layer scheme + IF( ln_tradmp ) CALL tra_dmp ( kstp, Nbb, Nnn, ts, Nrhs ) ! internal damping trends + IF( ln_bdy ) CALL bdy_tra_dmp( kstp, Nbb, ts, Nrhs ) ! bdy damping trends + END DO + IF( ln_tile ) CALL dom_tile_stop + + + ! TEMP: [tiling] Separate loop over tile domains (due to tra_adv workarounds for tiling) + IF( ln_tile ) CALL dom_tile_start ! [tiling] TRA tiling loop (2) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + CALL tra_adv ( kstp, Nbb, Nnn, ts, Nrhs ) ! hor. + vert. advection ==> RHS + IF( ln_zdfmfc ) CALL tra_mfc ( kstp, Nbb, ts, Nrhs ) ! Mass Flux Convection + IF( ln_zdfosm ) THEN + CALL tra_osm ( kstp, Nnn, ts, Nrhs ) ! OSMOSIS non-local tracer fluxes ==> RHS + IF( lrst_oce ) CALL osm_rst ( kstp, Nnn, 'WRITE' ) ! write OSMOSIS outputs + ww (so must do here) to restarts + ENDIF + CALL tra_ldf ( kstp, Nbb, Nnn, ts, Nrhs ) ! lateral mixing + + CALL tra_zdf ( kstp, Nbb, Nnn, Nrhs, ts, Naa ) ! vertical mixing and after tracer fields + IF( ln_zdfnpc ) CALL tra_npc ( kstp, Nnn, Nrhs, ts, Naa ) ! update after fields by non-penetrative convection + END DO + IF( ln_tile ) CALL dom_tile_stop + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Set boundary conditions, time filter and swap time levels + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!!jc1: For agrif, it would be much better to finalize tracers/momentum here (e.g. bdy conditions) and move the swap +!! (and time filtering) after Agrif update. Then restart would be done after and would contain updated fields. +!! If so: +!! (i) no need to call agrif update at initialization time +!! (ii) no need to update "before" fields +!! +!! Apart from creating new tra_swp/dyn_swp routines, this however: +!! (i) makes boundary conditions at initialization time computed from updated fields which is not the case between +!! two restarts => restartability issue. One can circumvent this, maybe, by assuming "interface separation", +!! e.g. a shift of the feedback interface inside child domain. +!! (ii) requires that all restart outputs of updated variables by agrif (e.g. passive tracers/tke/barotropic arrays) are done at the same +!! place. +!! + IF( ln_dynspg_ts ) CALL mlf_baro_corr ( Nnn, Naa, uu, vv ) ! barotrope adjustment + CALL finalize_lbc ( kstp, Nbb , Naa, uu, vv, ts ) ! boundary conditions + CALL tra_atf_qco ( kstp, Nbb, Nnn, Naa , ts ) ! time filtering of "now" tracer arrays + CALL dyn_atf_qco ( kstp, Nbb, Nnn, Naa, uu, vv ) ! time filtering of "now" velocities + IF(.NOT.lk_linssh) THEN + r3t(:,:,Nnn) = r3t_f(:,:) ! update now ssh/h_0 with time filtered values + r3u(:,:,Nnn) = r3u_f(:,:) + r3v(:,:,Nnn) = r3v_f(:,:) + ENDIF + ! + ! Swap time levels + Nrhs = Nbb + Nbb = Nnn + Nnn = Naa + Naa = Nrhs + ! + ! + IF( ln_diahsb ) CALL dia_hsb ( kstp, Nbb, Nnn ) ! - ML - global conservation diagnostics + +!!gm : This does not only concern the dynamics ==>>> add a new title +!!gm2: why ouput restart before AGRIF update? +!! +!!jc: That would be better, but see comment above +!! + IF( lrst_oce ) CALL rst_write ( kstp, Nbb, Nnn ) ! write output ocean restart file + IF( ln_sto_eos ) CALL sto_rst_write( kstp ) ! write restart file for stochastic parameters + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Control + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL stp_ctl ( kstp, Nnn ) + + IF( ln_diaobs .AND. nstop == 0 ) & + & CALL dia_obs( kstp, Nnn ) ! obs-minus-model (assimilation) diags (after dynamics update) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! File manipulation at the end of the first time step + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( kstp == nit000 ) THEN ! 1st time step only + CALL iom_close( numror ) ! close input ocean restart file + IF( lrxios ) CALL iom_context_finalize( cr_ocerst_cxt ) + IF(lwm) CALL FLUSH ( numond ) ! flush output namelist oce + IF(lwm .AND. numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice (if exist) + ENDIF + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Coupled mode + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( lk_oasis .AND. nstop == 0 ) CALL sbc_cpl_snd( kstp, Nbb, Nnn ) ! coupled mode : field exchanges + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Finalize contextes if end of simulation or error detected + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( kstp == nitend .OR. nstop > 0 ) THEN + CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF + IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! + ENDIF + ! + IF( l_1st_euler ) THEN ! recover Leap-frog timestep + rDt = 2._wp * rn_Dt + r1_Dt = 1._wp / rDt + l_1st_euler = .FALSE. + ENDIF + ! + IF( ln_timing ) CALL timing_stop('stp_MLF') + ! + END SUBROUTINE stp_MLF + + SUBROUTINE mlf_baro_corr( Kmm, Kaa, puu, pvv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mlf_baro_corr *** + !! + !! ** Purpose : Finalize after horizontal velocity. + !! + !! ** Method : * Ensure after velocities transport matches time splitting + !! estimate (ln_dynspg_ts=T) + !! + !! ** Action : puu(Kmm),pvv(Kmm) updated now horizontal velocity (ln_bt_fw=F) + !! puu(Kaa),pvv(Kaa) after horizontal velocity + !!---------------------------------------------------------------------- + USE dynspg_ts, ONLY : un_adv, vn_adv ! updated Kmm barotropic transport + !! + INTEGER , INTENT(in ) :: Kmm, Kaa ! before and after time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities + ! + INTEGER :: ji,jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zue, zve + !!---------------------------------------------------------------------- + + ! Ensure below that barotropic velocities match time splitting estimate + ! Compute actual transport and replace it with ts estimate at "after" time step + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zue(ji,jj) = (e3u_0(ji,jj,1)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,1))) * puu(ji,jj,1,Kaa) * umask(ji,jj,1) + zve(ji,jj) = (e3v_0(ji,jj,1)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,1))) * pvv(ji,jj,1,Kaa) * vmask(ji,jj,1) + END DO ; END DO + DO jk = 2, jpkm1 + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zue(ji,jj) = zue(ji,jj) + (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kaa)*umask(ji,jj,jk))) * puu(ji,jj,jk,Kaa) * umask(ji,jj,jk) + zve(ji,jj) = zve(ji,jj) + (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kaa)*vmask(ji,jj,jk))) * pvv(ji,jj,jk,Kaa) * vmask(ji,jj,jk) + END DO ; END DO + END DO + DO jk = 1, jpkm1 + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - zue(ji,jj) * (r1_hu_0(ji,jj)/(1._wp+r3u(ji,jj,Kaa))) + uu_b(ji,jj,Kaa) ) * umask(ji,jj,jk) + pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - zve(ji,jj) * (r1_hv_0(ji,jj)/(1._wp+r3v(ji,jj,Kaa))) + vv_b(ji,jj,Kaa) ) * vmask(ji,jj,jk) + END DO ; END DO + END DO + ! + IF( .NOT.ln_bt_fw ) THEN + ! Remove advective velocity from "now velocities" + ! prior to asselin filtering + ! In the forward case, this is done below after asselin filtering + ! so that asselin contribution is removed at the same time + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = ( puu(:,:,jk,Kmm) - un_adv(:,:)*(r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm))) + uu_b(:,:,Kmm) )*umask(:,:,jk) + pvv(:,:,jk,Kmm) = ( pvv(:,:,jk,Kmm) - vn_adv(:,:)*(r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm))) + vv_b(:,:,Kmm) )*vmask(:,:,jk) + END DO + ENDIF + ! + END SUBROUTINE mlf_baro_corr + + + SUBROUTINE finalize_lbc( kt, Kbb, Kaa, puu, pvv, pts ) + !!---------------------------------------------------------------------- + !! *** ROUTINE finalize_lbc *** + !! + !! ** Purpose : Apply the boundary condition on the after velocity + !! + !! ** Method : * Apply lateral boundary conditions on after velocity + !! at the local domain boundaries through lbc_lnk call, + !! at the one-way open boundaries (ln_bdy=T), + !! at the AGRIF zoom boundaries (lk_agrif=T) + !! + !! ** Action : puu(Kaa),pvv(Kaa) after horizontal velocity and tracers + !!---------------------------------------------------------------------- + USE bdydyn ! ocean open boundary conditions (define bdy_dyn) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kaa ! before and after time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt) , INTENT(inout) :: puu, pvv ! velocities to be time filtered + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers + !!---------------------------------------------------------------------- + ! + ! Update after tracer and velocity on domain lateral boundaries + ! + ! ! local domain boundaries (T-point, unchanged sign) + CALL lbc_lnk( 'finalize_lbc', puu(:,:,:, Kaa), 'U', -1., pvv(:,:,: ,Kaa), 'V', -1. & + & , pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) + ! + ! lbc_lnk needed for zdf_sh2 when using nn_hls = 2, moved here to allow tiling in zdf_phy + IF( nn_hls == 2 .AND. l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_wp ) + + ! dom_qco_r3c defines over [nn_hls, nn_hls-1, nn_hls, nn_hls-1] + IF( nn_hls == 2 .AND. .NOT. lk_linssh ) THEN + CALL lbc_lnk( 'finalize_lbc', r3u(:,:,Kaa), 'U', 1._wp, r3v(:,:,Kaa), 'V', 1._wp, & + & r3u_f(:,:), 'U', 1._wp, r3v_f(:,:), 'V', 1._wp ) + ENDIF + ! !* BDY open boundaries + IF( ln_bdy ) THEN + CALL bdy_tra( kt, Kbb, pts, Kaa ) + IF( ln_dynspg_exp ) CALL bdy_dyn( kt, Kbb, puu, pvv, Kaa ) + IF( ln_dynspg_ts ) CALL bdy_dyn( kt, Kbb, puu, pvv, Kaa, dyn3d_only=.true. ) + ENDIF + ! + END SUBROUTINE finalize_lbc + + + !!====================================================================== +END MODULE stpmlf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tide_mod.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tide_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dac823467f14dad43a0d638663d67d9c9e8195ba --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tide_mod.f90 @@ -0,0 +1,979 @@ + + + + + + + + + + + + + +MODULE tide_mod + !!====================================================================== + !! *** MODULE tide_mod *** + !! Compute nodal modulations corrections and pulsations + !!====================================================================== + !! History : 1.0 ! 2007 (O. Le Galloudec) Original code + !! ! 2019 (S. Mueller) + !!---------------------------------------------------------------------- + !! + !! ** Reference : + !! S58) Schureman, P. (1958): Manual of Harmonic Analysis and + !! Prediction of Tides (Revised (1940) Edition (Reprinted 1958 + !! with corrections). Reprinted June 2001). U.S. Department of + !! Commerce, Coast and Geodetic Survey Special Publication + !! No. 98. Washington DC, United States Government Printing + !! Office. 317 pp. DOI: 10.25607/OBP-155. + !!---------------------------------------------------------------------- + + USE oce, ONLY : ssh ! sea-surface height + USE par_oce ! ocean parameters + USE phycst, ONLY : rpi, rad, rday + USE daymod, ONLY : ndt05 ! half-length of time step + USE in_out_manager ! I/O units + USE iom ! xIOs server + + IMPLICIT NONE + PRIVATE + + PUBLIC tide_init + PUBLIC tide_update ! called by stp + PUBLIC tide_init_harmonics ! called internally and by module diaharm + PUBLIC upd_tide ! called in dynspg_... modules + + INTEGER, PUBLIC, PARAMETER :: jpmax_harmo = 64 !: maximum number of harmonic components + + TYPE :: tide + CHARACTER(LEN=4) :: cname_tide = '' + REAL(wp) :: equitide + INTEGER :: nt, ns, nh, np, np1, shift + INTEGER :: nksi, nnu0, nnu1, nnu2, R + INTEGER :: nformula + END TYPE tide + + TYPE(tide), DIMENSION(:), POINTER :: tide_components !: Array of selected tidal component parameters + + TYPE, PUBLIC :: tide_harmonic !: Oscillation parameters of harmonic tidal components + CHARACTER(LEN=4) :: cname_tide ! Name of component + REAL(wp) :: equitide ! Amplitude of equilibrium tide + REAL(wp) :: f ! Node factor + REAL(wp) :: omega ! Angular velocity + REAL(wp) :: v0 ! Initial phase at prime meridian + REAL(wp) :: u ! Phase correction + END type tide_harmonic + + TYPE(tide_harmonic), PUBLIC, DIMENSION(:), POINTER :: tide_harmonics !: Oscillation parameters of selected tidal components + + LOGICAL , PUBLIC :: ln_tide !: + LOGICAL , PUBLIC :: ln_tide_pot !: + INTEGER :: nn_tide_var ! Variant of tidal parameter set and tide-potential computation + LOGICAL :: ln_tide_dia ! Enable tidal diagnostic output + LOGICAL :: ln_read_load !: + LOGICAL , PUBLIC :: ln_scal_load !: + LOGICAL , PUBLIC :: ln_tide_ramp !: + INTEGER , PUBLIC :: nb_harmo !: Number of active tidal components + REAL(wp), PUBLIC :: rn_tide_ramp_dt !: + REAL(wp), PUBLIC :: rn_scal_load !: + CHARACTER(lc), PUBLIC :: cn_tide_load !: + REAL(wp) :: rn_tide_gamma ! Tidal tilt factor + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pot_astro !: tidal potential + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: pot_astro_comp ! tidal-potential component + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_pot, phi_pot + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_load, phi_load + + REAL(wp) :: rn_tide_ramp_t ! Elapsed time in seconds + + REAL(wp) :: sh_T, sh_s, sh_h, sh_p, sh_p1 ! astronomic angles + REAL(wp) :: sh_xi, sh_nu, sh_nuprim, sh_nusec, sh_R ! + REAL(wp) :: sh_I, sh_x1ra, sh_N ! + + ! Longitudes on 1 Jan 1900, 00h and angular velocities (units of deg and + ! deg/h, respectively. The values of these module variables have been copied + ! from subroutine astronomic_angle of the version of this module used in + ! release version 4.0 of NEMO. + REAL(wp) :: rlon00_N = 259.1560564_wp ! Longitude of ascending lunar node + REAL(wp) :: romega_N = -.0022064139_wp + REAL(wp) :: rlon00_T = 180.0_wp ! Mean solar angle (GMT) + REAL(wp) :: romega_T = 15.0_wp + REAL(wp) :: rlon00_h = 280.1895014_wp ! Mean solar Longitude + REAL(wp) :: romega_h = .0410686387_wp + REAL(wp) :: rlon00_s = 277.0256206_wp ! Mean lunar Longitude + REAL(wp) :: romega_s = .549016532_wp + REAL(wp) :: rlon00_p1 = 281.2208569_wp ! Longitude of solar perigee + REAL(wp) :: romega_p1 = .000001961_wp + REAL(wp) :: rlon00_p = 334.3837214_wp ! Longitude of lunar perigee + REAL(wp) :: romega_p = .004641834_wp + ! Values of cos(i)*cos(epsilon), rcice, and sin(incl)*sin(epsilon), rsise, + ! where i is the inclination of the orbit of the Moon w.r.t. the ecliptic and + ! epsilon the obliquity of the ecliptic on 1 January 1900, 00h. The values of + ! these module variables have been copied from subroutine astronomic_angle + ! (computation of the cosine of inclination of orbit of Moon to the celestial + ! equator) of the version of this module used in release version 4.0 of NEMO. + REAL(wp) :: rcice = 0.913694997_wp + REAL(wp) :: rsise = 0.035692561_wp + ! Coefficients used to compute sh_xi and sh_nu in subroutine astronomic_angle + ! according to two equations given in the explanation of Table 6 of S58 + REAL(wp) :: rxinu1, rxinu2 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: tide_mod.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tide_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init *** + !!---------------------------------------------------------------------- + INTEGER :: ji, jk + CHARACTER(LEN=4), DIMENSION(jpmax_harmo) :: sn_tide_cnames ! Names of selected tidal components + INTEGER :: ios ! Local integer output status for namelist read + ! + NAMELIST/nam_tide/ln_tide, nn_tide_var, ln_tide_dia, ln_tide_pot, rn_tide_gamma, & + & ln_scal_load, ln_read_load, cn_tide_load, & + & ln_tide_ramp, rn_scal_load, rn_tide_ramp_dt, & + & sn_tide_cnames + !!---------------------------------------------------------------------- + ! + ! Initialise all array elements of sn_tide_cnames, as some of them + ! typically do not appear in namelist_ref or namelist_cfg + sn_tide_cnames(:) = '' + ! Read Namelist nam_tide + READ ( numnam_ref, nam_tide, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_tide in reference namelist' ) + ! + READ ( numnam_cfg, nam_tide, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_tide in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_tide ) + ! + IF( ln_tide ) THEN + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'tide_init : Initialization of the tidal components' + WRITE(numout,*) '~~~~~~~~~ ' + WRITE(numout,*) ' Namelist nam_tide' + WRITE(numout,*) ' Use tidal components ln_tide = ', ln_tide + WRITE(numout,*) ' Variant (1: default; 0: legacy option) nn_tide_var = ', nn_tide_var + WRITE(numout,*) ' Tidal diagnostic output ln_tide_dia = ', ln_tide_dia + WRITE(numout,*) ' Apply astronomical potential ln_tide_pot = ', ln_tide_pot + WRITE(numout,*) ' Tidal tilt factor rn_tide_gamma = ', rn_tide_gamma + WRITE(numout,*) ' Use scalar approx. for load potential ln_scal_load = ', ln_scal_load + WRITE(numout,*) ' Read load potential from file ln_read_load = ', ln_read_load + WRITE(numout,*) ' Apply ramp on tides at startup ln_tide_ramp = ', ln_tide_ramp + WRITE(numout,*) ' Fraction of SSH used in scal. approx. rn_scal_load = ', rn_scal_load + WRITE(numout,*) ' Duration (days) of ramp rn_tide_ramp_dt = ', rn_tide_ramp_dt + ENDIF + ELSE + rn_scal_load = 0._wp + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tide_init : tidal components not used (ln_tide = F)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~ ' + RETURN + ENDIF + ! + IF( ln_read_load.AND.(.NOT.ln_tide_pot) ) & + & CALL ctl_stop('ln_read_load requires ln_tide_pot') + IF( ln_scal_load.AND.(.NOT.ln_tide_pot) ) & + & CALL ctl_stop('ln_scal_load requires ln_tide_pot') + IF( ln_scal_load.AND.ln_read_load ) & + & CALL ctl_stop('Choose between ln_scal_load and ln_read_load') + IF( ln_tide_ramp.AND.((nitend-nit000+1)*rn_Dt/rday < rn_tide_ramp_dt) ) & + & CALL ctl_stop('rn_tide_ramp_dt must be lower than run duration') + IF( ln_tide_ramp.AND.(rn_tide_ramp_dt<0.) ) & + & CALL ctl_stop('rn_tide_ramp_dt must be positive') + ! + ! Compute coefficients which are used in subroutine astronomic_angle to + ! compute sh_xi and sh_nu according to two equations given in the + ! explanation of Table 6 of S58 + rxinu1 = COS( 0.5_wp * ( ABS( ACOS( rcice + rsise ) ) ) ) / COS( 0.5_wp * ( ACOS( rcice - rsise ) ) ) + rxinu2 = SIN( 0.5_wp * ( ABS( ACOS( rcice + rsise ) ) ) ) / SIN( 0.5_wp * ( ACOS( rcice - rsise ) ) ) + ! + ! Initialise array used to store tidal oscillation parameters (frequency, + ! amplitude, phase); also retrieve and store array of information about + ! selected tidal components + CALL tide_init_harmonics(sn_tide_cnames, tide_harmonics, tide_components) + ! + ! Number of active tidal components + nb_harmo = size(tide_components) + ! + ! Ensure that tidal components have been set in namelist_cfg + IF( nb_harmo == 0 ) CALL ctl_stop( 'tide_init : No tidal components set in nam_tide' ) + ! + IF (.NOT.ln_scal_load ) rn_scal_load = 0._wp + ! + ALLOCATE( amp_pot(jpi,jpj,nb_harmo), & + & phi_pot(jpi,jpj,nb_harmo), pot_astro(jpi,jpj) ) + IF( ln_tide_dia ) ALLOCATE( pot_astro_comp(jpi,jpj) ) + IF( ln_read_load ) THEN + ALLOCATE( amp_load(jpi,jpj,nb_harmo), phi_load(jpi,jpj,nb_harmo) ) + CALL tide_init_load + amp_pot(:,:,:) = amp_load(:,:,:) + phi_pot(:,:,:) = phi_load(:,:,:) + ELSE + amp_pot(:,:,:) = 0._wp + phi_pot(:,:,:) = 0._wp + ENDIF + ! + END SUBROUTINE tide_init + + + SUBROUTINE tide_init_components(pcnames, ptide_comp) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_components *** + !! + !! Returns pointer to array of variables of type 'tide' that contain + !! information about the selected tidal components + !! ---------------------------------------------------------------------- + CHARACTER(LEN=4), DIMENSION(jpmax_harmo), INTENT(in) :: pcnames ! Names of selected components + TYPE(tide), POINTER, DIMENSION(:), INTENT(out) :: ptide_comp ! Selected components + INTEGER, ALLOCATABLE, DIMENSION(:) :: icomppos ! Indices of selected components + INTEGER :: icomp, jk, jj, ji ! Miscellaneous integers + LOGICAL :: llmatch ! Local variables used for + INTEGER :: ic1, ic2 ! string comparison + TYPE(tide), POINTER, DIMENSION(:) :: tide_components ! All available components + + ! Populate local array with information about all available tidal + ! components + ! + ! Note, here 'tide_components' locally overrides the global module + ! variable of the same name to enable the use of the global name in the + ! include file that contains the initialisation of elements of array + ! 'tide_components' + ALLOCATE(tide_components(jpmax_harmo), icomppos(jpmax_harmo)) + ! Initialise array of indices of the selected componenents + icomppos(:) = 0 + ! Include tidal component parameters for all available components + IF (nn_tide_var < 1) THEN +!!===================================================================== + !! *** Include file tide.h90 *** + !!====================================================================== + !! History : 3.2 ! 2007 (O. Le Galloudec) Original code + !! ! 2019 (S. Mueller, N. Bruneau) Alternative parameter set + !!---------------------------------------------------------------------- + !! + !! ** Purpose : Inclusion of alternative variants of tidal-constituent + !! parameter definitions during code preprocessing: the default + !! variant includes the 34 constituents available in the FES2014 + !! version of the Finite Element Solution - Global Tide data + !! product + !! (https://www.aviso.altimetry.fr/en/data/products/auxiliary-products/global-tide-fes.html); + !! also available is the default parameter set available in + !! previous NEMO versions + !! + !! ** References : + !! S58) Schureman, P. (1958): Manual of Harmonic Analysis and + !! Prediction of Tides (Revised (1940) Edition (Reprinted 1958 + !! with corrections). Reprinted June 2001). U.S. Department of + !! Commerce, Coast and Geodetic Survey Special Publication + !! No. 98. Washington DC, United States Government Printing + !! Office. 317 pp. DOI: 10.25607/OBP-155. + !! CT71) Cartwright, D. E. and Tayler, R. J. (1971): New computations of + !! the Tide-generating Potential. Geophys. J. R. astr. Soc. 23, + !! pp. 45-74. DOI: 10.1111/j.1365-246X.1971.tb01803.x + !! CE73) Cartwright, D. E. and Edden, A. C. (1973): Corrected Tables of + !! Tidal Harmonics. Geophys. J. R. astr. Soc. 33, + !! pp. 253-264. DOI: 10.1111/j.1365-246X.1973.tb03420.x + !! FES2014) FES (Finite element Solution) - Global + !! tide. https://www.aviso.altimetry.fr/en/data/products/auxiliary-products/global-tide-fes.html + !! + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2019) + !! $Id: tide.h90 14502 2021-02-18 18:48:54Z smueller $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + ! !! name_tide , equitide , nt , ns , nh , np , np1 , shift , nksi , nnu0 , nnu1 , nnu2 , R , formula !! + ! !! ! ! ! ! ! ! ! ! ! ! ! ! ! !! + tide_components( 1) = tide( 'M2' , 0.242297 , 2 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components( 2) = tide( 'N2' , 0.046313 , 2 , -3 , 2 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components( 3) = tide( '2N2' , 0.006184 , 2 , -4 , 2 , 2 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components( 4) = tide( 'S2' , 0.113572 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) + tide_components( 5) = tide( 'K2' , 0.030875 , 2 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , -2 , 0 , 235 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components( 6) = tide( 'K1' , 0.142408 , 1 , 0 , 1 , 0 , 0 , -90 , 0 , 0 , -1 , 0 , 0 , 227 ) + tide_components( 7) = tide( 'O1' , 0.101266 , 1 , -2 , 1 , 0 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) + tide_components( 8) = tide( 'Q1' , 0.019387 , 1 , -3 , 1 , 1 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) + tide_components( 9) = tide( 'P1' , 0.047129 , 1 , 0 , -1 , 0 , 0 , +90 , 0 , 0 , 0 , 0 , 0 , 0 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components(10) = tide( 'M4' , 0.000000 , 4 , -4 , 4 , 0 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components(11) = tide( 'Mf' , 0.042017 , 0 , 2 , 0 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + tide_components(12) = tide( 'Mm' , 0.022191 , 0 , 1 , 0 , -1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) + tide_components(13) = tide( 'Msqm' , 0.000667 , 0 , 4 , -2 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + tide_components(14) = tide( 'Mtm' , 0.008049 , 0 , 3 , 0 , -1 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components(15) = tide( 'S1' , 0.000000 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) + tide_components(16) = tide( 'MU2' , 0.005841 , 2 , -4 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components(17) = tide( 'NU2' , 0.009094 , 2 , -3 , 4 , -1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components(18) = tide( 'L2' , 0.006694 , 2 , -1 , 2 , -1 , 0 , +180 , 2 , -2 , 0 , 0 , 0 , 215 ) + tide_components(19) = tide( 'T2' , 0.006614 , 2 , 0 , -1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) + ELSE +!!===================================================================== + !! *** Include file tide.h90 *** + !!====================================================================== + !! History : 3.2 ! 2007 (O. Le Galloudec) Original code + !! ! 2019 (S. Mueller, N. Bruneau) Alternative parameter set + !!---------------------------------------------------------------------- + !! + !! ** Purpose : Inclusion of alternative variants of tidal-constituent + !! parameter definitions during code preprocessing: the default + !! variant includes the 34 constituents available in the FES2014 + !! version of the Finite Element Solution - Global Tide data + !! product + !! (https://www.aviso.altimetry.fr/en/data/products/auxiliary-products/global-tide-fes.html); + !! also available is the default parameter set available in + !! previous NEMO versions + !! + !! ** References : + !! S58) Schureman, P. (1958): Manual of Harmonic Analysis and + !! Prediction of Tides (Revised (1940) Edition (Reprinted 1958 + !! with corrections). Reprinted June 2001). U.S. Department of + !! Commerce, Coast and Geodetic Survey Special Publication + !! No. 98. Washington DC, United States Government Printing + !! Office. 317 pp. DOI: 10.25607/OBP-155. + !! CT71) Cartwright, D. E. and Tayler, R. J. (1971): New computations of + !! the Tide-generating Potential. Geophys. J. R. astr. Soc. 23, + !! pp. 45-74. DOI: 10.1111/j.1365-246X.1971.tb01803.x + !! CE73) Cartwright, D. E. and Edden, A. C. (1973): Corrected Tables of + !! Tidal Harmonics. Geophys. J. R. astr. Soc. 33, + !! pp. 253-264. DOI: 10.1111/j.1365-246X.1973.tb03420.x + !! FES2014) FES (Finite element Solution) - Global + !! tide. https://www.aviso.altimetry.fr/en/data/products/auxiliary-products/global-tide-fes.html + !! + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2019) + !! $Id: tide.h90 14502 2021-02-18 18:48:54Z smueller $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Name | Equilibrium | nt | ns | nh | np | np1 | Phase | nxi | nnu0 | nnu1 | nnu2 | R | Nodal | Equilibrium | Parameters source | Notes | + ! | | tide | | | | | | shift | | | | | | correction | tide | | | + ! | | | | | | | | | | | | | | formula | source/comment | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Long-period tidal constituents | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 1) = tide( 'Mf' , 0.042054_wp , 0 , 2 , 1 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) ! CE73 | S54 (Table 2, A6) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 2) = tide( 'Mm' , 0.022187_wp , 0 , 1 , 0 , -1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) ! CE73 | S54 (Table 2, A2) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 3) = tide( 'Ssa' , 0.019572_wp , 0 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B6) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 4) = tide( 'Mtm' , 0.008052_wp , 0 , 3 , 0 , -1 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) ! CE73 | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm); S54 | | + ! | | | | | | | | | | | | | | | | (Table 2, A7) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 5) = tide( 'Msf' , 0.003677_wp , 0 , 2 , -2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) ! CE73 | S54 (Table 2, A5) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 6) = tide( 'Msqm' , 0.001287_wp , 0 , 4 , -2 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) ! CE73 | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm); S54 | | + ! | | | | | | | | | | | | | | | | (Table 2, A12) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 7) = tide( 'Sa' , 0.000000_wp , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! Meteorological | S54 (Table 2, B64) | | + ! | | | | | | | | | | | | | | | tide only | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Diurnal tidal constituents | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 8) = tide( 'K1' , 0.142486_wp , 1 , 0 , 1 , 0 , 0 , -90 , 0 , 0 , -1 , 0 , 0 , 227 ) ! CE73, sign | S54 (Table 2) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 9) = tide( 'O1' , 0.101316_wp , 1 , -2 , 1 , 0 , 0 , 90 , 2 , -1 , 0 , 0 , 0 , 75 ) ! CE73 | S54 (Table 2, A14) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(10) = tide( 'P1' , 0.047152_wp , 1 , 0 , -1 , 0 , 0 , 90 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B14) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(11) = tide( 'Q1' , 0.019396_wp , 1 , -3 , 1 , 1 , 0 , 90 , 2 , -1 , 0 , 0 , 0 , 75 ) ! CE73 | S54 (Table 2, A15) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(12) = tide( 'J1' , 0.007967_wp , 1 , 1 , 1 , -1 , 0 , -90 , 0 , -1 , 0 , 0 , 0 , 76 ) ! CE73, sign | S54 (Table 2, A24) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(13) = tide( 'S1' , 0.000000_wp , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! Meteorological | S54 (Table 2, B71) | | + ! | | | | | | | | | | | | | | | tide only | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Semidiurnal tidal constituents | + ! +--------+-------------+-----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(14) = tide( 'M2' , 0.244081_wp , 2 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A39) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(15) = tide( 'S2' , 0.110242_wp , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B39) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(16) = tide( 'N2' , 0.046732_wp , 2 , -3 , 2 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A40) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(17) = tide( 'K2' , 0.030905_wp , 2 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , -2 , 0 , 235 ) ! CE73 | S54 (Table 2) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(18) = tide( 'nu2' , 0.008877_wp , 2 , -3 , 4 , -1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A43) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(19) = tide( 'mu2' , 0.007463_wp , 2 , -4 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A45) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(20) = tide( '2N2' , 0.006184_wp , 2 , -4 , 2 , 2 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A42) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(21) = tide( 'L2' , 0.006899_wp , 2 , -1 , 2 , -1 , 0 , 180 , 2 , -2 , 0 , 0 , -1 , 215 ) ! CE73, sign | S54 (Table 2) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(22) = tide( 'T2' , 0.006655_wp , 2 , 0 , -1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B40) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(23) = tide( 'eps2' , 0.001804_wp , 2 , -5 , 4 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(24) = tide( 'lam2' , 0.001800_wp , 2 , -1 , 0 , 1 , 0 , 180 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73, sign | S54 (Table 2, A44) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(25) = tide( 'R2' , 0.000952_wp , 2 , 0 , 1 , 0 , -1 , 180 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73, sign | S54 (Table 2, B41) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Terdiurnal tidal constituents | + ! +--------+-------------+-----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(26) = tide( 'M3' , 0.003192_wp , 3 , -3 , 3 , 0 , 0 , 0 , 3 , -3 , 0 , 0 , 0 , 149 ) ! CT71, sign | S54 (Table 2, A82) | Note 2 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Compound tides | + ! +--------+-------------+-----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(27) = tide( 'MKS2' , 0.000000_wp , 2 , -2 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , -2 , 0 , 4 ) ! Compound tide | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(28) = tide( 'MN4' , 0.000000_wp , 4 , -5 , 4 , 1 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) ! Compound tide | S54 (Table 2a) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(29) = tide( 'MS4' , 0.000000_wp , 4 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! Compound tide | FES2014 (prediction | Note 3 | + ! | | | | | | | | | | | | | | | | algorithm); S54 | | + ! | | | | | | | | | | | | | | | | (Table 2a) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Overtides | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(30) = tide( 'M4' , 0.000000_wp , 4 , -4 , 4 , 0 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(31) = tide( 'N4' , 0.000000_wp , 4 , -6 , 4 , 2 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) ! Overtide | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(32) = tide( 'S4' , 0.000000_wp , 4 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(33) = tide( 'M6' , 0.000000_wp , 6 , -6 , 6 , 0 , 0 , 0 , 6 , -6 , 0 , 0 , 0 , 18 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(34) = tide( 'M8' , 0.000000_wp , 8 , -8 , 8 , 0 , 0 , 0 , 8 , -8 , 0 , 0 , 0 , 20 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! Note 1: the negative sign of the equilibrium-tide value derived from CE73 has been changed to accomodate the phase shift from Table 2 of S54. + ! Note 2: the negative sign of the equilibrium-tide value derived from CT71 has been changed to accomodate the phase shift from Table 2 of S54. + ! Note 3: the nodal correction factor formulas from FES2014 and S54 differ; here, the version from FES2014 has been selected. + END IF + ! Identify the selected components that are availble + icomp = 0 + DO jk = 1, jpmax_harmo + IF (TRIM(pcnames(jk)) /= '') THEN + DO jj = 1, jpmax_harmo + ! Find matches between selected and available constituents + ! (ignore capitalisation unless legacy variant has been selected) + IF (nn_tide_var < 1) THEN + llmatch = (TRIM(pcnames(jk)) == TRIM(tide_components(jj)%cname_tide)) + ELSE + llmatch = .TRUE. + ji = MAX(LEN_TRIM(pcnames(jk)), LEN_TRIM(tide_components(jj)%cname_tide)) + DO WHILE (llmatch.AND.(ji > 0)) + ic1 = IACHAR(pcnames(jk)(ji:ji)) + IF ((ic1 >= 97).AND.(ic1 <= 122)) ic1 = ic1 - 32 + ic2 = IACHAR(tide_components(jj)%cname_tide(ji:ji)) + IF ((ic2 >= 97).AND.(ic2 <= 122)) ic2 = ic2 - 32 + llmatch = (ic1 == ic2) + ji = ji - 1 + END DO + END IF + IF (llmatch) THEN + ! Count and record the match + icomp = icomp + 1 + icomppos(icomp) = jj + ! Set the capitalisation of the tidal constituent identifier + ! as specified in the namelist + tide_components(jj)%cname_tide = pcnames(jk) + IF (lwp) WRITE(numout, '(10X,"Tidal component #",I2.2,36X,"= ",A4)') icomp, tide_components(jj)%cname_tide + EXIT + END IF + END DO + IF ((lwp).AND.(jj > jpmax_harmo)) WRITE(numout, '(10X,"Tidal component ",A4," is not available!")') pcnames(jk) + END IF + END DO + + ! Allocate and populate reduced list of components + ALLOCATE(ptide_comp(icomp)) + DO jk = 1, icomp + ptide_comp(jk) = tide_components(icomppos(jk)) + END DO + + ! Release local array of available components and list of selected + ! components + DEALLOCATE(tide_components, icomppos) + + END SUBROUTINE tide_init_components + + + SUBROUTINE tide_init_harmonics(pcnames, ptide_harmo, ptide_comp) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_harmonics *** + !! + !! Returns pointer to array of variables of type 'tide_harmonics' that + !! contain oscillation parameters of the selected harmonic tidal + !! components + !! ---------------------------------------------------------------------- + CHARACTER(LEN=4), DIMENSION(jpmax_harmo), INTENT(in) :: pcnames ! Names of selected components + TYPE(tide_harmonic), POINTER, DIMENSION(:) :: ptide_harmo ! Oscillation parameters of tidal components + TYPE(tide), POINTER, DIMENSION(:), OPTIONAL :: ptide_comp ! Selected components + TYPE(tide), POINTER, DIMENSION(:) :: ztcomp ! Selected components + + ! Retrieve information about selected tidal components + ! If requested, prepare tidal component array for returning + IF (PRESENT(ptide_comp)) THEN + CALL tide_init_components(pcnames, ptide_comp) + ztcomp => ptide_comp + ELSE + CALL tide_init_components(pcnames, ztcomp) + END IF + + ! Allocate and populate array of oscillation parameters + ALLOCATE(ptide_harmo(size(ztcomp))) + ptide_harmo(:)%cname_tide = ztcomp(:)%cname_tide + ptide_harmo(:)%equitide = ztcomp(:)%equitide + CALL tide_harmo(ztcomp, ptide_harmo) + + END SUBROUTINE tide_init_harmonics + + + SUBROUTINE tide_init_potential + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_potential *** + !! + !! ** Reference : + !! CT71) Cartwright, D. E. and Tayler, R. J. (1971): New computations of + !! the Tide-generating Potential. Geophys. J. R. astr. Soc. 23, + !! pp. 45-74. DOI: 10.1111/j.1365-246X.1971.tb01803.x + !! + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcons, ztmp1, ztmp2, zlat, zlon, ztmp, zamp, zcs ! local scalar + !!---------------------------------------------------------------------- + + IF( ln_read_load ) THEN + amp_pot(:,:,:) = amp_load(:,:,:) + phi_pot(:,:,:) = phi_load(:,:,:) + ELSE + amp_pot(:,:,:) = 0._wp + phi_pot(:,:,:) = 0._wp + ENDIF + DO jk = 1, nb_harmo + zcons = rn_tide_gamma * tide_components(jk)%equitide * tide_harmonics(jk)%f + DO ji = 1, jpi + DO jj = 1, jpj + ztmp1 = tide_harmonics(jk)%f * amp_pot(ji,jj,jk) * COS( phi_pot(ji,jj,jk) & + & + tide_harmonics(jk)%v0 + tide_harmonics(jk)%u ) + ztmp2 = -tide_harmonics(jk)%f * amp_pot(ji,jj,jk) * SIN( phi_pot(ji,jj,jk) & + & + tide_harmonics(jk)%v0 + tide_harmonics(jk)%u ) + zlat = gphit(ji,jj)*rad !! latitude en radian + zlon = glamt(ji,jj)*rad !! longitude en radian + ztmp = tide_harmonics(jk)%v0 + tide_harmonics(jk)%u + tide_components(jk)%nt * zlon + ! le potentiel est composé des effets des astres: + SELECT CASE( tide_components(jk)%nt ) + CASE( 0 ) ! long-periodic tidal constituents (included unless + zcs = zcons * ( 0.5_wp - 1.5_wp * SIN( zlat )**2 ) ! compatibility with original formulation is requested) + IF ( nn_tide_var < 1 ) zcs = 0.0_wp + CASE( 1 ) ! diurnal tidal constituents + zcs = zcons * SIN( 2.0_wp*zlat ) + CASE( 2 ) ! semi-diurnal tidal constituents + zcs = zcons * COS( zlat )**2 + CASE( 3 ) ! Terdiurnal tidal constituents; the colatitude-dependent + zcs = zcons * COS( zlat )**3 ! factor is sin(theta)^3 (Table 2 of CT71) + CASE DEFAULT ! constituents of higher frequency are not included + zcs = 0.0_wp + END SELECT + ztmp1 = ztmp1 + zcs * COS( ztmp ) + ztmp2 = ztmp2 - zcs * SIN( ztmp ) + zamp = SQRT( ztmp1*ztmp1 + ztmp2*ztmp2 ) + amp_pot(ji,jj,jk) = zamp + phi_pot(ji,jj,jk) = ATAN2( -ztmp2 / MAX( 1.e-10_wp , zamp ) , & + & ztmp1 / MAX( 1.e-10_wp, zamp ) ) + END DO + END DO + END DO + ! + END SUBROUTINE tide_init_potential + + + SUBROUTINE tide_init_load + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_load *** + !!---------------------------------------------------------------------- + INTEGER :: inum ! Logical unit of input file + INTEGER :: ji, jj, itide ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: ztr, zti !: workspace to read in tidal harmonics data + !!---------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'tide_init_load : Initialization of load potential from file' + WRITE(numout,*) '~~~~~~~~~~~~~~ ' + ENDIF + ! + CALL iom_open ( cn_tide_load , inum ) + ! + DO itide = 1, nb_harmo + CALL iom_get ( inum, jpdom_global,TRIM(tide_components(itide)%cname_tide)//'_z1', ztr(:,:) ) + CALL iom_get ( inum, jpdom_global,TRIM(tide_components(itide)%cname_tide)//'_z2', zti(:,:) ) + ! + DO ji=1,jpi + DO jj=1,jpj + amp_load(ji,jj,itide) = SQRT( ztr(ji,jj)**2. + zti(ji,jj)**2. ) + phi_load(ji,jj,itide) = ATAN2(-zti(ji,jj), ztr(ji,jj) ) + END DO + END DO + ! + END DO + CALL iom_close( inum ) + ! + END SUBROUTINE tide_init_load + + + SUBROUTINE tide_update( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_update *** + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step + INTEGER :: jk ! dummy loop index + !!---------------------------------------------------------------------- + + IF( nsec_day == NINT(0.5_wp * rn_Dt) .OR. kt == nit000 ) THEN ! start a new day + ! + CALL tide_harmo(tide_components, tide_harmonics, ndt05) ! Update oscillation parameters of tidal components for start of current day + ! + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'tide_update : Update of the components and (re)Init. the potential at kt=', kt + WRITE(numout,*) '~~~~~~~~~~~ ' + DO jk = 1, nb_harmo + WRITE(numout,*) tide_harmonics(jk)%cname_tide, tide_harmonics(jk)%u, & + & tide_harmonics(jk)%f,tide_harmonics(jk)%v0, tide_harmonics(jk)%omega + END DO + ENDIF + ! + IF( ln_tide_pot ) CALL tide_init_potential + ! + rn_tide_ramp_t = (kt - nit000)*rn_Dt ! Elapsed time in seconds + ENDIF + ! + END SUBROUTINE tide_update + + + SUBROUTINE tide_harmo( ptide_comp, ptide_harmo, psec_day ) + ! + TYPE(tide), DIMENSION(:), POINTER :: ptide_comp ! Array of selected tidal component parameters + TYPE(tide_harmonic), DIMENSION(:), POINTER :: ptide_harmo ! Oscillation parameters of selected tidal components + INTEGER, OPTIONAL :: psec_day ! Number of seconds since the start of the current day + ! + IF (PRESENT(psec_day)) THEN + CALL astronomic_angle(psec_day) + ELSE + CALL astronomic_angle(nsec_day) + END IF + CALL tide_pulse( ptide_comp, ptide_harmo ) + CALL tide_vuf( ptide_comp, ptide_harmo ) + ! + END SUBROUTINE tide_harmo + + + SUBROUTINE astronomic_angle(psec_day) + !!---------------------------------------------------------------------- + !! *** ROUTINE astronomic_angle *** + !! + !! ** Purpose : Compute astronomic angles + !!---------------------------------------------------------------------- + INTEGER :: psec_day ! Number of seconds from midnight + REAL(wp) :: zp, zq, zt2, zs2, ztgI2, zP1, ztgn2, zat1, zat2 + REAL(wp) :: zqy , zsy, zday, zdj, zhfrac, zt + !!---------------------------------------------------------------------- + ! + ! Computation of the time from 1 Jan 1900, 00h in years + zqy = AINT( (nyear - 1901.0_wp) / 4.0_wp ) + zsy = nyear - 1900.0_wp + ! + zdj = dayjul( nyear, nmonth, nday ) + zday = zdj + zqy - 1.0_wp + ! + zhfrac = psec_day / 3600.0_wp + ! + zt = zsy * 365.0_wp * 24.0_wp + zday * 24.0_wp + zhfrac + ! + ! Longitude of ascending lunar node + sh_N = ( rlon00_N + romega_N * zt ) * rad + sh_N = MOD( sh_N, 2*rpi ) + ! Mean solar angle (Greenwhich time) + sh_T = ( rlon00_T + romega_T * zhfrac ) * rad + ! Mean solar Longitude + sh_h = ( rlon00_h + romega_h * zt ) * rad + sh_h = MOD( sh_h, 2*rpi ) + ! Mean lunar Longitude + sh_s = ( rlon00_s + romega_s * zt ) * rad + sh_s = MOD( sh_s, 2*rpi ) + ! Longitude of solar perigee + sh_p1 = ( rlon00_p1 + romega_p1 * zt ) * rad + sh_p1= MOD( sh_p1, 2*rpi ) + ! Longitude of lunar perigee + sh_p = ( rlon00_p + romega_p * zt ) * rad + sh_p = MOD( sh_p, 2*rpi ) + ! + ! Inclination of the orbit of the moon w.r.t. the celestial equator, see + ! explanation of Table 6 of S58 + sh_I = ACOS( rcice - rsise * COS( sh_N ) ) + ! + ! Computation of sh_xi and sh_nu, see explanation of Table 6 of S58 + ztgn2 = TAN( sh_N / 2.0_wp ) + zat1 = ATAN( rxinu1 * ztgn2 ) + zat2 = ATAN( rxinu2 * ztgn2 ) + sh_xi = sh_N - zat1 - zat2 + IF( sh_N > rpi ) sh_xi = sh_xi - 2.0_wp * rpi + sh_nu = zat1 - zat2 + ! + ! Computation of sh_x1ra, sh_R, sh_nuprim, and sh_nusec used for tidal + ! constituents L2, K1, and K2 + ! + ! Computation of sh_x1ra and sh_R (Equations 204, 213, and 214 of S58) + ztgI2 = tan( sh_I / 2.0_wp ) + zP1 = sh_p - sh_xi + zt2 = ztgI2 * ztgI2 + sh_x1ra = SQRT( 1.0 - 12.0 * zt2 * COS( 2.0_wp * zP1 ) + 36.0_wp * zt2 * zt2 ) + zp = SIN( 2.0_wp * zP1 ) + zq = 1.0_wp / ( 6.0_wp * zt2 ) - COS( 2.0_wp * zP1 ) + sh_R = ATAN( zp / zq ) + ! + ! Computation of sh_nuprim (Equation 224 of S58) + zp = SIN( 2.0_wp * sh_I ) * SIN( sh_nu ) + zq = SIN( 2.0_wp * sh_I ) * COS( sh_nu ) + 0.3347_wp + sh_nuprim = ATAN( zp / zq ) + ! + ! Computation of sh_nusec (Equation 232 of S58) + zs2 = SIN( sh_I ) * SIN( sh_I ) + zp = zs2 * SIN( 2.0_wp * sh_nu ) + zq = zs2 * COS( 2.0_wp * sh_nu ) + 0.0727_wp + sh_nusec = 0.5_wp * ATAN( zp / zq ) + ! + END SUBROUTINE astronomic_angle + + + SUBROUTINE tide_pulse( ptide_comp, ptide_harmo ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_pulse *** + !! + !! ** Purpose : Compute tidal frequencies + !!---------------------------------------------------------------------- + TYPE(tide), DIMENSION(:), POINTER :: ptide_comp ! Array of selected tidal component parameters + TYPE(tide_harmonic), DIMENSION(:), POINTER :: ptide_harmo ! Oscillation parameters of selected tidal components + ! + INTEGER :: jh + REAL(wp) :: zscale + !!---------------------------------------------------------------------- + ! + zscale = rad / 3600.0_wp + ! + DO jh = 1, size(ptide_harmo) + ptide_harmo(jh)%omega = ( romega_T * ptide_comp( jh )%nT & + & + romega_s * ptide_comp( jh )%ns & + & + romega_h * ptide_comp( jh )%nh & + & + romega_p * ptide_comp( jh )%np & + & + romega_p1* ptide_comp( jh )%np1 ) * zscale + END DO + ! + END SUBROUTINE tide_pulse + + + SUBROUTINE tide_vuf( ptide_comp, ptide_harmo ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_vuf *** + !! + !! ** Purpose : Compute nodal modulation corrections + !! + !! ** Outputs : vt: Phase of tidal potential relative to Greenwich (radians) + !! ut: Phase correction u due to nodal motion (radians) + !! ft: Nodal correction factor + !!---------------------------------------------------------------------- + TYPE(tide), DIMENSION(:), POINTER :: ptide_comp ! Array of selected tidal component parameters + TYPE(tide_harmonic), DIMENSION(:), POINTER :: ptide_harmo ! Oscillation parameters of selected tidal components + ! + INTEGER :: jh ! dummy loop index + !!---------------------------------------------------------------------- + ! + DO jh = 1, size(ptide_harmo) + ! Phase of the tidal potential relative to the Greenwhich + ! meridian (e.g. the position of the fictuous celestial body). Units are radian: + ptide_harmo(jh)%v0 = sh_T * ptide_comp( jh )%nT & + & + sh_s * ptide_comp( jh )%ns & + & + sh_h * ptide_comp( jh )%nh & + & + sh_p * ptide_comp( jh )%np & + & + sh_p1* ptide_comp( jh )%np1 & + & + ptide_comp( jh )%shift * rad + ! + ! Phase correction u due to nodal motion. Units are radian: + ptide_harmo(jh)%u = sh_xi * ptide_comp( jh )%nksi & + & + sh_nu * ptide_comp( jh )%nnu0 & + & + sh_nuprim * ptide_comp( jh )%nnu1 & + & + sh_nusec * ptide_comp( jh )%nnu2 & + & + sh_R * ptide_comp( jh )%R + + ! Nodal correction factor: + ptide_harmo(jh)%f = nodal_factort( ptide_comp( jh )%nformula ) + END DO + ! + END SUBROUTINE tide_vuf + + + RECURSIVE FUNCTION nodal_factort( kformula ) RESULT( zf ) + !!---------------------------------------------------------------------- + !! *** FUNCTION nodal_factort *** + !! + !! ** Purpose : Compute amplitude correction factors due to nodal motion + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kformula + ! + REAL(wp) :: zf + REAL(wp) :: zs, zf1, zf2 + CHARACTER(LEN=3) :: clformula + !!---------------------------------------------------------------------- + ! + SELECT CASE( kformula ) + ! + CASE( 0 ) ! Formula 0, solar waves + zf = 1.0 + ! + CASE( 1 ) ! Formula 1, compound waves (78 x 78) + zf=nodal_factort( 78 ) + zf = zf * zf + ! + CASE ( 4 ) ! Formula 4, compound waves (78 x 235) + zf1 = nodal_factort( 78 ) + zf = nodal_factort(235) + zf = zf1 * zf + ! + CASE( 18 ) ! Formula 18, compound waves (78 x 78 x 78 ) + zf1 = nodal_factort( 78 ) + zf = zf1 * zf1 * zf1 + ! + CASE( 20 ) ! Formula 20, compound waves ( 78 x 78 x 78 x 78 ) + zf1 = nodal_factort( 78 ) + zf = zf1 * zf1 * zf1 * zf1 + ! + CASE( 73 ) ! Formula 73 of S58 + zs = SIN( sh_I ) + zf = ( 2.0_wp / 3.0_wp - zs * zs ) / 0.5021_wp + ! + CASE( 74 ) ! Formula 74 of S58 + zs = SIN(sh_I) + zf = zs * zs / 0.1578_wp + ! + CASE( 75 ) ! Formula 75 of S58 + zs = COS( sh_I / 2.0_wp ) + zf = SIN( sh_I ) * zs * zs / 0.3800_wp + ! + CASE( 76 ) ! Formula 76 of S58 + zf = SIN( 2.0_wp * sh_I ) / 0.7214_wp + ! + CASE( 78 ) ! Formula 78 of S58 + zs = COS( sh_I/2 ) + zf = zs * zs * zs * zs / 0.9154_wp + ! + CASE( 149 ) ! Formula 149 of S58 + zs = COS( sh_I/2 ) + zf = zs * zs * zs * zs * zs * zs / 0.8758_wp + ! + CASE( 215 ) ! Formula 215 of S58 with typo correction (0.9154 instead of 0.9145) + zs = COS( sh_I/2 ) + zf = zs * zs * zs * zs / 0.9154_wp * sh_x1ra + ! + CASE( 227 ) ! Formula 227 of S58 + zs = SIN( 2.0_wp * sh_I ) + zf = SQRT( 0.8965_wp * zs * zs + 0.6001_wp * zs * COS( sh_nu ) + 0.1006_wp ) + ! + CASE ( 235 ) ! Formula 235 of S58 + zs = SIN( sh_I ) + zf = SQRT( 19.0444_wp * zs * zs * zs * zs + 2.7702_wp * zs * zs * cos( 2.0_wp * sh_nu ) + 0.0981_wp ) + ! + CASE DEFAULT + WRITE( clformula, '(I3)' ) kformula + CALL ctl_stop('nodal_factort: formula ' // clformula // ' is not available') + END SELECT + ! + END FUNCTION nodal_factort + + + FUNCTION dayjul( kyr, kmonth, kday ) + !!---------------------------------------------------------------------- + !! *** FUNCTION dayjul *** + !! + !! Purpose : compute the Julian day + !!---------------------------------------------------------------------- + INTEGER,INTENT(in) :: kyr, kmonth, kday + ! + INTEGER,DIMENSION(12) :: idayt = (/ 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 /) + INTEGER,DIMENSION(12) :: idays + INTEGER :: inc, ji, zyq + REAL(wp) :: dayjul + !!---------------------------------------------------------------------- + ! + idays(1) = 0 + idays(2) = 31 + inc = 0.0_wp + zyq = MOD( kyr - 1900 , 4 ) + IF( zyq == 0 ) inc = 1 + DO ji = 3, 12 + idays(ji) = idayt(ji) + inc + END DO + dayjul = REAL( idays(kmonth) + kday, KIND=wp ) + ! + END FUNCTION dayjul + + + SUBROUTINE upd_tide(pdelta, Kmm) + !!---------------------------------------------------------------------- + !! *** ROUTINE upd_tide *** + !! + !! ** Purpose : provide at each time step the astronomical potential + !! + !! ** Method : computed from pulsation and amplitude of all tide components + !! + !! ** Action : pot_astro actronomical potential + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pdelta ! Temporal offset in seconds + INTEGER, INTENT(IN) :: Kmm ! Time level index + INTEGER :: jk ! Dummy loop index + REAL(wp) :: zt, zramp ! Local scalars + REAL(wp), DIMENSION(nb_harmo) :: zwt ! Temporary array + !!---------------------------------------------------------------------- + ! + zwt(:) = tide_harmonics(:)%omega * pdelta + ! + IF( ln_tide_ramp ) THEN ! linear increase if asked + zt = rn_tide_ramp_t + pdelta + zramp = MIN( MAX( zt / (rn_tide_ramp_dt*rday) , 0._wp ) , 1._wp ) + ENDIF + ! + pot_astro(:,:) = 0._wp ! update tidal potential (sum of all harmonics) + DO jk = 1, nb_harmo + IF ( .NOT. ln_tide_dia ) THEN + pot_astro(:,:) = pot_astro(:,:) + amp_pot(:,:,jk) * COS( zwt(jk) + phi_pot(:,:,jk) ) + ELSE + pot_astro_comp(:,:) = amp_pot(:,:,jk) * COS( zwt(jk) + phi_pot(:,:,jk) ) + pot_astro(:,:) = pot_astro(:,:) + pot_astro_comp(:,:) + IF ( iom_use( "tide_pot_" // TRIM( tide_harmonics(jk)%cname_tide ) ) ) THEN ! Output tidal potential (incl. load potential) + IF ( ln_tide_ramp ) pot_astro_comp(:,:) = zramp * pot_astro_comp(:,:) + CALL iom_put( "tide_pot_" // TRIM( tide_harmonics(jk)%cname_tide ), pot_astro_comp(:,:) ) + END IF + END IF + END DO + ! + IF ( ln_tide_ramp ) pot_astro(:,:) = zramp * pot_astro(:,:) + ! + IF( ln_tide_dia ) THEN ! Output total tidal potential (incl. load potential) + IF ( iom_use( "tide_pot" ) ) CALL iom_put( "tide_pot", pot_astro(:,:) + rn_scal_load * ssh(:,:,Kmm) ) + END IF + ! + END SUBROUTINE upd_tide + + !!====================================================================== +END MODULE tide_mod diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/timing.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/timing.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2bfe3169c9fa407c1c1f46b1130cf3ab8e249c67 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/timing.f90 @@ -0,0 +1,837 @@ + + + + + + + + + + + + + +MODULE timing + !!======================================================================== + !! *** MODULE timing *** + !!======================================================================== + !! History : 4.0 ! 2001-05 (R. Benshila) + !!------------------------------------------------------------------------ + + !!------------------------------------------------------------------------ + !! timming_init : initialize timing process + !! timing_start : start Timer + !! timing_stop : stop Timer + !! timing_reset : end timing variable creation + !! timing_finalize : compute stats and write output in calling w*_info + !! timing_ini_var : create timing variables + !! timing_listing : print instumented subroutines in ocean.output + !! wcurrent_info : compute and print detailed stats on the current CPU + !! wave_info : compute and print averaged statson all processors + !! wmpi_info : compute and write global stats + !! supress : suppress an element of the timing linked list + !! insert : insert an element of the timing linked list + !!------------------------------------------------------------------------ + USE in_out_manager ! I/O manager + USE dom_oce ! ocean domain + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC timing_init, timing_finalize ! called in nemogcm module + PUBLIC timing_reset ! called in step module + PUBLIC timing_start, timing_stop ! called in each routine to time + + INCLUDE 'mpif.h' + + ! Variables for fine grain timing + TYPE timer + CHARACTER(LEN=20) :: cname + CHARACTER(LEN=20) :: surname + INTEGER :: rank + REAL(wp) :: t_cpu, t_clock, tsum_cpu, tsum_clock, tmax_cpu, tmax_clock, tmin_cpu, tmin_clock, tsub_cpu, tsub_clock + INTEGER :: ncount, ncount_max, ncount_rate + INTEGER :: niter + LOGICAL :: l_tdone + TYPE(timer), POINTER :: next => NULL() + TYPE(timer), POINTER :: prev => NULL() + TYPE(timer), POINTER :: parent_section => NULL() + END TYPE timer + + TYPE alltimer + CHARACTER(LEN=20), DIMENSION(:), POINTER :: cname => NULL() + REAL(wp), DIMENSION(:), POINTER :: tsum_cpu => NULL() + REAL(wp), DIMENSION(:), POINTER :: tsum_clock => NULL() + INTEGER, DIMENSION(:), POINTER :: niter => NULL() + TYPE(alltimer), POINTER :: next => NULL() + TYPE(alltimer), POINTER :: prev => NULL() + END TYPE alltimer + + TYPE(timer), POINTER :: s_timer_root => NULL() + TYPE(timer), POINTER :: s_timer => NULL() + TYPE(timer), POINTER :: s_timer_old => NULL() + + TYPE(timer), POINTER :: s_wrk => NULL() + REAL(wp) :: t_overclock, t_overcpu + LOGICAL :: l_initdone = .FALSE. + INTEGER :: nsize + + ! Variables for coarse grain timing + REAL(wp) :: tot_etime, tot_ctime + REAL(kind=wp), DIMENSION(2) :: t_elaps, t_cpu + REAL(wp), ALLOCATABLE, DIMENSION(:) :: all_etime, all_ctime + INTEGER :: nfinal_count, ncount, ncount_rate, ncount_max + INTEGER, DIMENSION(8) :: nvalues + CHARACTER(LEN=8), DIMENSION(2) :: cdate + CHARACTER(LEN=10), DIMENSION(2) :: ctime + CHARACTER(LEN=5) :: czone + + ! From of ouput file (1/proc or one global) !RB to put in nammpp or namctl + LOGICAL :: ln_onefile = .TRUE. + LOGICAL :: lwriter + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: timing.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE timing_start(cdinfo) + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_start *** + !! ** Purpose : collect execution time + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdinfo + ! + IF(ASSOCIATED(s_timer) ) s_timer_old => s_timer + ! + ! Create timing structure at first call of the routine + CALL timing_ini_var(cdinfo) + ! write(*,*) 'after inivar ', s_timer%cname + + ! ici timing_ini_var a soit retrouve s_timer et fait return soit ajoute un maillon + ! maintenant on regarde si le call d'avant corrsspond a un parent ou si il est ferme + IF( .NOT. s_timer_old%l_tdone ) THEN + s_timer%parent_section => s_timer_old + ELSE + s_timer%parent_section => NULL() + ENDIF + + s_timer%l_tdone = .FALSE. + IF( .NOT. l_istiled .OR. ntile == 1 ) s_timer%niter = s_timer%niter + 1 ! All tiles count as one iteration + s_timer%t_cpu = 0. + s_timer%t_clock = 0. + + ! CPU time collection + CALL CPU_TIME( s_timer%t_cpu ) + ! clock time collection + s_timer%t_clock= MPI_Wtime() +! write(*,*) 'end of start ', s_timer%cname + + ! + END SUBROUTINE timing_start + + + SUBROUTINE timing_stop(cdinfo, csection) + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_stop *** + !! ** Purpose : finalize timing and output + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdinfo + CHARACTER(len=*), INTENT(in), OPTIONAL :: csection + ! + INTEGER :: ifinal_count, iperiods + REAL(wp) :: zcpu_end, zmpitime,zcpu_raw,zclock_raw + ! + s_wrk => NULL() + + ! clock time collection + zmpitime = MPI_Wtime() + ! CPU time collection + CALL CPU_TIME( zcpu_end ) + +!!$ IF(associated(s_timer%parent_section))then +!!$ write(*,*) s_timer%cname,' <-- ', s_timer%parent_section%cname +!!$ ENDIF + + ! No need to search ... : s_timer has the last value defined in start + ! s_timer => s_timer_root + ! DO WHILE( TRIM(s_timer%cname) /= TRIM(cdinfo) ) + ! IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next + ! END DO + + ! CPU time correction + zcpu_raw = zcpu_end - s_timer%t_cpu - t_overcpu ! total time including child + s_timer%t_cpu = zcpu_raw - s_timer%tsub_cpu + ! IF(s_timer%cname==trim('lbc_lnk_2d')) write(*,*) s_timer%tsub_cpu,zcpu_end + + ! clock time correction + zclock_raw = zmpitime - s_timer%t_clock - t_overclock ! total time including child + s_timer%t_clock = zclock_raw - t_overclock - s_timer%tsub_clock + ! IF(s_timer%cname==trim('lbc_lnk_2d')) write(*,*) zclock_raw , s_timer%tsub_clock + + ! Correction of parent section + IF( .NOT. PRESENT(csection) ) THEN + IF ( ASSOCIATED(s_timer%parent_section ) ) THEN + s_timer%parent_section%tsub_cpu = zcpu_raw + s_timer%parent_section%tsub_cpu + s_timer%parent_section%tsub_clock = zclock_raw + s_timer%parent_section%tsub_clock + ENDIF + ENDIF + + ! time diagnostics + s_timer%tsum_clock = s_timer%tsum_clock + s_timer%t_clock + s_timer%tsum_cpu = s_timer%tsum_cpu + s_timer%t_cpu +!RB to use to get min/max during a time integration +! IF( .NOT. l_initdone ) THEN +! s_timer%tmin_clock = s_timer%t_clock +! s_timer%tmin_cpu = s_timer%t_cpu +! ELSE +! s_timer%tmin_clock = MIN( s_timer%tmin_clock, s_timer%t_clock ) +! s_timer%tmin_cpu = MIN( s_timer%tmin_cpu , s_timer%t_cpu ) +! ENDIF +! s_timer%tmax_clock = MAX( s_timer%tmax_clock, s_timer%t_clock ) +! s_timer%tmax_cpu = MAX( s_timer%tmax_cpu , s_timer%t_cpu ) + ! + s_timer%tsub_clock = 0. + s_timer%tsub_cpu = 0. + s_timer%l_tdone = .TRUE. + ! + ! + ! we come back + IF ( ASSOCIATED(s_timer%parent_section ) ) s_timer => s_timer%parent_section + +! write(*,*) 'end of stop ', s_timer%cname + + END SUBROUTINE timing_stop + + + SUBROUTINE timing_init( clname ) + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_init *** + !! ** Purpose : open timing output file + !!---------------------------------------------------------------------- + INTEGER :: iperiods, istart_count, ifinal_count + REAL(wp) :: zdum + LOGICAL :: ll_f + CHARACTER(len=*), INTENT(in), OPTIONAL :: clname + CHARACTER(len=20) :: cln + + IF( PRESENT(clname) ) THEN ; cln = clname + ELSE ; cln = 'timing.output' + ENDIF + + IF( ln_onefile ) THEN + IF( lwp) CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea ) + lwriter = lwp + ELSE + CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.FALSE., narea ) + lwriter = .TRUE. + ENDIF + + IF( lwriter) THEN + WRITE(numtime,*) + WRITE(numtime,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC - INGV' + WRITE(numtime,*) ' NEMO team' + WRITE(numtime,*) ' Ocean General Circulation Model' + WRITE(numtime,*) ' version 4.0 (2019) ' + WRITE(numtime,*) + WRITE(numtime,*) ' Timing Informations ' + WRITE(numtime,*) + WRITE(numtime,*) + ENDIF + + ! Compute clock function overhead + t_overclock = MPI_WTIME() + t_overclock = MPI_WTIME() - t_overclock + + ! Compute cpu_time function overhead + CALL CPU_TIME(zdum) + CALL CPU_TIME(t_overcpu) + + ! End overhead omputation + t_overcpu = t_overcpu - zdum + t_overclock = t_overcpu + t_overclock + + ! Timing on date and time + CALL DATE_AND_TIME(cdate(1),ctime(1),czone,nvalues) + + CALL CPU_TIME(t_cpu(1)) + ! Start elapsed and CPU time counters + t_elaps(1) = MPI_WTIME() + ! + END SUBROUTINE timing_init + + + SUBROUTINE timing_finalize + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_finalize *** + !! ** Purpose : compute average time + !! write timing output file + !!---------------------------------------------------------------------- + TYPE(timer), POINTER :: s_temp + INTEGER :: idum, iperiods, icode + INTEGER :: ji + LOGICAL :: ll_ord, ll_averep + CHARACTER(len=120) :: clfmt + REAL(wp), DIMENSION(:), ALLOCATABLE :: timing_glob + REAL(wp) :: zsypd ! simulated years per day (Balaji 2017) + REAL(wp) :: zperc, ztot + + ll_averep = .TRUE. + + ! total CPU and elapse + CALL CPU_TIME(t_cpu(2)) + t_cpu(2) = t_cpu(2) - t_cpu(1) - t_overcpu + t_elaps(2) = MPI_WTIME() - t_elaps(1) - t_overclock + + ! End of timings on date & time + CALL DATE_AND_TIME(cdate(2),ctime(2),czone,nvalues) + + ! Compute the numer of routines + nsize = 0 + s_timer => s_timer_root + DO WHILE( ASSOCIATED(s_timer) ) + nsize = nsize + 1 + s_timer => s_timer%next + END DO + idum = nsize + CALL mpp_sum('timing', idum) + IF( idum/jpnij /= nsize ) THEN + IF( lwriter ) WRITE(numtime,*) ' ===> W A R N I N G: ' + IF( lwriter ) WRITE(numtime,*) ' Some CPU have different number of routines instrumented for timing' + IF( lwriter ) WRITE(numtime,*) ' No detailed report on averaged timing can be provided' + IF( lwriter ) WRITE(numtime,*) ' The following detailed report only deals with the current processor' + IF( lwriter ) WRITE(numtime,*) + ll_averep = .FALSE. + ENDIF + + ! in MPI gather some info + ALLOCATE( all_etime(jpnij), all_ctime(jpnij) ) + CALL MPI_ALLGATHER(t_elaps(2), 1, MPI_DOUBLE_PRECISION, & + all_etime , 1, MPI_DOUBLE_PRECISION, & + MPI_COMM_OCE, icode) + CALL MPI_ALLGATHER(t_cpu(2) , 1, MPI_DOUBLE_PRECISION, & + all_ctime, 1, MPI_DOUBLE_PRECISION, & + MPI_COMM_OCE, icode) + tot_etime = SUM(all_etime(:)) + tot_ctime = SUM(all_ctime(:)) + + ! write output file + IF( lwriter ) WRITE(numtime,*) + IF( lwriter ) WRITE(numtime,*) + IF( lwriter ) WRITE(numtime,*) 'Total timing (sum) :' + IF( lwriter ) WRITE(numtime,*) '--------------------' + IF( lwriter ) WRITE(numtime,"('Elapsed Time (s) CPU Time (s)')") + IF( lwriter ) WRITE(numtime,'(5x,f12.3,1x,f12.3)') tot_etime, tot_ctime + IF( lwriter ) WRITE(numtime,*) + IF( ll_averep ) CALL waver_info + CALL wmpi_info + IF( lwriter ) CALL wcurrent_info + + clfmt='(1X,"Timing started on ",2(A2,"/"),A4," at ",2(A2,":"),A2," MET ",A3,":",A2," from GMT")' + IF( lwriter ) WRITE(numtime, TRIM(clfmt)) & + & cdate(1)(7:8), cdate(1)(5:6), cdate(1)(1:4), & + & ctime(1)(1:2), ctime(1)(3:4), ctime(1)(5:6), & + & czone(1:3), czone(4:5) + clfmt='(1X, "Timing ended on ",2(A2,"/"),A4," at ",2(A2,":"),A2," MET ",A3,":",A2," from GMT")' + IF( lwriter ) WRITE(numtime, TRIM(clfmt)) & + & cdate(2)(7:8), cdate(2)(5:6), cdate(2)(1:4), & + & ctime(2)(1:2), ctime(2)(3:4), ctime(2)(5:6), & + & czone(1:3), czone(4:5) + + ALLOCATE(timing_glob(4*jpnij), stat=icode) + CALL MPI_GATHER( (/compute_time, waiting_time(1), waiting_time(2), elapsed_time/), & + & 4, MPI_DOUBLE_PRECISION, timing_glob, 4, MPI_DOUBLE_PRECISION, 0, MPI_COMM_OCE, icode) + IF( narea == 1 ) THEN + WRITE(numtime,*) ' ' + WRITE(numtime,*) ' Report on time spent on waiting MPI messages ' + WRITE(numtime,*) ' total timing measured between nit000+1 and nitend-1 ' + WRITE(numtime,*) ' warning: includes restarts writing time if output before nitend... ' + WRITE(numtime,*) ' ' + DO ji = 1, jpnij + zperc = 0._wp ; zsypd = 0._wp + ztot = SUM( timing_glob(4*ji-3:4*ji-1) ) + WRITE(numtime,'(A28,F11.6, A34,I8)') 'Computing time : ',timing_glob(4*ji-3), ' on MPI rank : ', ji + IF ( ztot /= 0._wp ) zperc = timing_glob(4*ji-2) / ztot * 100. + WRITE(numtime,'(A28,F11.6,A2, F4.1,A3,A25,I8)') 'Waiting lbc_lnk time : ',timing_glob(4*ji-2) & + & , ' (', zperc,' %)', ' on MPI rank : ', ji + IF ( ztot /= 0._wp ) zperc = timing_glob(4*ji-1) / ztot * 100. + WRITE(numtime,'(A28,F11.6,A2, F4.1,A3,A25,I8)') 'Waiting global time : ',timing_glob(4*ji-1) & + & , ' (', zperc,' %)', ' on MPI rank : ', ji + IF ( timing_glob(4*ji) /= 0._wp ) zsypd = rn_Dt * REAL(nitend-nit000-1, wp) / (timing_glob(4*ji) * 365.) + WRITE(numtime,'(A28,F11.6,A7,F10.3,A2,A15,I8)') 'Total time : ',timing_glob(4*ji ) & + & , ' (SYPD: ', zsypd, ')', ' on MPI rank : ', ji + END DO + ENDIF + DEALLOCATE(timing_glob) + + IF( lwriter ) CLOSE(numtime) + ! + END SUBROUTINE timing_finalize + + + SUBROUTINE wcurrent_info + !!---------------------------------------------------------------------- + !! *** ROUTINE wcurrent_info *** + !! ** Purpose : compute and write timing output file + !!---------------------------------------------------------------------- + LOGICAL :: ll_ord + CHARACTER(len=2048) :: clfmt + + ! reorder the current list by elapse time + s_wrk => NULL() + s_timer => s_timer_root + DO + ll_ord = .TRUE. + s_timer => s_timer_root + DO WHILE ( ASSOCIATED( s_timer%next ) ) + IF (.NOT. ASSOCIATED(s_timer%next)) EXIT + IF ( s_timer%tsum_clock < s_timer%next%tsum_clock ) THEN + ALLOCATE(s_wrk) + s_wrk = s_timer%next + CALL insert (s_timer, s_timer_root, s_wrk) + CALL suppress(s_timer%next) + ll_ord = .FALSE. + CYCLE + ENDIF + IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next + END DO + IF( ll_ord ) EXIT + END DO + + ! write current info + WRITE(numtime,*) 'Detailed timing for proc :', narea-1 + WRITE(numtime,*) '--------------------------' + WRITE(numtime,*) 'Section ', & + & 'Elapsed Time (s) ','Elapsed Time (%) ', & + & 'CPU Time(s) ','CPU Time (%) ','CPU/Elapsed ','Frequency' + s_timer => s_timer_root + clfmt = '(1x,a,4x,f12.3,6x,f12.3,x,f12.3,2x,f12.3,6x,f7.3,2x,i9)' + DO WHILE ( ASSOCIATED(s_timer) ) + IF( s_timer%tsum_clock > 0._wp ) & + WRITE(numtime,TRIM(clfmt)) s_timer%cname, & + & s_timer%tsum_clock,s_timer%tsum_clock*100./t_elaps(2), & + & s_timer%tsum_cpu ,s_timer%tsum_cpu*100./t_cpu(2) , & + & s_timer%tsum_cpu/s_timer%tsum_clock, s_timer%niter + s_timer => s_timer%next + END DO + WRITE(numtime,*) + ! + END SUBROUTINE wcurrent_info + + SUBROUTINE waver_info + !!---------------------------------------------------------------------- + !! *** ROUTINE wcurrent_info *** + !! ** Purpose : compute and write averaged timing informations + !!---------------------------------------------------------------------- + TYPE(alltimer), POINTER :: sl_timer_glob_root => NULL() + TYPE(alltimer), POINTER :: sl_timer_glob => NULL() + TYPE(timer), POINTER :: sl_timer_ave_root => NULL() + TYPE(timer), POINTER :: sl_timer_ave => NULL() + INTEGER :: icode + INTEGER :: ierr + LOGICAL :: ll_ord + CHARACTER(len=200) :: clfmt + + ! Initialised the global strucutre + ALLOCATE(sl_timer_glob_root, Stat=ierr) + IF(ierr /= 0)THEN + WRITE(numtime,*) 'Failed to allocate global timing structure in waver_info' + RETURN + END IF + + ALLOCATE(sl_timer_glob_root%cname (jpnij), & + sl_timer_glob_root%tsum_cpu (jpnij), & + sl_timer_glob_root%tsum_clock(jpnij), & + sl_timer_glob_root%niter (jpnij), Stat=ierr) + IF(ierr /= 0)THEN + WRITE(numtime,*) 'Failed to allocate global timing structure in waver_info' + RETURN + END IF + sl_timer_glob_root%cname(:) = '' + sl_timer_glob_root%tsum_cpu(:) = 0._wp + sl_timer_glob_root%tsum_clock(:) = 0._wp + sl_timer_glob_root%niter(:) = 0 + sl_timer_glob_root%next => NULL() + sl_timer_glob_root%prev => NULL() + !ARPDBG - don't need to allocate a pointer that's immediately then + ! set to point to some other object. + !ALLOCATE(sl_timer_glob) + !ALLOCATE(sl_timer_glob%cname (jpnij)) + !ALLOCATE(sl_timer_glob%tsum_cpu (jpnij)) + !ALLOCATE(sl_timer_glob%tsum_clock(jpnij)) + !ALLOCATE(sl_timer_glob%niter (jpnij)) + sl_timer_glob => sl_timer_glob_root + ! + IF( narea .EQ. 1 ) THEN + ALLOCATE(sl_timer_ave_root) + sl_timer_ave_root%cname = '' + sl_timer_ave_root%t_cpu = 0._wp + sl_timer_ave_root%t_clock = 0._wp + sl_timer_ave_root%tsum_cpu = 0._wp + sl_timer_ave_root%tsum_clock = 0._wp + sl_timer_ave_root%tmax_cpu = 0._wp + sl_timer_ave_root%tmax_clock = 0._wp + sl_timer_ave_root%tmin_cpu = 0._wp + sl_timer_ave_root%tmin_clock = 0._wp + sl_timer_ave_root%tsub_cpu = 0._wp + sl_timer_ave_root%tsub_clock = 0._wp + sl_timer_ave_root%ncount = 0 + sl_timer_ave_root%ncount_rate = 0 + sl_timer_ave_root%ncount_max = 0 + sl_timer_ave_root%niter = 0 + sl_timer_ave_root%l_tdone = .FALSE. + sl_timer_ave_root%next => NULL() + sl_timer_ave_root%prev => NULL() + ALLOCATE(sl_timer_ave) + sl_timer_ave => sl_timer_ave_root + ENDIF + + ! Gather info from all processors + s_timer => s_timer_root + DO WHILE ( ASSOCIATED(s_timer) ) + CALL MPI_GATHER(s_timer%cname , 20, MPI_CHARACTER, & + sl_timer_glob%cname, 20, MPI_CHARACTER, & + 0, MPI_COMM_OCE, icode) + CALL MPI_GATHER(s_timer%tsum_clock , 1, MPI_DOUBLE_PRECISION, & + sl_timer_glob%tsum_clock, 1, MPI_DOUBLE_PRECISION, & + 0, MPI_COMM_OCE, icode) + CALL MPI_GATHER(s_timer%tsum_cpu , 1, MPI_DOUBLE_PRECISION, & + sl_timer_glob%tsum_cpu, 1, MPI_DOUBLE_PRECISION, & + 0, MPI_COMM_OCE, icode) + CALL MPI_GATHER(s_timer%niter , 1, MPI_INTEGER, & + sl_timer_glob%niter, 1, MPI_INTEGER, & + 0, MPI_COMM_OCE, icode) + + IF( narea == 1 .AND. ASSOCIATED(s_timer%next) ) THEN + ALLOCATE(sl_timer_glob%next) + ALLOCATE(sl_timer_glob%next%cname (jpnij)) + ALLOCATE(sl_timer_glob%next%tsum_cpu (jpnij)) + ALLOCATE(sl_timer_glob%next%tsum_clock(jpnij)) + ALLOCATE(sl_timer_glob%next%niter (jpnij)) + sl_timer_glob%next%prev => sl_timer_glob + sl_timer_glob%next%next => NULL() + sl_timer_glob => sl_timer_glob%next + ENDIF + s_timer => s_timer%next + END DO + + IF( narea == 1 ) THEN + ! Compute some stats + sl_timer_glob => sl_timer_glob_root + DO WHILE( ASSOCIATED(sl_timer_glob) ) + sl_timer_ave%cname = sl_timer_glob%cname(1) + sl_timer_ave%tsum_cpu = SUM (sl_timer_glob%tsum_cpu (:)) / jpnij + sl_timer_ave%tsum_clock = SUM (sl_timer_glob%tsum_clock(:)) / jpnij + sl_timer_ave%tmax_cpu = MAXVAL(sl_timer_glob%tsum_cpu (:)) + sl_timer_ave%tmax_clock = MAXVAL(sl_timer_glob%tsum_clock(:)) + sl_timer_ave%tmin_cpu = MINVAL(sl_timer_glob%tsum_cpu (:)) + sl_timer_ave%tmin_clock = MINVAL(sl_timer_glob%tsum_clock(:)) + sl_timer_ave%niter = SUM (sl_timer_glob%niter (:)) + ! + IF( ASSOCIATED(sl_timer_glob%next) ) THEN + ALLOCATE(sl_timer_ave%next) + sl_timer_ave%next%prev => sl_timer_ave + sl_timer_ave%next%next => NULL() + sl_timer_ave => sl_timer_ave%next + ENDIF + sl_timer_glob => sl_timer_glob%next + END DO + + ! reorder the averaged list by CPU time + s_wrk => NULL() + sl_timer_ave => sl_timer_ave_root + DO + ll_ord = .TRUE. + sl_timer_ave => sl_timer_ave_root + DO WHILE( ASSOCIATED( sl_timer_ave%next ) ) + + IF( .NOT. ASSOCIATED(sl_timer_ave%next) ) EXIT + + IF ( sl_timer_ave%tsum_clock < sl_timer_ave%next%tsum_clock ) THEN + ALLOCATE(s_wrk) + ! Copy data into the new object pointed to by s_wrk + s_wrk = sl_timer_ave%next + ! Insert this new timer object before our current position + CALL insert (sl_timer_ave, sl_timer_ave_root, s_wrk) + ! Remove the old object from the list + CALL suppress(sl_timer_ave%next) + ll_ord = .FALSE. + CYCLE + ENDIF + IF( ASSOCIATED(sl_timer_ave%next) ) sl_timer_ave => sl_timer_ave%next + END DO + IF( ll_ord ) EXIT + END DO + + ! write averaged info + WRITE(numtime,"('Averaged timing on all processors :')") + WRITE(numtime,"('-----------------------------------')") + WRITE(numtime,"('Section',13x,'Elap. Time(s)',2x,'Elap. Time(%)',2x, & + & 'CPU Time(s)',2x,'CPU Time(%)',2x,'CPU/Elap',1x, & + & 'Max elap(%)',2x,'Min elap(%)',2x, & + & 'Freq')") + sl_timer_ave => sl_timer_ave_root + clfmt = '((A),E15.7,2x,f6.2,5x,f12.2,5x,f6.2,5x,f7.2,2x,f12.2,4x,f6.2,2x,f9.2)' + DO WHILE ( ASSOCIATED(sl_timer_ave) ) + IF( sl_timer_ave%tsum_clock > 0. ) & + WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:18), & + & sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/tot_etime, & + & sl_timer_ave%tsum_cpu ,sl_timer_ave%tsum_cpu*100.*jpnij/tot_ctime , & + & sl_timer_ave%tsum_cpu/sl_timer_ave%tsum_clock, & + & sl_timer_ave%tmax_clock*100.*jpnij/tot_etime, & + & sl_timer_ave%tmin_clock*100.*jpnij/tot_etime, & + & sl_timer_ave%niter/REAL(jpnij) + sl_timer_ave => sl_timer_ave%next + END DO + WRITE(numtime,*) + ! + DEALLOCATE(sl_timer_ave_root) + ENDIF + ! + DEALLOCATE(sl_timer_glob_root) + ! + END SUBROUTINE waver_info + + + SUBROUTINE wmpi_info + !!---------------------------------------------------------------------- + !! *** ROUTINE wmpi_time *** + !! ** Purpose : compute and write a summary of MPI infos + !!---------------------------------------------------------------------- + ! + INTEGER :: idum, icode + INTEGER, ALLOCATABLE, DIMENSION(:) :: iall_rank + REAL(wp) :: ztot_ratio + REAL(wp) :: zmax_etime, zmax_ctime, zmax_ratio, zmin_etime, zmin_ctime, zmin_ratio + REAL(wp) :: zavg_etime, zavg_ctime, zavg_ratio + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zall_ratio + CHARACTER(LEN=128), dimension(8) :: cllignes + CHARACTER(LEN=128) :: clhline, clstart_date, clfinal_date + CHARACTER(LEN=2048) :: clfmt + + ! Gather all times + ALLOCATE( zall_ratio(jpnij), iall_rank(jpnij) ) + IF( narea == 1 ) THEN + iall_rank(:) = (/ (idum,idum=0,jpnij-1) /) + + ! Compute elapse user time + zavg_etime = tot_etime/REAL(jpnij,wp) + zmax_etime = MAXVAL(all_etime(:)) + zmin_etime = MINVAL(all_etime(:)) + + ! Compute CPU user time + zavg_ctime = tot_ctime/REAL(jpnij,wp) + zmax_ctime = MAXVAL(all_ctime(:)) + zmin_ctime = MINVAL(all_ctime(:)) + + ! Compute cpu/elapsed ratio + zall_ratio(:) = all_ctime(:) / all_etime(:) + ztot_ratio = SUM(all_ctime(:))/SUM(all_etime(:)) + zavg_ratio = SUM(zall_ratio(:))/REAL(jpnij,wp) + zmax_ratio = MAXVAL(zall_ratio(:)) + zmin_ratio = MINVAL(zall_ratio(:)) + + ! Output Format + clhline ='1x,13("-"),"|",18("-"),"|",14("-"),"|",18("-"),/,' + cllignes(1)='(1x,"MPI summary report :",/,' + cllignes(2)='1x,"--------------------",//,' + cllignes(3)='1x,"Process Rank |"," Elapsed Time (s) |"," CPU Time (s) |"," Ratio CPU/Elapsed",/,' + cllignes(4)=' (4x,i6,4x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),' + WRITE(cllignes(4)(1:6),'(I6)') jpnij + cllignes(5)='1x,"Total |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' + cllignes(6)='1x,"Minimum |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' + cllignes(7)='1x,"Maximum |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' + cllignes(8)='1x,"Average |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3)' + clfmt=TRIM(cllignes(1))// TRIM(cllignes(2))//TRIM(cllignes(3))// & + & TRIM(clhline)//TRIM(cllignes(4))//TRIM(clhline)//TRIM(cllignes(5))// & + & TRIM(clhline)//TRIM(cllignes(6))//TRIM(clhline)//TRIM(cllignes(7))// & + & TRIM(clhline)//TRIM(cllignes(8)) + WRITE(numtime, TRIM(clfmt)) & + (iall_rank(idum),all_etime(idum),all_ctime(idum),zall_ratio(idum),idum=1, jpnij), & + tot_etime, tot_ctime, ztot_ratio, & + zmin_etime, zmin_ctime, zmin_ratio, & + zmax_etime, zmax_ctime, zmax_ratio, & + zavg_etime, zavg_ctime, zavg_ratio + WRITE(numtime,*) + END IF + ! + DEALLOCATE(zall_ratio, iall_rank) + ! + END SUBROUTINE wmpi_info + + + SUBROUTINE timing_ini_var(cdinfo) + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_ini_var *** + !! ** Purpose : create timing structure + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdinfo + LOGICAL :: ll_section + + ! + IF( .NOT. ASSOCIATED(s_timer_root) ) THEN + ALLOCATE(s_timer_root) + s_timer_root%cname = cdinfo + s_timer_root%t_cpu = 0._wp + s_timer_root%t_clock = 0._wp + s_timer_root%tsum_cpu = 0._wp + s_timer_root%tsum_clock = 0._wp + s_timer_root%tmax_cpu = 0._wp + s_timer_root%tmax_clock = 0._wp + s_timer_root%tmin_cpu = 0._wp + s_timer_root%tmin_clock = 0._wp + s_timer_root%tsub_cpu = 0._wp + s_timer_root%tsub_clock = 0._wp + s_timer_root%ncount = 0 + s_timer_root%ncount_rate = 0 + s_timer_root%ncount_max = 0 + s_timer_root%niter = 0 + s_timer_root%l_tdone = .FALSE. + s_timer_root%next => NULL() + s_timer_root%prev => NULL() + s_timer => s_timer_root + ! + ALLOCATE(s_wrk) + s_wrk => NULL() + ! + ALLOCATE(s_timer_old) + s_timer_old%cname = cdinfo + s_timer_old%t_cpu = 0._wp + s_timer_old%t_clock = 0._wp + s_timer_old%tsum_cpu = 0._wp + s_timer_old%tsum_clock = 0._wp + s_timer_old%tmax_cpu = 0._wp + s_timer_old%tmax_clock = 0._wp + s_timer_old%tmin_cpu = 0._wp + s_timer_old%tmin_clock = 0._wp + s_timer_old%tsub_cpu = 0._wp + s_timer_old%tsub_clock = 0._wp + s_timer_old%ncount = 0 + s_timer_old%ncount_rate = 0 + s_timer_old%ncount_max = 0 + s_timer_old%niter = 0 + s_timer_old%l_tdone = .TRUE. + s_timer_old%next => NULL() + s_timer_old%prev => NULL() + + ELSE + s_timer => s_timer_root + ! case of already existing area (typically inside a loop) + ! write(*,*) 'in ini_var for routine : ', cdinfo + DO WHILE( ASSOCIATED(s_timer) ) + IF( TRIM(s_timer%cname) .EQ. TRIM(cdinfo) ) THEN + ! write(*,*) 'in ini_var for routine : ', cdinfo,' we return' + RETURN ! cdinfo is already in the chain + ENDIF + s_timer => s_timer%next + END DO + + ! end of the chain + s_timer => s_timer_root + DO WHILE( ASSOCIATED(s_timer%next) ) + s_timer => s_timer%next + END DO + + ! write(*,*) 'after search', s_timer%cname + ! cdinfo is not part of the chain so we add it with initialisation + ALLOCATE(s_timer%next) + ! write(*,*) 'after allocation of next' + + s_timer%next%cname = cdinfo + s_timer%next%t_cpu = 0._wp + s_timer%next%t_clock = 0._wp + s_timer%next%tsum_cpu = 0._wp + s_timer%next%tsum_clock = 0._wp + s_timer%next%tmax_cpu = 0._wp + s_timer%next%tmax_clock = 0._wp + s_timer%next%tmin_cpu = 0._wp + s_timer%next%tmin_clock = 0._wp + s_timer%next%tsub_cpu = 0._wp + s_timer%next%tsub_clock = 0._wp + s_timer%next%ncount = 0 + s_timer%next%ncount_rate = 0 + s_timer%next%ncount_max = 0 + s_timer%next%niter = 0 + s_timer%next%l_tdone = .FALSE. + s_timer%next%parent_section => NULL() + s_timer%next%prev => s_timer + s_timer%next%next => NULL() + s_timer => s_timer%next + ENDIF + ! write(*,*) 'after allocation' + ! + END SUBROUTINE timing_ini_var + + + SUBROUTINE timing_reset + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_reset *** + !! ** Purpose : go to root of timing tree + !!---------------------------------------------------------------------- + l_initdone = .TRUE. +! IF(lwp) WRITE(numout,*) +! IF(lwp) WRITE(numout,*) 'timing_reset : instrumented routines for timing' +! IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + CALL timing_list(s_timer_root) +! WRITE(numout,*) + ! + END SUBROUTINE timing_reset + + + RECURSIVE SUBROUTINE timing_list(ptr) + + TYPE(timer), POINTER, INTENT(inout) :: ptr + ! + IF( ASSOCIATED(ptr%next) ) CALL timing_list(ptr%next) + IF(lwp) WRITE(numout,*)' ', ptr%cname + ! + END SUBROUTINE timing_list + + + SUBROUTINE insert(sd_current, sd_root ,sd_ptr) + !!---------------------------------------------------------------------- + !! *** ROUTINE insert *** + !! ** Purpose : insert an element in timer structure + !!---------------------------------------------------------------------- + TYPE(timer), POINTER, INTENT(inout) :: sd_current, sd_root, sd_ptr + ! + + IF( ASSOCIATED( sd_current, sd_root ) ) THEN + ! If our current element is the root element then + ! replace it with the one being inserted + sd_root => sd_ptr + ELSE + sd_current%prev%next => sd_ptr + END IF + sd_ptr%next => sd_current + sd_ptr%prev => sd_current%prev + sd_current%prev => sd_ptr + ! Nullify the pointer to the new element now that it is held + ! within the list. If we don't do this then a subsequent call + ! to ALLOCATE memory to this pointer will fail. + sd_ptr => NULL() + ! + END SUBROUTINE insert + + + SUBROUTINE suppress(sd_ptr) + !!---------------------------------------------------------------------- + !! *** ROUTINE suppress *** + !! ** Purpose : supress an element in timer structure + !!---------------------------------------------------------------------- + TYPE(timer), POINTER, INTENT(inout) :: sd_ptr + ! + TYPE(timer), POINTER :: sl_temp + + sl_temp => sd_ptr + sd_ptr => sd_ptr%next + IF ( ASSOCIATED(sl_temp%next) ) sl_temp%next%prev => sl_temp%prev + DEALLOCATE(sl_temp) + sl_temp => NULL() + ! + END SUBROUTINE suppress + + !!===================================================================== +END MODULE timing diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..df02393b90f4f994438c8da30c340acf748c9fed --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv.f90 @@ -0,0 +1,342 @@ + + + + + + + + + + + + + +MODULE traadv + !!============================================================================== + !! *** MODULE traadv *** + !! Ocean active tracers: advection trend + !!============================================================================== + !! History : 2.0 ! 2005-11 (G. Madec) Original code + !! 3.3 ! 2010-09 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !! 3.6 ! 2011-06 (G. Madec) Addition of Mixed Layer Eddy parameterisation + !! 3.7 ! 2014-05 (G. Madec) Add 2nd/4th order cases for CEN and FCT schemes + !! - ! 2014-12 (G. Madec) suppression of cross land advection option + !! 3.6 ! 2015-06 (E. Clementi) Addition of Stokes drift in case of wave coupling + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv : compute ocean tracer advection trend + !! tra_adv_init : control the different options of advection scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + USE domtile + USE domvvl ! variable vertical scale factors + USE sbcwave ! wave module + USE sbc_oce ! surface boundary condition: ocean + USE traadv_cen ! centered scheme (tra_adv_cen routine) + USE traadv_fct ! FCT scheme (tra_adv_fct routine) + USE traadv_mus ! MUSCL scheme (tra_adv_mus routine) + USE traadv_ubs ! UBS scheme (tra_adv_ubs routine) + USE traadv_qck ! QUICKEST scheme (tra_adv_qck routine) + USE tramle ! Mixed Layer Eddy transport (tra_mle_trp routine) + USE ldftra ! Eddy Induced transport (ldf_eiv_trp routine) + USE ldfslp ! Lateral diffusion: slopes of neutral surfaces + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE diaptr ! Poleward heat transport + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE prtctl ! Print control + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv ! called by step.F90 + PUBLIC tra_adv_init ! called by nemogcm.F90 + + ! !!* Namelist namtra_adv * + LOGICAL :: ln_traadv_OFF ! no advection on T and S + LOGICAL :: ln_traadv_cen ! centered scheme flag + INTEGER :: nn_cen_h, nn_cen_v ! =2/4 : horizontal and vertical choices of the order of CEN scheme + LOGICAL :: ln_traadv_fct ! FCT scheme flag + INTEGER :: nn_fct_h, nn_fct_v ! =2/4 : horizontal and vertical choices of the order of FCT scheme + LOGICAL :: ln_traadv_mus ! MUSCL scheme flag + LOGICAL :: ln_mus_ups ! use upstream scheme in vivcinity of river mouths + LOGICAL :: ln_traadv_ubs ! UBS scheme flag + INTEGER :: nn_ubs_v ! =2/4 : vertical choice of the order of UBS scheme + LOGICAL :: ln_traadv_qck ! QUICKEST scheme flag + + INTEGER, PUBLIC :: nadv ! choice of the type of advection scheme + ! ! associated indices: + INTEGER, PARAMETER, PUBLIC :: np_NO_adv = 0 ! no T-S advection + INTEGER, PARAMETER, PUBLIC :: np_CEN = 1 ! 2nd/4th order centered scheme + INTEGER, PARAMETER, PUBLIC :: np_FCT = 2 ! 2nd/4th order Flux Corrected Transport scheme + INTEGER, PARAMETER, PUBLIC :: np_MUS = 3 ! MUSCL scheme + INTEGER, PARAMETER, PUBLIC :: np_UBS = 4 ! 3rd order Upstream Biased Scheme + INTEGER, PARAMETER, PUBLIC :: np_QCK = 5 ! QUICK scheme + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv.F90 15073 2021-07-02 14:20:14Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv( kt, Kbb, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv *** + !! + !! ** Purpose : compute the ocean tracer advection trend. + !! + !! ** Method : - Update (uu(:,:,:,Krhs),vv(:,:,:,Krhs)) with the advection term following nadv + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kbb, Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! dummy loop index + ! TEMP: [tiling] This change not necessary and can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zvv, zww ! 3D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + LOGICAL :: lskip + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_adv') + ! + lskip = .FALSE. + + ! TEMP: [tiling] These changes not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + ALLOCATE( zuu(jpi,jpj,jpk), zvv(jpi,jpj,jpk), zww(jpi,jpj,jpk) ) + ENDIF + + ! TEMP: [tiling] These changes not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( ln_tile .AND. nadv == np_FCT ) THEN + IF( ntile == 1 ) THEN + CALL dom_tile_stop( ldhold=.TRUE. ) + ELSE + lskip = .TRUE. + ENDIF + ENDIF + IF( .NOT. lskip ) THEN + ! !== effective transport ==! + IF( ln_wave .AND. ln_sdw ) THEN + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls)*nthr) + zuu(ji,jj,jk) = e2u (ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * ( uu(ji,jj,jk,Kmm) + usd(ji,jj,jk) ) + zvv(ji,jj,jk) = e1v (ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * ( vv(ji,jj,jk,Kmm) + vsd(ji,jj,jk) ) + END DO ; END DO ; END DO + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zww(ji,jj,jk) = e1e2t(ji,jj) * ( ww(ji,jj,jk) + wsd(ji,jj,jk) ) + END DO ; END DO ; END DO + ELSE + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls)*nthr) + zuu(ji,jj,jk) = e2u (ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * uu(ji,jj,jk,Kmm) ! eulerian transport only + zvv(ji,jj,jk) = e1v (ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * vv(ji,jj,jk,Kmm) + END DO ; END DO ; END DO + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zww(ji,jj,jk) = e1e2t(ji,jj) * ww(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ! + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls)*nthr) + zuu(ji,jj,jk) = zuu(ji,jj,jk) + un_td(ji,jj,jk) + zvv(ji,jj,jk) = zvv(ji,jj,jk) + vn_td(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ! + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls)*nthr) + zuu(ji,jj,jpk) = 0._wp ! no transport trough the bottom + zvv(ji,jj,jpk) = 0._wp + zww(ji,jj,jpk) = 0._wp + END DO ; END DO + ! + IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & + & CALL ldf_eiv_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) + ! + IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm ) ! add the mle transport (if necessary) + ! + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + CALL iom_put( "uocetr_eff", zuu ) ! output effective transport + CALL iom_put( "vocetr_eff", zvv ) + CALL iom_put( "wocetr_eff", zww ) + ENDIF + ! +!!gm ??? + ! TEMP: [tiling] This copy-in not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + CALL dia_ptr( kt, Kmm, zvv(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),:) ) ! diagnose the effective MSF +!!gm ??? + ! + + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) + ENDIF + ! + SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! + ! + CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order + CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) + CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order + CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) + CASE ( np_MUS ) ! MUSCL + CALL tra_adv_mus( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) + CASE ( np_UBS ) ! UBS + CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v ) + CASE ( np_QCK ) ! QUICKEST + CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) + ! + END SELECT + ! + IF( l_trdtra ) THEN ! save the advective trends for further diagnostics + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) + ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) + END DO + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + ENDIF + + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( ln_tile .AND. .NOT. l_istiled ) CALL dom_tile_start( ldhold=.TRUE. ) + ENDIF + ! ! print mean trends (used for debugging) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only for the full domain + DEALLOCATE( zuu, zvv, zww ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop( 'tra_adv' ) + ! + END SUBROUTINE tra_adv + + + SUBROUTINE tra_adv_init + !!--------------------------------------------------------------------- + !! *** ROUTINE tra_adv_init *** + !! + !! ** Purpose : Control the consistency between namelist options for + !! tracer advection schemes and set nadv + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ios ! Local integers + ! + NAMELIST/namtra_adv/ ln_traadv_OFF, & ! No advection + & ln_traadv_cen , nn_cen_h, nn_cen_v, & ! CEN + & ln_traadv_fct , nn_fct_h, nn_fct_v, & ! FCT + & ln_traadv_mus , ln_mus_ups, & ! MUSCL + & ln_traadv_ubs , nn_ubs_v, & ! UBS + & ln_traadv_qck ! QCK + !!---------------------------------------------------------------------- + ! + ! !== Namelist ==! + READ ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in reference namelist' ) + ! + READ ( numnam_cfg, namtra_adv, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_adv in configuration namelist' ) + IF(lwm) WRITE( numond, namtra_adv ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'tra_adv_init : choice/control of the tracer advection scheme' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtra_adv : chose a advection scheme for tracers' + WRITE(numout,*) ' No advection on T & S ln_traadv_OFF = ', ln_traadv_OFF + WRITE(numout,*) ' centered scheme ln_traadv_cen = ', ln_traadv_cen + WRITE(numout,*) ' horizontal 2nd/4th order nn_cen_h = ', nn_fct_h + WRITE(numout,*) ' vertical 2nd/4th order nn_cen_v = ', nn_fct_v + WRITE(numout,*) ' Flux Corrected Transport scheme ln_traadv_fct = ', ln_traadv_fct + WRITE(numout,*) ' horizontal 2nd/4th order nn_fct_h = ', nn_fct_h + WRITE(numout,*) ' vertical 2nd/4th order nn_fct_v = ', nn_fct_v + WRITE(numout,*) ' MUSCL scheme ln_traadv_mus = ', ln_traadv_mus + WRITE(numout,*) ' + upstream scheme near river mouths ln_mus_ups = ', ln_mus_ups + WRITE(numout,*) ' UBS scheme ln_traadv_ubs = ', ln_traadv_ubs + WRITE(numout,*) ' vertical 2nd/4th order nn_ubs_v = ', nn_ubs_v + WRITE(numout,*) ' QUICKEST scheme ln_traadv_qck = ', ln_traadv_qck + ENDIF + ! + ! !== Parameter control & set nadv ==! + ioptio = 0 + IF( ln_traadv_OFF ) THEN ; ioptio = ioptio + 1 ; nadv = np_NO_adv ; ENDIF + IF( ln_traadv_cen ) THEN ; ioptio = ioptio + 1 ; nadv = np_CEN ; ENDIF + IF( ln_traadv_fct ) THEN ; ioptio = ioptio + 1 ; nadv = np_FCT ; ENDIF + IF( ln_traadv_mus ) THEN ; ioptio = ioptio + 1 ; nadv = np_MUS ; ENDIF + IF( ln_traadv_ubs ) THEN ; ioptio = ioptio + 1 ; nadv = np_UBS ; ENDIF + IF( ln_traadv_qck ) THEN ; ioptio = ioptio + 1 ; nadv = np_QCK ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'tra_adv_init: Choose ONE advection option in namelist namtra_adv' ) + ! + IF( ln_traadv_cen .AND. ( nn_cen_h /= 2 .AND. nn_cen_h /= 4 ) & ! Centered + .AND. ( nn_cen_v /= 2 .AND. nn_cen_v /= 4 ) ) THEN + CALL ctl_stop( 'tra_adv_init: CEN scheme, choose 2nd or 4th order' ) + ENDIF + IF( ln_traadv_fct .AND. ( nn_fct_h /= 2 .AND. nn_fct_h /= 4 ) & ! FCT + .AND. ( nn_fct_v /= 2 .AND. nn_fct_v /= 4 ) ) THEN + CALL ctl_stop( 'tra_adv_init: FCT scheme, choose 2nd or 4th order' ) + ENDIF + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( ln_traadv_fct .AND. ln_tile ) THEN + CALL ctl_warn( 'tra_adv_init: FCT scheme does not yet work with tiling' ) + ENDIF + IF( ln_traadv_ubs .AND. ( nn_ubs_v /= 2 .AND. nn_ubs_v /= 4 ) ) THEN ! UBS + CALL ctl_stop( 'tra_adv_init: UBS scheme, choose 2nd or 4th order' ) + ENDIF + IF( ln_traadv_ubs .AND. nn_ubs_v == 4 ) THEN + CALL ctl_warn( 'tra_adv_init: UBS scheme, only 2nd FCT scheme available on the vertical. It will be used' ) + ENDIF + IF( ln_isfcav ) THEN ! ice-shelf cavities + IF( ln_traadv_cen .AND. nn_cen_v == 4 .OR. & ! NO 4th order with ISF + & ln_traadv_fct .AND. nn_fct_v == 4 ) CALL ctl_stop( 'tra_adv_init: 4th order COMPACT scheme not allowed with ISF' ) + ENDIF + ! + ! !== Print the choice ==! + IF(lwp) THEN + WRITE(numout,*) + SELECT CASE ( nadv ) + CASE( np_NO_adv ) ; WRITE(numout,*) ' ==>>> NO T-S advection' + CASE( np_CEN ) ; WRITE(numout,*) ' ==>>> CEN scheme is used. Horizontal order: ', nn_cen_h, & + & ' Vertical order: ', nn_cen_v + CASE( np_FCT ) ; WRITE(numout,*) ' ==>>> FCT scheme is used. Horizontal order: ', nn_fct_h, & + & ' Vertical order: ', nn_fct_v + CASE( np_MUS ) ; WRITE(numout,*) ' ==>>> MUSCL scheme is used' + CASE( np_UBS ) ; WRITE(numout,*) ' ==>>> UBS scheme is used' + CASE( np_QCK ) ; WRITE(numout,*) ' ==>>> QUICKEST scheme is used' + END SELECT + ENDIF + ! + CALL tra_mle_init !== initialisation of the Mixed Layer Eddy parametrisation (MLE) ==! + ! + END SUBROUTINE tra_adv_init + + !!====================================================================== +END MODULE traadv diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_cen.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_cen.f90 new file mode 100644 index 0000000000000000000000000000000000000000..113369b5ec14491f83d841ebe1d1e81bf1cc1baa --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_cen.f90 @@ -0,0 +1,217 @@ + + + + + + + + + + + + + +MODULE traadv_cen + !!====================================================================== + !! *** MODULE traadv_cen *** + !! Ocean tracers: advective trend (2nd/4th order centered) + !!====================================================================== + !! History : 3.7 ! 2014-05 (G. Madec) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_cen : update the tracer trend with the advection trends using a centered or scheme (2nd or 4th order) + !! NB: on the vertical it is actually a 4th order COMPACT scheme which is used + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE eosbn2 ! equation of state + USE traadv_fct ! acces to routine interp_4th_cpt + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + ! + USE in_out_manager ! I/O manager + USE iom ! IOM library + USE trc_oce ! share passive tracers/Ocean variables + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_cen ! called by traadv.F90 + + REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat/salt transport + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_cen.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_cen( kt, kit000, cdtype, pU, pV, pW, & + & Kmm, pt, kjpt, Krhs, kn_cen_h, kn_cen_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_cen *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The advection is evaluated by a 2nd or 4th order scheme + !! using now fields (leap-frog scheme). + !! kn_cen_h = 2 ==>> 2nd order centered scheme on the horizontal + !! = 4 ==>> 4th order - - - - + !! kn_cen_v = 2 ==>> 2nd order centered scheme on the vertical + !! = 4 ==>> 4th order COMPACT scheme - - + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (l_diaptr=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kn_cen_h ! =2/4 (2nd or 4th order scheme) + INTEGER , INTENT(in ) :: kn_cen_v ! =2/4 (2nd or 4th order scheme) + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zC2t_u, zC4t_u ! local scalars + REAL(wp) :: zC2t_v, zC4t_v ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwx, zwy, zwz, ztu, ztv, ztw + !!---------------------------------------------------------------------- + ! + 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,*) 'tra_adv_cen : centered advection scheme on ', cdtype, ' order h/v =', kn_cen_h,'/', kn_cen_v + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! ! set local switches + l_trd = .FALSE. + l_hst = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + ! + zwz(:,:, 1 ) = 0._wp ! surface & bottom vertical flux set to zero for all tracers + zwz(:,:,jpk) = 0._wp + ! + DO jn = 1, kjpt !== loop over the tracers ==! + ! + SELECT CASE( kn_cen_h ) !-- Horizontal fluxes --! + ! + CASE( 2 ) !* 2nd order centered + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ) + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) ) + END DO ; END DO ; END DO + ! + CASE( 4 ) !* 4th order centered + ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero + ztv(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) ! masked gradient + ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) + ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) + END DO ; END DO ; END DO + IF (nn_hls==1) CALL lbc_lnk( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( 0) ; DO ji = ntsi-( nn_hls-1), ntei+( 0) ! Horizontal advective fluxes + zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! C2 interpolation of T at u- & v-points (x2) + zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) + ! ! C4 interpolation of T at u- & v-points (x2) + zC4t_u = zC2t_u + r1_6 * ( ztu(ji-1,jj,jk) - ztu(ji+1,jj,jk) ) + zC4t_v = zC2t_v + r1_6 * ( ztv(ji,jj-1,jk) - ztv(ji,jj+1,jk) ) + ! ! C4 fluxes + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * zC4t_u + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v + END DO ; END DO ; END DO + IF (nn_hls==1) CALL lbc_lnk( 'traadv_cen', zwx, 'U', -1._wp , zwy, 'V', -1._wp ) + ! + CASE DEFAULT + CALL ctl_stop( 'traadv_cen: wrong value for nn_cen' ) + END SELECT + ! + SELECT CASE( kn_cen_v ) !-- Vertical fluxes --! (interior) + ! + CASE( 2 ) !* 2nd order centered + DO jk = 2, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + CASE( 4 ) !* 4th order compact + CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! ztw = interpolated value of T at w-point + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zwz(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + END SELECT + ! + IF( ln_linssh ) THEN !* top value (linear free surf. only as zwz is multiplied by wmask) + IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) + END DO ; END DO + ELSE ! no ice-shelf cavities (only ocean surface) + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) + END DO ; END DO + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !-- Divergence of advective fluxes --! + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & + & - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! ! trend diagnostics + IF( l_trd ) THEN + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) + ENDIF + ! ! "Poleward" heat and salt transports + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) + ! ! heat and salt transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) ) + ! + END DO + ! + END SUBROUTINE tra_adv_cen + + !!====================================================================== +END MODULE traadv_cen diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_cen_lf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_cen_lf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d3a30b876367b6fe33da9c3517f7ef508394795a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_cen_lf.f90 @@ -0,0 +1,216 @@ + + + + + + + + + + + + + +MODULE traadv_cen_lf + !!====================================================================== + !! *** MODULE traadv_cen *** + !! Ocean tracers: advective trend (2nd/4th order centered) + !!====================================================================== + !! History : 3.7 ! 2014-05 (G. Madec) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_cen : update the tracer trend with the advection trends using a centered or scheme (2nd or 4th order) + !! NB: on the vertical it is actually a 4th order COMPACT scheme which is used + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE eosbn2 ! equation of state + USE traadv_fct ! acces to routine interp_4th_cpt + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + ! + USE in_out_manager ! I/O manager + USE iom ! IOM library + USE trc_oce ! share passive tracers/Ocean variables + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_cen_lf ! called by traadv.F90 + + REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat/salt transport + + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_cen.F90 14776 2021-04-30 12:33:41Z mocavero $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_cen_lf( kt, kit000, cdtype, pU, pV, pW, & + & Kmm, pt, kjpt, Krhs, kn_cen_h, kn_cen_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_cen *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The advection is evaluated by a 2nd or 4th order scheme + !! using now fields (leap-frog scheme). + !! kn_cen_h = 2 ==>> 2nd order centered scheme on the horizontal + !! = 4 ==>> 4th order - - - - + !! kn_cen_v = 2 ==>> 2nd order centered scheme on the vertical + !! = 4 ==>> 4th order COMPACT scheme - - + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (l_diaptr=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kn_cen_h ! =2/4 (2nd or 4th order scheme) + INTEGER , INTENT(in ) :: kn_cen_v ! =2/4 (2nd or 4th order scheme) + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zC2t_u, zC4t_u ! local scalars + REAL(wp) :: zC2t_v, zC4t_v ! - - + REAL(wp) :: ztu_im1, ztu_ip1 ! - - + REAL(wp) :: ztv_jm1, ztv_jp1 ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwx, zwy, zwz, ztw + !!---------------------------------------------------------------------- + ! + IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv_cen : centered advection scheme on ', cdtype, ' order h/v =', kn_cen_h,'/', kn_cen_v + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! ! set local switches + l_trd = .FALSE. + l_hst = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + ! + zwz(:,:, 1 ) = 0._wp ! surface & bottom vertical flux set to zero for all tracers + zwz(:,:,jpk) = 0._wp + ! + DO jn = 1, kjpt !== loop over the tracers ==! + ! + SELECT CASE( kn_cen_h ) !-- Horizontal fluxes --! + ! + CASE( 2 ) !* 2nd order centered + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ) + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) ) + END DO ; END DO ; END DO + ! + CASE( 4 ) !* 4th order centered + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) ! Horizontal advective fluxes + ztu_im1 = ( pt(ji,jj ,jk,jn,Kmm) - pt(ji-1,jj,jk,jn,Kmm) ) * umask(ji-1,jj,jk) + ztu_ip1 = ( pt(ji+2,jj ,jk,jn,Kmm) - pt(ji+1,jj,jk,jn,Kmm) ) * umask(ji+1,jj,jk) + ztv_jm1 = ( pt(ji,jj,jk,jn,Kmm) - pt(ji,jj-1,jk,jn,Kmm) ) * vmask(ji,jj-1,jk) + ztv_jp1 = ( pt(ji,jj+2,jk,jn,Kmm) - pt(ji,jj+1,jk,jn,Kmm) ) * vmask(ji,jj+1,jk) + ! + zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! C2 interpolation of T at u- & v-points (x2) + zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) + ! ! C4 interpolation of T at u- & v-points (x2) + zC4t_u = zC2t_u + r1_6 * ( ztu_im1 - ztu_ip1 ) + zC4t_v = zC2t_v + r1_6 * ( ztv_jm1 - ztv_jp1 ) + ! ! C4 fluxes + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * zC4t_u + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v + END DO ; END DO ; END DO + ! + CASE DEFAULT + CALL ctl_stop( 'traadv_cen: wrong value for nn_cen' ) + END SELECT + ! + SELECT CASE( kn_cen_v ) !-- Vertical fluxes --! (interior) + ! + CASE( 2 ) !* 2nd order centered + DO jk = 2, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + CASE( 4 ) !* 4th order compact + CALL interp_4th_cpt( REAL(pt(:,:,:,jn,Kmm),dp) , ztw ) ! ztw = interpolated value of T at w-point + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zwz(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + END SELECT + ! + IF( ln_linssh ) THEN !* top value (linear free surf. only as zwz is multiplied by wmask) + IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) + END DO ; END DO + ELSE ! no ice-shelf cavities (only ocean surface) + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) + END DO ; END DO + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !-- Divergence of advective fluxes --! + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & + & - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! ! trend diagnostics + IF( l_trd ) THEN + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, REAL(pt(:,:,:,jn,Kmm),dp) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, REAL(pt(:,:,:,jn,Kmm),dp) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, REAL(pt(:,:,:,jn,Kmm),dp) ) + ENDIF + ! ! "Poleward" heat and salt transports + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) + ! ! heat and salt transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) ) + ! + END DO + ! + END SUBROUTINE tra_adv_cen_lf + + !!====================================================================== +END MODULE traadv_cen_lf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_fct.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_fct.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2ec28c791042be3ee8f6e8f26375ab72010ba073 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_fct.f90 @@ -0,0 +1,708 @@ + + + + + + + + + + + + + +MODULE traadv_fct + !!============================================================================== + !! *** MODULE traadv_fct *** + !! Ocean tracers: horizontal & vertical advective trend (2nd/4th order Flux Corrected Transport method) + !!============================================================================== + !! History : 3.7 ! 2015-09 (L. Debreu, G. Madec) original code (inspired from traadv_tvd.F90) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_fct : update the tracer trend with a 3D advective trends using a 2nd or 4th order FCT scheme + !! with sub-time-stepping in the vertical direction + !! nonosc : compute monotonic tracer fluxes by a non-oscillatory algorithm + !! interp_4th_cpt : 4th order compact scheme for the vertical component of the advection + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE trc_oce ! share passive tracers/Ocean variables + USE trd_oce ! trends: ocean variables + USE trdtra ! tracers trends + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + USE phycst , ONLY : rho0_rcp + USE zdf_oce , ONLY : ln_zad_Aimp + ! + USE in_out_manager ! I/O manager + USE iom ! + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_fct ! called by traadv.F90 + PUBLIC interp_4th_cpt ! called by traadv_cen.F90 + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat/salt transport + REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 + + ! ! tridiag solver associated indices: + INTEGER, PARAMETER :: np_NH = 0 ! Neumann homogeneous boundary condition + INTEGER, PARAMETER :: np_CEN2 = 1 ! 2nd order centered boundary condition + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_fct.F90 14857 2021-05-12 16:47:25Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_fct( kt, kit000, cdtype, p2dt, pU, pV, pW, & + & Kbb, Kmm, pt, kjpt, Krhs, kn_fct_h, kn_fct_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_fct *** + !! + !! ** Purpose : Compute the now trend due to total advection of tracers + !! and add it to the general trend of tracer equations + !! + !! ** Method : - 2nd or 4th FCT scheme on the horizontal direction + !! (choice through the value of kn_fct) + !! - on the vertical the 4th order is a compact scheme + !! - corrected flux (monotonic correction) + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostics (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kn_fct_h ! order of the FCT scheme (=2 or 4) + INTEGER , INTENT(in ) :: kn_fct_v ! order of the FCT scheme (=2 or 4) + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra ! local scalar + REAL(wp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u ! - - + REAL(wp) :: zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwi, zwz, ztu, ztv, zltu, zltv, ztw + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwx, zwy + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup + LOGICAL :: ll_zAimp ! flag to apply adaptive implicit vertical advection + !!---------------------------------------------------------------------- + ! + 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,*) 'tra_adv_fct : FCT advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + l_trd = .FALSE. ! set local switches + l_hst = .FALSE. + l_ptr = .FALSE. + ll_zAimp = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ! + ENDIF + + !! -- init to 0 + zwi(:,:,:) = 0._wp + zwx(:,:,:) = 0._wp + zwy(:,:,:) = 0._wp + zwz(:,:,:) = 0._wp + ztu(:,:,:) = 0._wp + ztv(:,:,:) = 0._wp + zltu(:,:,:) = 0._wp + zltv(:,:,:) = 0._wp + ztw(:,:,:) = 0._wp + ! + IF( l_trd .OR. l_hst ) THEN + ALLOCATE( ztrdx(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), ztrdy(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), ztrdz(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) ) + ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp + ENDIF + ! + IF( l_ptr ) THEN + ALLOCATE( zptry(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) ) + zptry(:,:,:) = 0._wp + ENDIF + ! + ! If adaptive vertical advection, check if it is needed on this PE at this time + IF( ln_zad_Aimp ) THEN + IF( MAXVAL( ABS( wi(ntsi-(1):ntei+(1),ntsj-(1):ntej+(1),:) ) ) > 0._wp ) ll_zAimp = .TRUE. + END IF + ! If active adaptive vertical advection, build tridiagonal matrix + IF( ll_zAimp ) THEN + ALLOCATE(zwdia(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), zwinf(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), zwsup(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk)) + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) & + & / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Krhs)*tmask(ji,jj,jk))) + zwinf(ji,jj,jk) = p2dt * MIN( wi(ji,jj,jk ) , 0._wp ) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Krhs)*tmask(ji,jj,jk))) + zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Krhs)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + END IF + ! + DO jn = 1, kjpt !== loop over the tracers ==! + ! + ! !== upstream advection with initial mass fluxes & intermediate update ==! + ! !* upstream tracer flux in the i and j direction + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + ! upstream scheme + zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) + zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) + zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) + zfm_vj = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) + zwx(ji,jj,jk) = 0.5 * ( zfp_ui * pt(ji,jj,jk,jn,Kbb) + zfm_ui * pt(ji+1,jj ,jk,jn,Kbb) ) + zwy(ji,jj,jk) = 0.5 * ( zfp_vj * pt(ji,jj,jk,jn,Kbb) + zfm_vj * pt(ji ,jj+1,jk,jn,Kbb) ) + END DO ; END DO ; END DO + ! !* upstream tracer flux in the k direction *! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! Interior value ( multiplied by wmask) + zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) + zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) + zwz(ji,jj,jk) = 0.5 * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as zwz has been w-masked) + IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface + END DO ; END DO + ELSE ! no cavities: only at the ocean surface + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) + END DO ; END DO + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !* trend and after field with monotonic scheme + ! ! total intermediate advective trends + ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) + ! ! update and guess with monotonic sheme + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra & + & / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm )*tmask(ji,jj,jk))) * tmask(ji,jj,jk) + zwi(ji,jj,jk) = ( (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kbb)*tmask(ji,jj,jk))) * pt(ji,jj,jk,jn,Kbb) + p2dt * ztra ) & + & / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Krhs)*tmask(ji,jj,jk))) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + + IF ( ll_zAimp ) THEN + CALL tridia_solver( zwdia, zwsup, zwinf, zwi, zwi , 0 ) + ! + ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! Interior value ( multiplied by wmask) + zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) + zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) + ztw(ji,jj,jk) = 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) + zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! update vertical fluxes + END DO ; END DO ; END DO + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + END IF + ! + IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) + ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) + END IF + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:) + ! + ! !== anti-diffusive flux : high order minus low order ==! + ! + SELECT CASE( kn_fct_h ) !* horizontal anti-diffusive fluxes + ! + CASE( 2 ) !- 2nd order centered + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj,jk,jn,Kmm) ) - zwx(ji,jj,jk) + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj+1,jk,jn,Kmm) ) - zwy(ji,jj,jk) + END DO ; END DO ; END DO + ! + CASE( 4 ) !- 4th order centered + zltu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero + zltv(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 ! Laplacian + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) ! 1st derivative (gradient) + ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) + ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) + END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! 2nd derivative * 1/ 6 + zltu(ji,jj,jk) = ( ztu(ji,jj,jk) + ztu(ji-1,jj,jk) ) * r1_6 + zltv(ji,jj,jk) = ( ztv(ji,jj,jk) + ztv(ji,jj-1,jk) ) * r1_6 + END DO ; END DO + END DO + ! NOTE [ comm_cleanup ] : need to change sign to ensure halo 1 - halo 2 compatibility + CALL lbc_lnk( 'traadv_fct', zltu, 'T', -1.0_wp , zltv, 'T', -1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points + zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) + ! ! C4 minus upstream advective fluxes + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( zC2t_u + ( zltu(ji,jj,jk) - zltu(ji+1,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) - zwx(ji,jj,jk) + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( zC2t_v + ( zltv(ji,jj,jk) - zltv(ji,jj+1,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) - zwy(ji,jj,jk) + END DO ; END DO ; END DO + ! + CASE( 41 ) !- 4th order centered ==>> !!gm coding attempt need to be tested + ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero + ztv(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! 1st derivative (gradient) + ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) + ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) + END DO ; END DO ; END DO + IF (nn_hls==1) CALL lbc_lnk( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! Horizontal advective fluxes + zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points (x2) + zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) + ! ! C4 interpolation of T at u- & v-points (x2) + zC4t_u = zC2t_u + r1_6 * ( ztu(ji-1,jj ,jk) - ztu(ji+1,jj ,jk) ) + zC4t_v = zC2t_v + r1_6 * ( ztv(ji ,jj-1,jk) - ztv(ji ,jj+1,jk) ) + ! ! C4 minus upstream advective fluxes + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * zC4t_u - zwx(ji,jj,jk) + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) + END DO ; END DO ; END DO + IF (nn_hls==2) CALL lbc_lnk( 'traadv_fct', zwx, 'U', -1.0_dp , zwy, 'V', -1.0_dp ) ! Lateral boundary cond. (unchanged sgn) + ! + END SELECT + ! + SELECT CASE( kn_fct_v ) !* vertical anti-diffusive fluxes (w-masked interior values) + ! + CASE( 2 ) !- 2nd order centered + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ( pW(ji,jj,jk) * 0.5_wp * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) & + & - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + CASE( 4 ) !- 4th order COMPACT + CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! zwt = COMPACT interpolation of T at w-point + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwz(ji,jj,jk) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + END SELECT + IF( ln_linssh ) THEN ! top ocean value: high order = upstream ==>> zwz=0 + zwz(:,:,1) = 0._wp ! only ocean surface as interior zwz values have been w-masked + ENDIF + ! + IF (nn_hls==1) THEN + CALL lbc_lnk( 'traadv_fct', zwx, 'U', -1.0_dp , zwy, 'V', -1.0_dp) + CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp , zwz, 'T', 1.0_wp ) + ELSE + CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) + END IF + ! + IF ( ll_zAimp ) THEN + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !* trend and after field with monotonic scheme + ! ! total intermediate advective trends + ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) + ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Krhs)*tmask(ji,jj,jk))) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! Interior value ( multiplied by wmask) + zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) + zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) + zwz(ji,jj,jk) = zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + END IF + ! + ! !== monotonicity algorithm ==! + ! + CALL nonosc( Kmm, pt(:,:,:,jn,Kbb), zwx, zwy, zwz, zwi, p2dt ) + ! + ! !== final trend with corrected fluxes ==! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Krhs)*tmask(ji,jj,jk))) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + IF ( ll_zAimp ) THEN + ! + ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! Interior value ( multiplied by wmask) + zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) + zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) + ztw(ji,jj,jk) = - 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) + zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! Update vertical fluxes for trend diagnostic + END DO ; END DO ; END DO + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + END IF + IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport + ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes + ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! to upstream fluxes + ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! + ! + IF( l_trd ) THEN ! trend diagnostics + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztrdx, pU, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztrdy, pV, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, ztrdz, pW, pt(:,:,:,jn,Kmm) ) + ENDIF + ! ! heat/salt transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) ) + ! + ENDIF + IF( l_ptr ) THEN ! "Poleward" transports + zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< add anti-diffusive fluxes + CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) ) + ENDIF + ! + END DO ! end of tracer loop + ! + IF ( ll_zAimp ) THEN + DEALLOCATE( zwdia, zwinf, zwsup ) + ENDIF + IF( l_trd .OR. l_hst ) THEN + DEALLOCATE( ztrdx, ztrdy, ztrdz ) + ENDIF + IF( l_ptr ) THEN + DEALLOCATE( zptry ) + ENDIF + ! + END SUBROUTINE tra_adv_fct + + + SUBROUTINE nonosc( Kmm, pbef, paa, pbb, pcc, paft, p2dt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE nonosc *** + !! + !! ** Purpose : compute monotonic tracer fluxes from the upstream + !! scheme and the before field by a nonoscillatory algorithm + !! + !! ** Method : ... ??? + !! warning : pbef and paft must be masked, but the boundaries + !! conditions on the fluxes are not necessary zalezak (1979) + !! drange (1995) multi-dimensional forward-in-time and upstream- + !! in-space based differencing for fluid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pbef ! before field + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) ,jpk), INTENT(in ) :: paft ! after field + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) ,jpk), INTENT(inout) :: pcc! monotonic fluxes in the 3 directions + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) ,jpk), INTENT(inout) :: paa, pbb! monotonic fluxes in the 3 directions + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikm1 ! local integer + REAL(dp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars + REAL(dp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zbetup, zbetdo, zbup, zbdo + !!---------------------------------------------------------------------- + ! + zbig = 1.e+40_dp + zrtrn = 1.e-15_dp + zbetup(:,:,:) = 0._dp ; zbetdo(:,:,:) = 0._dp + + ! Search local extrema + ! -------------------- + ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zbup(ji,jj,jk) = MAX( pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ), & + & paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ) ) + zbdo(ji,jj,jk) = MIN( pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ), & + & paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ) ) + END DO ; END DO ; END DO + + DO jk = 1, jpkm1 + ikm1 = MAX(jk-1,1) + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + + ! search maximum in neighbourhood + zup = MAX( zbup(ji ,jj ,jk ), & + & zbup(ji-1,jj ,jk ), zbup(ji+1,jj ,jk ), & + & zbup(ji ,jj-1,jk ), zbup(ji ,jj+1,jk ), & + & zbup(ji ,jj ,ikm1), zbup(ji ,jj ,jk+1) ) + + ! search minimum in neighbourhood + zdo = MIN( zbdo(ji ,jj ,jk ), & + & zbdo(ji-1,jj ,jk ), zbdo(ji+1,jj ,jk ), & + & zbdo(ji ,jj-1,jk ), zbdo(ji ,jj+1,jk ), & + & zbdo(ji ,jj ,ikm1), zbdo(ji ,jj ,jk+1) ) + + ! positive part of the flux + zpos = MAX( 0., paa(ji-1,jj ,jk ) ) - MIN( 0., paa(ji ,jj ,jk ) ) & + & + MAX( 0., pbb(ji ,jj-1,jk ) ) - MIN( 0., pbb(ji ,jj ,jk ) ) & + & + MAX( 0., pcc(ji ,jj ,jk+1) ) - MIN( 0., pcc(ji ,jj ,jk ) ) + + ! negative part of the flux + zneg = MAX( 0., paa(ji ,jj ,jk ) ) - MIN( 0., paa(ji-1,jj ,jk ) ) & + & + MAX( 0., pbb(ji ,jj ,jk ) ) - MIN( 0., pbb(ji ,jj-1,jk ) ) & + & + MAX( 0., pcc(ji ,jj ,jk ) ) - MIN( 0., pcc(ji ,jj ,jk+1) ) + + ! up & down beta terms + zbt = e1e2t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / p2dt + zbetup(ji,jj,jk) = ( zup - paft(ji,jj,jk) ) / ( zpos + zrtrn ) * zbt + zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zdo ) / ( zneg + zrtrn ) * zbt + END DO ; END DO + END DO + IF (nn_hls==1) CALL lbc_lnk( 'traadv_fct', zbetup, 'T', 1.0_dp , zbetdo, 'T', 1.0_dp, ld4only= .TRUE. ) ! lateral boundary cond. (unchanged sign) + + ! 3. monotonic flux in the i & j direction (paa & pbb) + ! ---------------------------------------- + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) + zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) + zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) + zcu = ( 0.5 + SIGN( 0.5_wp , paa(ji,jj,jk) ) ) + paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) + + zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) + zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) + zcv = ( 0.5 + SIGN( 0.5_wp , pbb(ji,jj,jk) ) ) + pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) + + ! monotonic flux in the k direction, i.e. pcc + ! ------------------------------------------- + za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) + zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) + zc = ( 0.5 + SIGN( 0.5_wp , pcc(ji,jj,jk+1) ) ) + pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) + END DO ; END DO ; END DO + ! + END SUBROUTINE nonosc + + + SUBROUTINE interp_4th_cpt_org( pt_in, pt_out ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp_4th_cpt_org *** + !! + !! ** Purpose : Compute the interpolation of tracer at w-point + !! + !! ** Method : 4th order compact interpolation + !!---------------------------------------------------------------------- + REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt_in ! now tracer fields + REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT( out) :: pt_out ! now tracer field interpolated at w-pts + ! + INTEGER :: ji, jj, jk ! dummy loop integers + REAL(wp),DIMENSION(jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt + !!---------------------------------------------------------------------- + + DO jk = 3, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) !== build the three diagonal matrix ==! + zwd (ji,jj,jk) = 4._wp + zwi (ji,jj,jk) = 1._wp + zws (ji,jj,jk) = 1._wp + zwrm(ji,jj,jk) = 3._wp * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) + ! + IF( tmask(ji,jj,jk+1) == 0._wp) THEN ! Switch to second order centered at bottom + zwd (ji,jj,jk) = 1._wp + zwi (ji,jj,jk) = 0._wp + zws (ji,jj,jk) = 0._wp + zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) + ENDIF + END DO ; END DO ; END DO + ! + jk = 2 ! Switch to second order centered at top + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + zwd (ji,jj,jk) = 1._wp + zwi (ji,jj,jk) = 0._wp + zws (ji,jj,jk) = 0._wp + zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) + END DO ; END DO + ! + ! !== tridiagonal solve ==! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) ! first recurrence + zwt(ji,jj,2) = zwd(ji,jj,2) + END DO ; END DO + DO jk = 3, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + pt_out(ji,jj,2) = zwrm(ji,jj,2) + END DO ; END DO + DO jk = 3, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) + END DO ; END DO ; END DO + + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk + pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) + END DO ; END DO + DO jk = jpk-2, 2, -1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) + END DO ; END DO ; END DO + ! + END SUBROUTINE interp_4th_cpt_org + + + SUBROUTINE interp_4th_cpt( pt_in, pt_out ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp_4th_cpt *** + !! + !! ** Purpose : Compute the interpolation of tracer at w-point + !! + !! ** Method : 4th order compact interpolation + !!---------------------------------------------------------------------- + REAL(dp),DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt_in ! field at t-point + REAL(wp),DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) ,jpk), INTENT( out) :: pt_out ! field interpolated at w-point + ! + INTEGER :: ji, jj, jk ! dummy loop integers + INTEGER :: ikt, ikb ! local integers + REAL(wp),DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwd, zwi, zws, zwrm, zwt + !!---------------------------------------------------------------------- + ! + ! !== build the three diagonal matrix & the RHS ==! + ! + DO jk = 3, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! interior (from jk=3 to jpk-1) + zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp ! diagonal + zwi (ji,jj,jk) = wmask(ji,jj,jk) ! lower diagonal + zws (ji,jj,jk) = wmask(ji,jj,jk) ! upper diagonal + zwrm(ji,jj,jk) = 3._wp * wmask(ji,jj,jk) & ! RHS + & * ( pt_in(ji,jj,jk) + pt_in(ji,jj,jk-1) ) + END DO ; END DO ; END DO + ! +!!gm +! SELECT CASE( kbc ) !* boundary condition +! CASE( np_NH ) ! Neumann homogeneous at top & bottom +! CASE( np_CEN2 ) ! 2nd order centered at top & bottom +! END SELECT +!!gm + ! + IF ( ln_isfcav ) THEN ! set level two values which may not be set in ISF case + zwd(:,:,2) = 1._wp ; zwi(:,:,2) = 0._wp ; zws(:,:,2) = 0._wp ; zwrm(:,:,2) = 0._wp + END IF + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! 2nd order centered at top & bottom + ikt = mikt(ji,jj) + 1 ! w-point below the 1st wet point + ikb = MAX(mbkt(ji,jj), 2) ! - above the last wet point + ! + zwd (ji,jj,ikt) = 1._wp ! top + zwi (ji,jj,ikt) = 0._wp + zws (ji,jj,ikt) = 0._wp + zwrm(ji,jj,ikt) = 0.5_wp * ( pt_in(ji,jj,ikt-1) + pt_in(ji,jj,ikt) ) + ! + zwd (ji,jj,ikb) = 1._wp ! bottom + zwi (ji,jj,ikb) = 0._wp + zws (ji,jj,ikb) = 0._wp + zwrm(ji,jj,ikb) = 0.5_wp * ( pt_in(ji,jj,ikb-1) + pt_in(ji,jj,ikb) ) + END DO ; END DO + ! + ! !== tridiagonal solver ==! + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 + zwt(ji,jj,2) = zwd(ji,jj,2) + END DO ; END DO + DO jk = 3, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + pt_out(ji,jj,2) = zwrm(ji,jj,2) + END DO ; END DO + DO jk = 3, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) + END DO ; END DO ; END DO + + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk + pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) + END DO ; END DO + DO jk = jpk-2, 2, -1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) + END DO ; END DO ; END DO + ! + END SUBROUTINE interp_4th_cpt + + + SUBROUTINE tridia_solver( pD, pU, pL, pRHS, pt_out , klev ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tridia_solver *** + !! + !! ** Purpose : solve a symmetric 3diagonal system + !! + !! ** Method : solve M.t_out = RHS(t) where M is a tri diagonal matrix ( jpk*jpk ) + !! + !! ( D_1 U_1 0 0 0 )( t_1 ) ( RHS_1 ) + !! ( L_2 D_2 U_2 0 0 )( t_2 ) ( RHS_2 ) + !! ( 0 L_3 D_3 U_3 0 )( t_3 ) = ( RHS_3 ) + !! ( ... )( ... ) ( ... ) + !! ( 0 0 0 L_k D_k )( t_k ) ( RHS_k ) + !! + !! M is decomposed in the product of an upper and lower triangular matrix. + !! The tri-diagonals matrix is given as input 3D arrays: pD, pU, pL + !! (i.e. the Diagonal, the Upper diagonal, and the Lower diagonal). + !! The solution is pta. + !! The 3d array zwt is used as a work space array. + !!---------------------------------------------------------------------- + REAL(wp),DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in ) :: pD, pU, pL ! 3-diagonal matrix + REAL(wp),DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in ) :: pRHS ! Right-Hand-Side + REAL(wp),DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT( out) :: pt_out !!gm field at level=F(klev) + INTEGER , INTENT(in ) :: klev ! =1 pt_out at w-level + ! ! =0 pt at t-level + INTEGER :: ji, jj, jk ! dummy loop integers + INTEGER :: kstart ! local indices + REAL(wp),DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwt ! 3D work array + !!---------------------------------------------------------------------- + ! + kstart = 1 + klev + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 + zwt(ji,jj,kstart) = pD(ji,jj,kstart) + END DO ; END DO + DO jk = kstart+1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) + END DO ; END DO + DO jk = kstart+1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) + END DO ; END DO ; END DO + + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk + pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) + END DO ; END DO + DO jk = jpk-2, kstart, -1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) + END DO ; END DO ; END DO + ! + END SUBROUTINE tridia_solver + + !!====================================================================== +END MODULE traadv_fct diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_mus.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_mus.f90 new file mode 100644 index 0000000000000000000000000000000000000000..bbb42fd902b1c298a85ede4ccc2f2e376bc9505b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_mus.f90 @@ -0,0 +1,273 @@ + + + + + + + + + + + + + +MODULE traadv_mus + !!====================================================================== + !! *** MODULE traadv_mus *** + !! Ocean tracers: horizontal & vertical advective trend + !!====================================================================== + !! History : ! 2000-06 (A.Estublier) for passive tracers + !! ! 2001-08 (E.Durand, G.Madec) adapted for T & S + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.2 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !! 3.4 ! 2012-06 (P. Oddo, M. Vichi) include the upstream where needed + !! 3.7 ! 2015-09 (G. Madec) add the ice-shelf cavities boundary condition + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_mus : update the tracer trend with the horizontal + !! and vertical advection trends using MUSCL scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE trc_oce ! share passive tracers/Ocean variables + USE dom_oce ! ocean space and time domain + USE trd_oce ! trends: ocean variables + USE trdtra ! tracers trends manager + USE sbcrnf ! river runoffs + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + + ! + USE iom ! XIOS library + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_mus ! routine called by traadv.F90 + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits + ! ! and in closed seas (orca 2 and 1 configurations) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xind !: mixed upstream/centered index + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat/salt transport + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_mus.F90 15139 2021-07-23 12:52:21Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_mus( kt, kit000, cdtype, p2dt, pU, pV, pW, & + & Kbb, Kmm, pt, kjpt, Krhs, ld_msc_ups ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_mus *** + !! + !! ** Purpose : Compute the now trend due to total advection of tracers + !! using a MUSCL scheme (Monotone Upstream-centered Scheme for + !! Conservation Laws) and add it to the general tracer trend. + !! + !! ** Method : MUSCL scheme plus centered scheme at ocean boundaries + !! ld_msc_ups=T : + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !! + !! References : Estubier, A., and M. Levy, Notes Techn. Pole de Modelisation + !! IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + LOGICAL , INTENT(in ) :: ld_msc_ups ! use upstream scheme within muscl + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zu, z0u, zzwx, zw , zalpha ! local scalars + REAL(wp) :: zv, z0v, zzwy, z0w ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwx, zslpx ! 3D workspace + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwy, zslpy ! - - + !!---------------------------------------------------------------------- + ! + 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,*) 'tra_adv : MUSCL advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) ' : mixed up-stream ', ld_msc_ups + IF(lwp) WRITE(numout,*) '~~~~~~~' + IF(lwp) WRITE(numout,*) + ! + ! Upstream / MUSCL scheme indicator + ! + ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) + xind(:,:,:) = 1._wp ! set equal to 1 where up-stream is not needed + ! + IF( ld_msc_ups ) THEN ! define the upstream indicator (if asked) + ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) + upsmsk(:,:) = 0._wp ! not upstream by default + ! + DO jk = 1, jpkm1 + xind(:,:,jk) = 1._wp & ! =>1 where up-stream is not needed + & - MAX ( rnfmsk(:,:) * rnfmsk_z(jk), & ! =>0 near runoff mouths (& closed sea outflows) + & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 in some user defined area + END DO + ENDIF + ! + ENDIF + ! + l_trd = .FALSE. + l_hst = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + DO jn = 1, kjpt !== loop over the tracers ==! + ! + ! !* Horizontal advective fluxes + ! + ! !-- first guess of the slopes + zwx(:,:,jpk) = 0._wp ! bottom values + zwy(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + END DO ; END DO ; END DO + ! !-- Slopes of tracer + zslpx(:,:,jpk) = 0._wp ! bottom values + zslpy(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) & + & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) ) + zslpy(ji,jj,jk) = ( zwy(ji,jj,jk) + zwy(ji ,jj-1,jk) ) & + & * ( 0.25 + SIGN( 0.25_wp, zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) ) + END DO ; END DO ; END DO + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !-- Slopes limitation + zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & + & 2.*ABS( zwx (ji-1,jj,jk) ), & + & 2.*ABS( zwx (ji ,jj,jk) ) ) + zslpy(ji,jj,jk) = SIGN( 1.0_wp, zslpy(ji,jj,jk) ) * MIN( ABS( zslpy(ji,jj ,jk) ), & + & 2.*ABS( zwy (ji,jj-1,jk) ), & + & 2.*ABS( zwy (ji,jj ,jk) ) ) + END DO ; END DO ; END DO + ! NOTE [ comm_cleanup ] : need to change sign to ensure halo 1 - halo 2 compatibility + IF ( nn_hls==1 ) CALL lbc_lnk( 'traadv_mus', zslpx, 'T', -1.0_wp , zslpy, 'T', -1.0_wp ) ! lateral boundary conditions (changed sign) + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) !-- MUSCL horizontal advective fluxes + ! MUSCL fluxes + z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) + zalpha = 0.5 - z0u + zu = z0u - 0.5 * pU(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + zzwx = pt(ji+1,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) + zzwy = pt(ji ,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji ,jj,jk) + zwx(ji,jj,jk) = pU(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) + ! + z0v = SIGN( 0.5_wp, pV(ji,jj,jk) ) + zalpha = 0.5 - z0v + zv = z0v - 0.5 * pV(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + zzwx = pt(ji,jj+1,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) + zzwy = pt(ji,jj ,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj ,jk) + zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) + END DO ; END DO ; END DO + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !-- Tracer advective trend + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! ! trend diagnostics + IF( l_trd ) THEN + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kbb) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kbb) ) + END IF + ! ! "Poleward" heat and salt transports + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) + ! ! heat transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) ) + ! + ! !* Vertical advective fluxes + ! + ! !-- first guess of the slopes + zwx(:,:, 1 ) = 0._wp ! surface & bottom boundary conditions + zwx(:,:,jpk) = 0._wp + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! interior values + zwx(ji,jj,jk) = tmask(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + END DO ; END DO ; END DO + ! !-- Slopes of tracer + zslpx(:,:,1) = 0._wp ! surface values + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) & + & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) + END DO ; END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !-- Slopes limitation + zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), & + & 2.*ABS( zwx (ji,jj,jk+1) ), & + & 2.*ABS( zwx (ji,jj,jk ) ) ) + END DO ; END DO ; END DO + DO jk = 1, jpk-2 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !-- vertical advective flux + z0w = SIGN( 0.5_wp, pW(ji,jj,jk+1) ) + zalpha = 0.5 + z0w + zw = z0w - 0.5 * pW(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / (e3w_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) + zzwx = pt(ji,jj,jk+1,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) + zzwy = pt(ji,jj,jk ,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk ) + zwx(ji,jj,jk+1) = pW(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + IF( ln_linssh ) THEN ! top values, linear free surface only + IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zwx(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) + END DO ; END DO + ELSE ! no cavities: only at the ocean surface + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zwx(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) + END DO ; END DO + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !-- vertical advective trend + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! ! send trends for diagnostic + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwx, pW, pt(:,:,:,jn,Kbb) ) + ! + END DO ! end of tracer loop + ! + END SUBROUTINE tra_adv_mus + + !!====================================================================== +END MODULE traadv_mus diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_qck.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_qck.f90 new file mode 100644 index 0000000000000000000000000000000000000000..766a71c8eab390ea02f9915e81fad37c114f5005 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_qck.f90 @@ -0,0 +1,428 @@ + + + + + + + + + + + + + +MODULE traadv_qck + !!============================================================================== + !! *** MODULE traadv_qck *** + !! Ocean tracers: horizontal & vertical advective trend + !!============================================================================== + !! History : 3.0 ! 2008-07 (G. Reffray) Original code + !! 3.3 ! 2010-05 (C.Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_qck : update the tracer trend with the horizontal advection + !! trends using a 3rd order finite difference scheme + !! tra_adv_qck_i : apply QUICK scheme in i-direction + !! tra_adv_qck_j : apply QUICK scheme in j-direction + !! tra_adv_cen2_k : 2nd centered scheme for the vertical advection + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE trc_oce ! share passive tracers/Ocean variables + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE iom + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_qck ! routine called by step.F90 + + REAL(wp) :: r1_6 = 1./ 6. ! 1/6 ratio + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_qck.F90 14978 2021-06-11 13:21:08Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_qck ( kt, kit000, cdtype, p2dt, pU, pV, pW, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_qck *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The advection is evaluated by a third order scheme + !! For a positive velocity u : u(i)>0 + !! |--FU--|--FC--|--FD--|------| + !! i-1 i i+1 i+2 + !! + !! For a negative velocity u : u(i)<0 + !! |------|--FD--|--FC--|--FU--| + !! i-1 i i+1 i+2 + !! where FU is the second upwind point + !! FD is the first douwning point + !! FC is the central point (or the first upwind point) + !! + !! Flux(i) = u(i) * { 0.5(FC+FD) -0.5C(i)(FD-FC) -((1-C(i))/6)(FU+FD-2FC) } + !! with C(i)=|u(i)|dx(i)/dt (=Courant number) + !! + !! dt = 2*rdtra and the scalar values are tb and sb + !! + !! On the vertical, the simple centered scheme used pt(:,:,:,:,Kmm) + !! + !! The fluxes are bounded by the ULTIMATE limiter to + !! guarantee the monotonicity of the solution and to + !! prevent the appearance of spurious numerical oscillations + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !! + !! ** Reference : Leonard (1979, 1991) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + !!---------------------------------------------------------------------- + ! + 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,*) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) + ENDIF + ! + l_trd = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + ENDIF + ! + ! ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme + CALL tra_adv_qck_i( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) + CALL tra_adv_qck_j( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) + + ! ! vertical fluxes are computed with the 2nd order centered scheme + CALL tra_adv_cen2_k( kt, cdtype, pW, Kmm, pt, kjpt, Krhs ) + ! + END SUBROUTINE tra_adv_qck + + + SUBROUTINE tra_adv_qck_i( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU ! i-velocity components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwx, zfu, zfc, zfd + !---------------------------------------------------------------------- + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + zfu(:,:,:) = 0._wp ; zfc(:,:,:) = 0._wp + zfd(:,:,:) = 0._wp ; zwx(:,:,:) = 0._wp + ! +!!gm why not using a SHIFT instruction... + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !--- Computation of the ustream and downstream value of the tracer and the mask + zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb) ! Upstream in the x-direction for the tracer + zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer + END DO ; END DO ; END DO + IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, ld4only= .TRUE. ) ! Lateral boundary conditions + + ! + ! Horizontal advective fluxes + ! --------------------------- + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( nn_hls-1), ntei+( 0) + zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk) ! FU in the x-direction for T + END DO ; END DO ; END DO + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( nn_hls-1), ntei+( 0) + zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + zwx(ji,jj,jk) = ABS( pU(ji,jj,jk) ) * p2dt / zdx ! (0 0 : zdir = 1 otherwise zdir = 0 + !--- If the second ustream point is a land point + !--- the flux is computed by the 1st order UPWIND scheme + zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) + zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) + zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! Computation of the trend + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zbtr = r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + ! horizontal advective trends + ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) + !--- add it to the general tracer trends + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra + END DO ; END DO ; END DO + ! ! trend diagnostics + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) ) + ! + END DO + ! + END SUBROUTINE tra_adv_qck_i + + + SUBROUTINE tra_adv_qck_j( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pV ! j-velocity components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace + !---------------------------------------------------------------------- + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + zfu(:,:,:) = 0.0 ; zfc(:,:,:) = 0.0 + zfd(:,:,:) = 0.0 ; zwy(:,:,:) = 0.0 + ! + !--- Computation of the ustream and downstream value of the tracer and the mask + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( 0), ntei+( 0) + ! Upstream in the x-direction for the tracer + zfc(ji,jj,jk) = pt(ji,jj-1,jk,jn,Kbb) + ! Downstream in the x-direction for the tracer + zfd(ji,jj,jk) = pt(ji,jj+1,jk,jn,Kbb) + END DO ; END DO ; END DO + + IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, ld4only= .TRUE. ) ! Lateral boundary conditions + + ! Correct zfd on northfold after lbc_lnk; see #2640 + IF( nn_hls == 1 .AND. l_IdoNFold .AND. ntej == Nje0 ) THEN + DO jk = 1, jpkm1 + WHERE( tmask_i(ntsi:ntei,ntej:jpj) == 0._wp ) zfd(ntsi:ntei,ntej:jpj,jk) = zfc(ntsi:ntei,ntej:jpj,jk) + END DO + ENDIF + ! + ! Horizontal advective fluxes + ! --------------------------- + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk) ! FU in the x-direction for T + END DO ; END DO ; END DO + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + zwy(ji,jj,jk) = ABS( pV(ji,jj,jk) ) * p2dt / zdx ! (0 0 : zdir = 1 otherwise zdir = 0 + !--- If the second ustream point is a land point + !--- the flux is computed by the 1st order UPWIND scheme + zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) + zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) + zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! Computation of the trend + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zbtr = r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + ! horizontal advective trends + ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) + !--- add it to the general tracer trends + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra + END DO ; END DO ; END DO + ! ! trend diagnostics + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) ) + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) + ! + END DO + ! + END SUBROUTINE tra_adv_qck_j + + + SUBROUTINE tra_adv_cen2_k( kt, cdtype, pW, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwz ! 3D workspace + !!---------------------------------------------------------------------- + ! + zwz(:,:, 1 ) = 0._wp ! surface & bottom values set to zero for all tracers + zwz(:,:,jpk) = 0._wp + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !* Interior point (w-masked 2nd order centered flux) + zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kmm) + pt(ji,jj,jk,jn,Kmm) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + IF( ln_linssh ) THEN !* top value (only in linear free surf. as zwz is multiplied by wmask) + IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) ! linear free surface + END DO ; END DO + ELSE ! no ocean cavities (only ocean surface) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) + END DO ; END DO + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !== Tracer flux divergence added to the general trend ==! + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! ! Send trends for diagnostic + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) + ! + END DO + ! + END SUBROUTINE tra_adv_cen2_k + + + SUBROUTINE quickest( pfu, pfd, pfc, puc ) + !!---------------------------------------------------------------------- + !! + !! ** Purpose : Computation of advective flux with Quickest scheme + !! + !! ** Method : + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point) + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef1, zcoef2, zcoef3 ! local scalars + REAL(wp) :: zc, zcurv, zfho ! - - + !---------------------------------------------------------------------- + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) + zc = puc(ji,jj,jk) ! Courant number + zcurv = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) + zcoef1 = 0.5 * ( pfc(ji,jj,jk) + pfd(ji,jj,jk) ) + zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) + zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv + zfho = zcoef1 - zcoef2 - zcoef3 ! phi_f QUICKEST + ! + zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) + zcoef2 = ABS( zcoef1 ) + zcoef3 = ABS( zcurv ) + IF( zcoef3 >= zcoef2 ) THEN + zfho = pfc(ji,jj,jk) + ELSE + zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) ) ! phi_REF + IF( zcoef1 >= 0. ) THEN + zfho = MAX( pfc(ji,jj,jk), zfho ) + zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) ) + ELSE + zfho = MIN( pfc(ji,jj,jk), zfho ) + zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) ) + ENDIF + ENDIF + puc(ji,jj,jk) = zfho + END DO ; END DO ; END DO + ! + END SUBROUTINE quickest + + !!====================================================================== +END MODULE traadv_qck diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_qck_lf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_qck_lf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1d587266b8b707014d7d414cce4c63a80476bdb5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_qck_lf.f90 @@ -0,0 +1,403 @@ + + + + + + + + + + + + + +MODULE traadv_qck_lf + !!============================================================================== + !! *** MODULE traadv_qck *** + !! Ocean tracers: horizontal & vertical advective trend + !!============================================================================== + !! History : 3.0 ! 2008-07 (G. Reffray) Original code + !! 3.3 ! 2010-05 (C.Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_qck : update the tracer trend with the horizontal advection + !! trends using a 3rd order finite difference scheme + !! tra_adv_qck_i : apply QUICK scheme in i-direction + !! tra_adv_qck_j : apply QUICK scheme in j-direction + !! tra_adv_cen2_k : 2nd centered scheme for the vertical advection + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE trc_oce ! share passive tracers/Ocean variables + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE iom + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_qck_lf ! routine called by step.F90 + + REAL(wp) :: r1_6 = 1./ 6. ! 1/6 ratio + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + + + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_qck.F90 14776 2021-04-30 12:33:41Z mocavero $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_qck_lf ( kt, kit000, cdtype, p2dt, pU, pV, pW, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_qck *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The advection is evaluated by a third order scheme + !! For a positive velocity u : u(i)>0 + !! |--FU--|--FC--|--FD--|------| + !! i-1 i i+1 i+2 + !! + !! For a negative velocity u : u(i)<0 + !! |------|--FD--|--FC--|--FU--| + !! i-1 i i+1 i+2 + !! where FU is the second upwind point + !! FD is the first douwning point + !! FC is the central point (or the first upwind point) + !! + !! Flux(i) = u(i) * { 0.5(FC+FD) -0.5C(i)(FD-FC) -((1-C(i))/6)(FU+FD-2FC) } + !! with C(i)=|u(i)|dx(i)/dt (=Courant number) + !! + !! dt = 2*rdtra and the scalar values are tb and sb + !! + !! On the vertical, the simple centered scheme used pt(:,:,:,:,Kmm) + !! + !! The fluxes are bounded by the ULTIMATE limiter to + !! guarantee the monotonicity of the solution and to + !! prevent the appearance of spurious numerical oscillations + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !! + !! ** Reference : Leonard (1979, 1991) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + !!---------------------------------------------------------------------- + ! + IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) + ENDIF + ! + l_trd = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + ENDIF + ! + ! ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme + CALL tra_adv_qck_i_lf( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) + CALL tra_adv_qck_j_lf( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) + + ! ! vertical fluxes are computed with the 2nd order centered scheme + CALL tra_adv_cen2_k_lf( kt, cdtype, pW, Kmm, pt, kjpt, Krhs ) + ! + END SUBROUTINE tra_adv_qck_lf + + + SUBROUTINE tra_adv_qck_i_lf( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU ! i-velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp) :: zzfc, zzfd, zzfu, zzfu_ip1 ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwx, zfu, zfc, zfd + !---------------------------------------------------------------------- + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + zfu(:,:,:) = 0._wp ; zfc(:,:,:) = 0._wp + zfd(:,:,:) = 0._wp ; zwx(:,:,:) = 0._wp + ! +!!gm why not using a SHIFT instruction... + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) !--- Computation of the ustream and downstream value of the tracer and the mask + zzfc = pt(ji-1,jj,jk,jn,Kbb) ! Upstream in the x-direction for the tracer + zzfd = pt(ji+2,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer + ! + ! Horizontal advective fluxes + ! --------------------------- + zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zfu(ji,jj,jk) = zdir * zzfc + ( 1. - zdir ) * zzfd ! FU in the x-direction for T + ! + zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + zwx(ji,jj,jk) = ABS( pU(ji,jj,jk) ) * p2dt / zdx ! (0 0 : zdir = 1 otherwise zdir = 0 + !--- If the second ustream point is a land point + !--- the flux is computed by the 1st order UPWIND scheme + zmsk = zdir * zzfu + ( 1. - zdir ) * zzfu_ip1 + zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) + zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! Computation of the trend + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zbtr = r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + ! horizontal advective trends + ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) + !--- add it to the general tracer trends + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra + END DO ; END DO ; END DO + ! ! trend diagnostics + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, REAL(pt(:,:,:,jn,Kmm),dp) ) + ! + END DO + ! + END SUBROUTINE tra_adv_qck_i_lf + + + SUBROUTINE tra_adv_qck_j_lf( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pV ! j-velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp) :: zzfc, zzfd, zzfu, zzfu_jp1 ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace + !---------------------------------------------------------------------- + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + zfu(:,:,:) = 0.0 ; zfc(:,:,:) = 0.0 + zfd(:,:,:) = 0.0 ; zwy(:,:,:) = 0.0 + ! + !--- Computation of the ustream and downstream value of the tracer and the mask + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ! Upstream in the x-direction for the tracer + zzfc = pt(ji,jj-1,jk,jn,Kbb) + ! Downstream in the x-direction for the tracer + zzfd = pt(ji,jj+2,jk,jn,Kbb) + ! + ! Horizontal advective fluxes + ! --------------------------- + ! + zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zfu(ji,jj,jk) = zdir * zzfc + ( 1. - zdir ) * zzfd ! FU in the x-direction for T + ! + zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + zwy(ji,jj,jk) = ABS( pV(ji,jj,jk) ) * p2dt / zdx ! (0 0 : zdir = 1 otherwise zdir = 0 + !--- If the second ustream point is a land point + !--- the flux is computed by the 1st order UPWIND scheme + zmsk = zdir * zzfu + ( 1. - zdir ) * zzfu_jp1 + zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) + zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! Computation of the trend + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zbtr = r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + ! horizontal advective trends + ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) + !--- add it to the general tracer trends + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra + END DO ; END DO ; END DO + ! ! trend diagnostics + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, REAL(pt(:,:,:,jn,Kmm),dp) ) + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) + ! + END DO + ! + END SUBROUTINE tra_adv_qck_j_lf + + + SUBROUTINE tra_adv_cen2_k_lf( kt, cdtype, pW, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwz ! 3D workspace + !!---------------------------------------------------------------------- + ! + zwz(:,:, 1 ) = 0._wp ! surface & bottom values set to zero for all tracers + zwz(:,:,jpk) = 0._wp + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !* Interior point (w-masked 2nd order centered flux) + zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kmm) + pt(ji,jj,jk,jn,Kmm) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + IF( ln_linssh ) THEN !* top value (only in linear free surf. as zwz is multiplied by wmask) + IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) ! linear free surface + END DO ; END DO + ELSE ! no ocean cavities (only ocean surface) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) + END DO ; END DO + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !== Tracer flux divergence added to the general trend ==! + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! ! Send trends for diagnostic + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, REAL(pt(:,:,:,jn,Kmm),dp) ) + ! + END DO + ! + END SUBROUTINE tra_adv_cen2_k_lf + + + SUBROUTINE quickest( pfu, pfd, pfc, puc ) + !!---------------------------------------------------------------------- + !! + !! ** Purpose : Computation of advective flux with Quickest scheme + !! + !! ** Method : + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point) + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef1, zcoef2, zcoef3 ! local scalars + REAL(wp) :: zc, zcurv, zfho ! - - + !---------------------------------------------------------------------- + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 2), ntej+( 2) ; DO ji = ntsi-( 2), ntei+( 2) + zc = puc(ji,jj,jk) ! Courant number + zcurv = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) + zcoef1 = 0.5 * ( pfc(ji,jj,jk) + pfd(ji,jj,jk) ) + zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) + zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv + zfho = zcoef1 - zcoef2 - zcoef3 ! phi_f QUICKEST + ! + zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) + zcoef2 = ABS( zcoef1 ) + zcoef3 = ABS( zcurv ) + IF( zcoef3 >= zcoef2 ) THEN + zfho = pfc(ji,jj,jk) + ELSE + zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) ) ! phi_REF + IF( zcoef1 >= 0. ) THEN + zfho = MAX( pfc(ji,jj,jk), zfho ) + zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) ) + ELSE + zfho = MIN( pfc(ji,jj,jk), zfho ) + zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) ) + ENDIF + ENDIF + puc(ji,jj,jk) = zfho + END DO ; END DO ; END DO + ! + END SUBROUTINE quickest + + !!====================================================================== +END MODULE traadv_qck_lf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_ubs.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_ubs.f90 new file mode 100644 index 0000000000000000000000000000000000000000..08c9c0e913347636367707f689a2bc1d1f593671 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_ubs.f90 @@ -0,0 +1,382 @@ + + + + + + + + + + + + + +MODULE traadv_ubs + !!============================================================================== + !! *** MODULE traadv_ubs *** + !! Ocean active tracers: horizontal & vertical advective trend + !!============================================================================== + !! History : 1.0 ! 2006-08 (L. Debreu, R. Benshila) Original code + !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_ubs : update the tracer trend with the horizontal + !! advection trends using a third order biaised scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE trc_oce ! share passive tracers/Ocean variables + USE trd_oce ! trends: ocean variables + USE traadv_fct ! acces to routine interp_4th_cpt + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + ! + USE iom ! I/O library + USE in_out_manager ! I/O manager + USE lib_mpp ! massively parallel library + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_ubs ! routine called by traadv module + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat transport + + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_ubs.F90 14922 2021-05-28 13:25:33Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_ubs( kt, kit000, cdtype, p2dt, pU, pV, pW, & + & Kbb, Kmm, pt, kjpt, Krhs, kn_ubs_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_ubs *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The 3rd order Upstream Biased Scheme (UBS) is based on an + !! upstream-biased parabolic interpolation (Shchepetkin and McWilliams 2005) + !! It is only used in the horizontal direction. + !! For example the i-component of the advective fluxes are given by : + !! ! e2u e3u un ( mi(Tn) - zltu(i ) ) if un(i) >= 0 + !! ztu = ! or + !! ! e2u e3u un ( mi(Tn) - zltu(i+1) ) if un(i) < 0 + !! where zltu is the second derivative of the before temperature field: + !! zltu = 1/e3t di[ e2u e3u / e1u di[Tb] ] + !! This results in a dissipatively dominant (i.e. hyper-diffusive) + !! truncation error. The overall performance of the advection scheme + !! is similar to that reported in (Farrow and Stevens, 1995). + !! For stability reasons, the first term of the fluxes which corresponds + !! to a second order centered scheme is evaluated using the now velocity + !! (centered in time) while the second term which is the diffusive part + !! of the scheme, is evaluated using the before velocity (forward in time). + !! Note that UBS is not positive. Do not use it on passive tracers. + !! On the vertical, the advection is evaluated using a FCT scheme, + !! as the UBS have been found to be too diffusive. + !! kn_ubs_v argument controles whether the FCT is based on + !! a 2nd order centrered scheme (kn_ubs_v=2) or on a 4th order compact + !! scheme (kn_ubs_v=4). + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !! + !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404. + !! Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731�1741. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kn_ubs_v ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zcoef ! local scalars + REAL(wp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - + REAL(wp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace + !!---------------------------------------------------------------------- + ! + 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,*) 'tra_adv_ubs : horizontal UBS advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + l_trd = .FALSE. + l_hst = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + ztw (:,:, 1 ) = 0._wp ! surface & bottom value : set to zero for all tracers + zltu(:,:,jpk) = 0._wp ; zltv(:,:,jpk) = 0._wp + ztw (:,:,jpk) = 0._wp ; zti (:,:,jpk) = 0._wp + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! + DO jk = 1, jpkm1 !== horizontal laplacian of before tracer ==! + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) ! First derivative (masked gradient) + zeeu = e2_e1u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) * umask(ji,jj,jk) + zeev = e1_e2v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) * vmask(ji,jj,jk) + ztu(ji,jj,jk) = zeeu * ( pt(ji+1,jj ,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + ztv(ji,jj,jk) = zeev * ( pt(ji ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + END DO ; END DO + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! Second derivative (divergence) + zcoef = 1._wp / ( 6._wp * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) ) + zltu(ji,jj,jk) = ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zcoef + zltv(ji,jj,jk) = ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) * zcoef + END DO ; END DO + ! + END DO + IF (nn_hls==1) CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp, zltv, 'T', 1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) !== Horizontal advective fluxes ==! (UBS) + zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2) + zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) + zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) + zfm_vj = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) + ! ! 2nd order centered advective fluxes (x2) + zcenut = pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ) + zcenvt = pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) ) + ! ! UBS advective fluxes + ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) ) + ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) ) + END DO ; END DO ; END DO + ! + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store the initial trends before its update + END DO ; END DO ; END DO + ! + DO jk = 1, jpkm1 !== add the horizontal advective trend ==! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & + & - ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk) & + & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO + ! + END DO + ! + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltu(ji,jj,jk) ! Horizontal advective trend used in vertical 2nd order FCT case + END DO ; END DO ; END DO ! and/or in trend diagnostic (l_trd=T) + ! + IF( l_trd ) THEN ! trend diagnostics + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztv, pV, pt(:,:,:,jn,Kmm) ) + END IF + ! + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', ztv(:,:,:) ) + ! ! heati/salt transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztu(:,:,:), ztv(:,:,:) ) + ! + ! + ! !== vertical advective trend ==! + ! + SELECT CASE( kn_ubs_v ) ! select the vertical advection scheme + ! + CASE( 2 ) ! 2nd order FCT + ! + IF( l_trd ) THEN + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag. + END DO ; END DO ; END DO + ENDIF + ! + ! !* upstream advection with initial mass fluxes & intermediate update ==! + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) + zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) + ztw(ji,jj,jk) = 0.5_wp * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as ztw has been w-masked) + IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface + END DO ; END DO + ELSE ! no cavities: only at the ocean surface + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) + END DO ; END DO + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !* trend and after field with monotonic scheme + ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztak + zti(ji,jj,jk) = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! !* anti-diffusive flux : high order minus low order + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ztw(ji,jj,jk) = ( 0.5_wp * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) & + & - ztw(ji,jj,jk) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! ! top ocean value: high order == upstream ==>> zwz=0 + IF( ln_linssh ) ztw(:,:, 1 ) = 0._wp ! only ocean surface as interior zwz values have been w-masked + ! + CALL nonosc_z( Kmm, pt(:,:,:,jn,Kbb), ztw, zti, p2dt ) ! monotonicity algorithm + ! + CASE( 4 ) ! 4th order COMPACT + CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! 4th order compact interpolation of T at w-point + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + IF( ln_linssh ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) !!gm ISF & 4th COMPACT doesn't work + END DO ; END DO + ENDIF + ! + END SELECT + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! final trend with corrected fluxes + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + IF( l_trd ) THEN ! vertical advective trend diagnostics + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) + zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk) & + & + pt(ji,jj,jk,jn,Kmm) * ( pW(ji,jj,jk) - pW(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zltv ) + ENDIF + ! + END DO + ! + END SUBROUTINE tra_adv_ubs + + + SUBROUTINE nonosc_z( Kmm, pbef, pcc, paft, p2dt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE nonosc_z *** + !! + !! ** Purpose : compute monotonic tracer fluxes from the upstream + !! scheme and the before field by a nonoscillatory algorithm + !! + !! ** Method : ... ??? + !! warning : pbef and paft must be masked, but the boundaries + !! conditions on the fluxes are not necessary zalezak (1979) + !! drange (1995) multi-dimensional forward-in-time and upstream- + !! in-space based differencing for fluid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), INTENT(in ) :: p2dt ! tracer time-step + REAL(dp), DIMENSION(jpi,jpj,jpk) :: pbef ! before field + REAL(wp), INTENT(inout), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) ,jpk) :: paft ! after field + REAL(wp), INTENT(inout), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikm1 ! local integer + REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace + !!---------------------------------------------------------------------- + ! + zbig = 1.e+20_wp + zrtrn = 1.e-15_wp + zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp + ! + ! Search local extrema + ! -------------------- + ! ! large negative value (-zbig) inside land + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) + END DO ; END DO ; END DO + ! + DO jk = 1, jpkm1 ! search maximum in neighbourhood + ikm1 = MAX(jk-1,1) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zbetup(ji,jj,jk) = MAX( pbef(ji ,jj ,jk ), paft(ji ,jj ,jk ), & + & pbef(ji ,jj ,ikm1), pbef(ji ,jj ,jk+1), & + & paft(ji ,jj ,ikm1), paft(ji ,jj ,jk+1) ) + END DO ; END DO + END DO + ! ! large positive value (+zbig) inside land + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) + END DO ; END DO ; END DO + ! + DO jk = 1, jpkm1 ! search minimum in neighbourhood + ikm1 = MAX(jk-1,1) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zbetdo(ji,jj,jk) = MIN( pbef(ji ,jj ,jk ), paft(ji ,jj ,jk ), & + & pbef(ji ,jj ,ikm1), pbef(ji ,jj ,jk+1), & + & paft(ji ,jj ,ikm1), paft(ji ,jj ,jk+1) ) + END DO ; END DO + END DO + ! ! restore masked values to zero + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! Positive and negative part of fluxes and beta terms + ! --------------------------------------------------- + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ! positive & negative part of the flux + zpos = MAX( 0., pcc(ji ,jj ,jk+1) ) - MIN( 0., pcc(ji ,jj ,jk ) ) + zneg = MAX( 0., pcc(ji ,jj ,jk ) ) - MIN( 0., pcc(ji ,jj ,jk+1) ) + ! up & down beta terms + zbt = e1e2t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / p2dt + zbetup(ji,jj,jk) = ( zbetup(ji,jj,jk) - paft(ji,jj,jk) ) / (zpos+zrtrn) * zbt + zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zbetdo(ji,jj,jk) ) / (zneg+zrtrn) * zbt + END DO ; END DO ; END DO + ! + ! monotonic flux in the k direction, i.e. pcc + ! ------------------------------------------- + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) ) + zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) ) + zc = 0.5 * ( 1.e0 + SIGN( 1.0_wp, pcc(ji,jj,jk) ) ) + pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb ) + END DO ; END DO ; END DO + ! + END SUBROUTINE nonosc_z + + !!====================================================================== +END MODULE traadv_ubs diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_ubs_lf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_ubs_lf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..82d9a20249094c4cd25d1ea3606633c44a0d9b14 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traadv_ubs_lf.f90 @@ -0,0 +1,395 @@ + + + + + + + + + + + + + +MODULE traadv_ubs_lf + !!============================================================================== + !! *** MODULE traadv_ubs *** + !! Ocean active tracers: horizontal & vertical advective trend + !!============================================================================== + !! History : 1.0 ! 2006-08 (L. Debreu, R. Benshila) Original code + !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_ubs : update the tracer trend with the horizontal + !! advection trends using a third order biaised scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE trc_oce ! share passive tracers/Ocean variables + USE trd_oce ! trends: ocean variables + USE traadv_fct ! acces to routine interp_4th_cpt + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + ! + USE iom ! I/O library + USE in_out_manager ! I/O manager + USE lib_mpp ! massively parallel library + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_ubs_lf ! routine called by traadv module + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat transport + + + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_ubs.F90 14776 2021-04-30 12:33:41Z mocavero $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_ubs_lf( kt, kit000, cdtype, p2dt, pU, pV, pW, & + & Kbb, Kmm, pt, kjpt, Krhs, kn_ubs_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_ubs *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The 3rd order Upstream Biased Scheme (UBS) is based on an + !! upstream-biased parabolic interpolation (Shchepetkin and McWilliams 2005) + !! It is only used in the horizontal direction. + !! For example the i-component of the advective fluxes are given by : + !! ! e2u e3u un ( mi(Tn) - zltu(i ) ) if un(i) >= 0 + !! ztu = ! or + !! ! e2u e3u un ( mi(Tn) - zltu(i+1) ) if un(i) < 0 + !! where zltu is the second derivative of the before temperature field: + !! zltu = 1/e3t di[ e2u e3u / e1u di[Tb] ] + !! This results in a dissipatively dominant (i.e. hyper-diffusive) + !! truncation error. The overall performance of the advection scheme + !! is similar to that reported in (Farrow and Stevens, 1995). + !! For stability reasons, the first term of the fluxes which corresponds + !! to a second order centered scheme is evaluated using the now velocity + !! (centered in time) while the second term which is the diffusive part + !! of the scheme, is evaluated using the before velocity (forward in time). + !! Note that UBS is not positive. Do not use it on passive tracers. + !! On the vertical, the advection is evaluated using a FCT scheme, + !! as the UBS have been found to be too diffusive. + !! kn_ubs_v argument controles whether the FCT is based on + !! a 2nd order centrered scheme (kn_ubs_v=2) or on a 4th order compact + !! scheme (kn_ubs_v=4). + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !! + !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404. + !! Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731�1741. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kn_ubs_v ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zcoef, zcoef_ip1, zcoef_jp1 ! local scalars + REAL(wp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - + REAL(wp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - + REAL(wp) :: zeeu_im1, zeeu_ip1, zeev_jm1, zeev_jp1 + REAL(wp) :: zztu, zztu_im1, zztu_ip1 + REAL(wp) :: zztv, zztv_jm1, zztv_jp1 + REAL(wp) :: zzltu, zzltu_ip1, zzltv, zzltv_jp1 + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv_ubs : horizontal UBS advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + l_trd = .FALSE. + l_hst = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + ztw (:,:, 1 ) = 0._wp ! surface & bottom value : set to zero for all tracers + zltu(:,:,jpk) = 0._wp ; zltv(:,:,jpk) = 0._wp + ztw (:,:,jpk) = 0._wp ; zti (:,:,jpk) = 0._wp + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! !== horizontal laplacian of before tracer ==! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) ! Second derivative (divergence) + ! First derivative (masked gradient) + zeeu_im1 = e2_e1u(ji-1,jj ) * (e3u_0(ji-1,jj ,jk)*(1._wp+r3u(ji-1,jj ,Kmm)*umask(ji-1,jj ,jk))) * umask(ji-1,jj ,jk) + zeeu = e2_e1u(ji ,jj ) * (e3u_0(ji ,jj ,jk)*(1._wp+r3u(ji ,jj ,Kmm)*umask(ji ,jj ,jk))) * umask(ji ,jj ,jk) + zeeu_ip1 = e2_e1u(ji+1,jj ) * (e3u_0(ji+1,jj ,jk)*(1._wp+r3u(ji+1,jj ,Kmm)*umask(ji+1,jj ,jk))) * umask(ji+1,jj ,jk) + zeev_jm1 = e1_e2v(ji ,jj-1) * (e3v_0(ji ,jj-1,jk)*(1._wp+r3v(ji ,jj-1,Kmm)*vmask(ji ,jj-1,jk))) * vmask(ji ,jj-1,jk) + zeev = e1_e2v(ji ,jj ) * (e3v_0(ji ,jj ,jk)*(1._wp+r3v(ji ,jj ,Kmm)*vmask(ji ,jj ,jk))) * vmask(ji ,jj ,jk) + zeev_jp1 = e1_e2v(ji ,jj+1) * (e3v_0(ji ,jj+1,jk)*(1._wp+r3v(ji ,jj+1,Kmm)*vmask(ji ,jj+1,jk))) * vmask(ji ,jj+1,jk) + ! + zztu_im1 = zeeu_im1 * ( pt(ji ,jj,jk,jn,Kbb) - pt(ji-1,jj,jk,jn,Kbb) ) + zztu = zeeu * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji ,jj,jk,jn,Kbb) ) + zztu_ip1 = zeeu_ip1 * ( pt(ji+2,jj,jk,jn,Kbb) - pt(ji+1,jj,jk,jn,Kbb) ) + ! + zztv_jm1 = zeev_jm1 * ( pt(ji,jj ,jk,jn,Kbb) - pt(ji,jj-1,jk,jn,Kbb) ) + zztv = zeev * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj ,jk,jn,Kbb) ) + zztv_jp1 = zeev_jp1 * ( pt(ji,jj+2,jk,jn,Kbb) - pt(ji,jj+1,jk,jn,Kbb) ) + ! Second derivative (divergence) + zcoef = 1._wp / ( 6._wp * (e3t_0(ji ,jj ,jk)*(1._wp+r3t(ji ,jj ,Kmm)*tmask(ji ,jj ,jk))) ) + zcoef_ip1 = 1._wp / ( 6._wp * (e3t_0(ji+1,jj ,jk)*(1._wp+r3t(ji+1,jj ,Kmm)*tmask(ji+1,jj ,jk))) ) + zcoef_jp1 = 1._wp / ( 6._wp * (e3t_0(ji ,jj+1,jk)*(1._wp+r3t(ji ,jj+1,Kmm)*tmask(ji ,jj+1,jk))) ) + ! + zzltu = ( zztu - zztu_im1 ) * zcoef + zzltu_ip1 = ( zztu_ip1 - zztu ) * zcoef_ip1 + zzltv = ( zztv - zztv_jm1 ) * zcoef + zzltv_jp1 = ( zztv_jp1 - zztv ) * zcoef_jp1 + ! + ! !== Horizontal advective fluxes ==! (UBS) + zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2) + zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) + zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) + zfm_vj = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) + ! ! 2nd order centered advective fluxes (x2) + zcenut = pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ) + zcenvt = pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) ) + ! ! UBS advective fluxes + ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zzltu - zfm_ui * zzltu_ip1 ) + ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zzltv - zfm_vj * zzltv_jp1 ) + END DO ; END DO ; END DO + ! + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store the initial trends before its update + END DO ; END DO ; END DO + ! + ! !== add the horizontal advective trend ==! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & + & - ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk) & + & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltu(ji,jj,jk) ! Horizontal advective trend used in vertical 2nd order FCT case + END DO ; END DO ; END DO ! and/or in trend diagnostic (l_trd=T) + ! + IF( l_trd ) THEN ! trend diagnostics + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, REAL(pt(:,:,:,jn,Kmm),dp) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztv, pV, REAL(pt(:,:,:,jn,Kmm),dp) ) + END IF + ! + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', ztv(:,:,:) ) + ! ! heati/salt transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztu(:,:,:), ztv(:,:,:) ) + ! + ! + ! !== vertical advective trend ==! + ! + SELECT CASE( kn_ubs_v ) ! select the vertical advection scheme + ! + CASE( 2 ) ! 2nd order FCT + ! + IF( l_trd ) THEN + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag. + END DO ; END DO ; END DO + ENDIF + ! + ! !* upstream advection with initial mass fluxes & intermediate update ==! + DO jk = 2, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) + zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) + ztw(ji,jj,jk) = 0.5_wp * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as ztw has been w-masked) + IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface + END DO ; END DO + ELSE ! no cavities: only at the ocean surface + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) + END DO ; END DO + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) !* trend and after field with monotonic scheme + ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztak + zti(ji,jj,jk) = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! !* anti-diffusive flux : high order minus low order + DO jk = 2, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + ztw(ji,jj,jk) = ( 0.5_wp * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) & + & - ztw(ji,jj,jk) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! ! top ocean value: high order == upstream ==>> zwz=0 + IF( ln_linssh ) ztw(:,:, 1 ) = 0._wp ! only ocean surface as interior zwz values have been w-masked + ! + CALL nonosc_z( Kmm, pt(:,:,:,jn,Kbb), ztw, zti, p2dt ) ! monotonicity algorithm + ! + CASE( 4 ) ! 4th order COMPACT + CALL interp_4th_cpt( REAL(pt(:,:,:,jn,Kmm),dp) , ztw ) ! 4th order compact interpolation of T at w-point + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + IF( ln_linssh ) THEN + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) !!gm ISF & 4th COMPACT doesn't work + END DO ; END DO + ENDIF + ! + END SELECT + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! final trend with corrected fluxes + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + IF( l_trd ) THEN ! vertical advective trend diagnostics + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) + zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk) & + & + pt(ji,jj,jk,jn,Kmm) * ( pW(ji,jj,jk) - pW(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zltv ) + ENDIF + ! + END DO + ! + END SUBROUTINE tra_adv_ubs_lf + + + SUBROUTINE nonosc_z( Kmm, pbef, pcc, paft, p2dt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE nonosc_z *** + !! + !! ** Purpose : compute monotonic tracer fluxes from the upstream + !! scheme and the before field by a nonoscillatory algorithm + !! + !! ** Method : ... ??? + !! warning : pbef and paft must be masked, but the boundaries + !! conditions on the fluxes are not necessary zalezak (1979) + !! drange (1995) multi-dimensional forward-in-time and upstream- + !! in-space based differencing for fluid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), INTENT(in ) :: p2dt ! tracer time-step + REAL(wp), DIMENSION(jpi,jpj,jpk) :: pbef ! before field + REAL(wp), INTENT(inout), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) ,jpk) :: paft ! after field + REAL(wp), INTENT(inout), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikm1 ! local integer + REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace + !!---------------------------------------------------------------------- + ! + zbig = 1.e+20_wp + zrtrn = 1.e-15_wp + zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp + ! + ! Search local extrema + ! -------------------- + ! ! large negative value (-zbig) inside land + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) + END DO ; END DO ; END DO + ! + DO jk = 1, jpkm1 ! search maximum in neighbourhood + ikm1 = MAX(jk-1,1) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zbetup(ji,jj,jk) = MAX( pbef(ji ,jj ,jk ), paft(ji ,jj ,jk ), & + & pbef(ji ,jj ,ikm1), pbef(ji ,jj ,jk+1), & + & paft(ji ,jj ,ikm1), paft(ji ,jj ,jk+1) ) + END DO ; END DO + END DO + ! ! large positive value (+zbig) inside land + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) + END DO ; END DO ; END DO + ! + DO jk = 1, jpkm1 ! search minimum in neighbourhood + ikm1 = MAX(jk-1,1) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zbetdo(ji,jj,jk) = MIN( pbef(ji ,jj ,jk ), paft(ji ,jj ,jk ), & + & pbef(ji ,jj ,ikm1), pbef(ji ,jj ,jk+1), & + & paft(ji ,jj ,ikm1), paft(ji ,jj ,jk+1) ) + END DO ; END DO + END DO + ! ! restore masked values to zero + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! Positive and negative part of fluxes and beta terms + ! --------------------------------------------------- + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ! positive & negative part of the flux + zpos = MAX( 0., pcc(ji ,jj ,jk+1) ) - MIN( 0., pcc(ji ,jj ,jk ) ) + zneg = MAX( 0., pcc(ji ,jj ,jk ) ) - MIN( 0., pcc(ji ,jj ,jk+1) ) + ! up & down beta terms + zbt = e1e2t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / p2dt + zbetup(ji,jj,jk) = ( zbetup(ji,jj,jk) - paft(ji,jj,jk) ) / (zpos+zrtrn) * zbt + zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zbetdo(ji,jj,jk) ) / (zneg+zrtrn) * zbt + END DO ; END DO ; END DO + ! + ! monotonic flux in the k direction, i.e. pcc + ! ------------------------------------------- + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) ) + zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) ) + zc = 0.5 * ( 1.e0 + SIGN( 1.0_wp, pcc(ji,jj,jk) ) ) + pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb ) + END DO ; END DO ; END DO + ! + END SUBROUTINE nonosc_z + + !!====================================================================== +END MODULE traadv_ubs_lf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traatf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traatf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7e783b6e49426619478d731d2fec49becd651bdf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traatf.f90 @@ -0,0 +1,407 @@ + + + + + + + + + + + + + +MODULE traatf + !!====================================================================== + !! *** MODULE traatf *** + !! Ocean active tracers: Asselin time filtering for temperature and salinity + !!====================================================================== + !! History : OPA ! 1991-11 (G. Madec) Original code + !! 7.0 ! 1993-03 (M. Guyon) symetrical conditions + !! 8.0 ! 1996-02 (G. Madec & M. Imbard) opa release 8.0 + !! - ! 1996-04 (A. Weaver) Euler forward step + !! 8.2 ! 1999-02 (G. Madec, N. Grima) semi-implicit pressure grad. + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2002-11 (C. Talandier, A-M Treguier) Open boundaries + !! - ! 2005-04 (C. Deltel) Add Asselin trend in the ML budget + !! 2.0 ! 2006-02 (L. Debreu, C. Mazauric) Agrif implementation + !! 3.0 ! 2008-06 (G. Madec) time stepping always done in trazdf + !! 3.1 ! 2009-02 (G. Madec, R. Benshila) re-introduce the vvl option + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) semi-implicit hpg with asselin filter + modified LF-RA + !! - ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename tranxt.F90 -> traatf.F90. Now only does time filtering. + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_atf : time filtering on tracers + !! tra_atf_fix : time filtering on tracers : fixed volume case + !! tra_atf_vvl : time filtering on tracers : variable volume case + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! surface boundary condition: ocean + USE sbcrnf ! river runoffs + USE isf_oce ! ice shelf melting + USE zdf_oce ! ocean vertical mixing + USE domvvl ! variable volume + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE traqsr ! penetrative solar radiation (needed for nksr) + USE phycst ! physical constant + USE ldftra ! lateral physics : tracers + USE ldfslp ! lateral physics : slopes + USE bdy_oce , ONLY : ln_bdy + USE bdytra ! open boundary condition (bdy_tra routine) + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_atf ! routine called by step.F90 + PUBLIC tra_atf_fix ! to be used in trcnxt + PUBLIC tra_atf_vvl ! to be used in trcnxt + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traatf.F90 15004 2021-06-16 10:33:18Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_atf( kt, Kbb, Kmm, Kaa, pts ) + !!---------------------------------------------------------------------- + !! *** ROUTINE traatf *** + !! + !! ** Purpose : Apply the boundary condition on the after temperature + !! and salinity fields and add the Asselin time filter on now fields. + !! + !! ** Method : At this stage of the computation, ta and sa are the + !! after temperature and salinity as the time stepping has + !! been performed in trazdf_imp or trazdf_exp module. + !! + !! - Apply lateral boundary conditions on (ta,sa) + !! at the local domain boundaries through lbc_lnk call, + !! at the one-way open boundaries (ln_bdy=T), + !! at the AGRIF zoom boundaries (lk_agrif=T) + !! + !! - Update lateral boundary conditions on AGRIF children + !! domains (lk_agrif=T) + !! + !! ** Action : - ts(Kmm) time filtered + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: zfact ! local scalars + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'tra_atf') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf : apply Asselin time filter to "now" fields' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + + ! Update after tracer on domain lateral boundaries + ! + ! ! local domain boundaries (T-point, unchanged sign) + CALL lbc_lnk( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_dp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_dp ) + ! + IF( ln_bdy ) CALL bdy_tra( kt, Kbb, pts, Kaa ) ! BDY open boundaries + + ! trends computation initialisation + IF( l_trdtra ) THEN + ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = 0._wp + ztrds(:,:,:) = 0._wp + IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_zdfp, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_zdfp, ztrds ) + ENDIF + ! total trend for the non-time-filtered variables. + zfact = 1.0 / rn_Dt + ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from pts(Kmm) terms + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kaa)*(e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kaa)*tmask(:,:,jk))) / (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) - pts(:,:,jk,jp_tem,Kmm)) * zfact + ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kaa)*(e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kaa)*tmask(:,:,jk))) / (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) - pts(:,:,jk,jp_sal,Kmm)) * zfact + END DO + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_tot, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_tot, ztrds ) + IF( ln_linssh ) THEN ! linear sea surface height only + ! Store now fields before applying the Asselin filter + ! in order to calculate Asselin filter trend later. + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kmm) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Kmm) + ENDIF + ENDIF + + IF( l_1st_euler ) THEN ! Euler time-stepping + ! + IF (l_trdtra .AND. .NOT. ln_linssh ) THEN ! Zero Asselin filter contribution must be explicitly written out since for vvl + ! ! Asselin filter is output by tra_atf_vvl that is not called on this time step + ztrdt(:,:,:) = 0._wp + ztrds(:,:,:) = 0._wp + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_atf, ztrds ) + END IF + ! + ELSE ! Leap-Frog + Asselin filter time stepping + ! + IF( ln_linssh ) THEN ; CALL tra_atf_fix( kt, Kbb, Kmm, Kaa, nit000, 'TRA', pts, jpts ) ! linear free surface + ELSE ; CALL tra_atf_vvl( kt, Kbb, Kmm, Kaa, nit000, rn_Dt, 'TRA', pts, sbc_tsc, sbc_tsc_b, jpts ) ! non-linear free surface + ENDIF + ! + CALL lbc_lnk( 'traatf', pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_dp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_dp ) + + ENDIF + ! + IF( l_trdtra .AND. ln_linssh ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kmm) - ztrdt(:,:,jk) ) * r1_Dt + ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kmm) - ztrds(:,:,jk) ) * r1_Dt + END DO + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_atf, ztrds ) + END IF + IF( l_trdtra ) DEALLOCATE( ztrdt , ztrds ) + ! + ! ! control print + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kmm), clinfo1=' nxt - Tn: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Kmm), clinfo2= ' Sn: ', mask2=tmask ) + ! + IF( ln_timing ) CALL timing_stop('tra_atf') + ! + END SUBROUTINE tra_atf + + + SUBROUTINE tra_atf_fix( kt, Kbb, Kmm, Kaa, kit000, cdtype, pt, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_atf_fix *** + !! + !! ** Purpose : fixed volume: apply the Asselin time filter to the "now" field + !! + !! ** Method : - Apply a Asselin time filter on now fields. + !! + !! ** Action : - pt(Kmm) ready for the next time step + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztn, ztd ! local scalars + !!---------------------------------------------------------------------- + ! + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf_fix : time filtering', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + DO jn = 1, kjpt + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ztn = pt(ji,jj,jk,jn,Kmm) + ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers + ! + pt(ji,jj,jk,jn,Kmm) = ztn + rn_atfp * ztd ! pt <-- filtered pt + END DO ; END DO ; END DO + ! + END DO + ! + END SUBROUTINE tra_atf_fix + + + SUBROUTINE tra_atf_vvl( kt, Kbb, Kmm, Kaa, kit000, p2dt, cdtype, pt, psbc_tc, psbc_tc_b, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_atf_vvl *** + !! + !! ** Purpose : Time varying volume: apply the Asselin time filter + !! + !! ** Method : - Apply a thickness weighted Asselin time filter on now fields. + !! pt(Kmm) = ( e3t_Kmm*pt(Kmm) + rn_atfp*[ e3t_Kbb*pt(Kbb) - 2 e3t_Kmm*pt(Kmm) + e3t_Kaa*pt(Kaa) ] ) + !! /( e3t_Kmm + rn_atfp*[ e3t_Kbb - 2 e3t_Kmm + e3t_Kaa ] ) + !! + !! ** Action : - pt(Kmm) ready for the next time step + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + REAL(wp) , INTENT(in ) :: p2dt ! time-step + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content + ! + LOGICAL :: ll_traqsr, ll_rnf, ll_isf ! local logical + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: zfact, zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar + REAL(wp) :: zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d, zscale ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf + !!---------------------------------------------------------------------- + ! + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf_vvl : time filtering', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + IF( cdtype == 'TRA' ) THEN + ll_traqsr = ln_traqsr ! active tracers case and solar penetration + ll_rnf = ln_rnf ! active tracers case and river runoffs + ll_isf = ln_isf ! active tracers case and ice shelf melting + ELSE ! passive tracers case + ll_traqsr = .FALSE. ! NO solar penetration + ll_rnf = .FALSE. ! NO river runoffs ???? !!gm BUG ? + ll_isf = .FALSE. ! NO ice shelf melting/freezing !!gm BUG ?? + ENDIF + ! + IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) ) THEN + ALLOCATE( ztrd_atf(jpi,jpj,jpk,kjpt) ) + ztrd_atf(:,:,:,:) = 0.0_wp + ENDIF + zfact = 1._wp / p2dt + zfact1 = rn_atfp * p2dt + zfact2 = zfact1 * r1_rho0 + DO jn = 1, kjpt + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ze3t_b = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kbb)*tmask(ji,jj,jk))) + ze3t_n = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + ze3t_a = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kaa)*tmask(ji,jj,jk))) + ! ! tracer content at Before, now and after + ztc_b = pt(ji,jj,jk,jn,Kbb) * ze3t_b + ztc_n = pt(ji,jj,jk,jn,Kmm) * ze3t_n + ztc_a = pt(ji,jj,jk,jn,Kaa) * ze3t_a + ! + ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b + ztc_d = ztc_a - 2. * ztc_n + ztc_b + ! + ze3t_f = ze3t_n + rn_atfp * ze3t_d + ztc_f = ztc_n + rn_atfp * ztc_d + ! + ! Add asselin correction on scale factors: + zscale = tmask(ji,jj,jk) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / ( (ht_0(ji,jj)*(1._wp+r3t(ji,jj,Kmm))) + 1._wp - ssmask(ji,jj) ) + ze3t_f = ze3t_f - zfact2 * zscale * ( emp_b(ji,jj) - emp(ji,jj) ) + IF ( ll_rnf ) ze3t_f = ze3t_f + zfact2 * zscale * ( rnf_b(ji,jj) - rnf(ji,jj) ) + IF ( ll_isf ) THEN + IF ( ln_isfcav_mlt ) ze3t_f = ze3t_f + zfact2 * zscale * ( fwfisf_cav_b(ji,jj) - fwfisf_cav(ji,jj) ) + IF ( ln_isfpar_mlt ) ze3t_f = ze3t_f + zfact2 * zscale * ( fwfisf_par_b(ji,jj) - fwfisf_par(ji,jj) ) + ENDIF + ! + IF( jk == mikt(ji,jj) ) THEN ! first level + ztc_f = ztc_f - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) + ENDIF + ! + ! solar penetration (temperature only) + IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr ) & + & ztc_f = ztc_f - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) ) + ! + ! + IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) ) & + & ztc_f = ztc_f - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / h_rnf(ji,jj) + + ! + ! ice shelf + IF( ll_isf ) THEN + ! + ! melt in the cavity + IF ( ln_isfcav_mlt ) THEN + ! level fully include in the Losch_2008 ice shelf boundary layer + IF ( jk >= misfkt_cav(ji,jj) .AND. jk < misfkb_cav(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / rhisf_tbl_cav(ji,jj) + END IF + ! level partially include in Losch_2008 ice shelf boundary layer + IF ( jk == misfkb_cav(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / rhisf_tbl_cav(ji,jj) * rfrac_tbl_cav(ji,jj) + END IF + END IF + ! + ! parametrised melt (cavity closed) + IF ( ln_isfpar_mlt ) THEN + ! level fully include in the Losch_2008 ice shelf boundary layer + IF ( jk >= misfkt_par(ji,jj) .AND. jk < misfkb_par(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / rhisf_tbl_par(ji,jj) + END IF + ! level partially include in Losch_2008 ice shelf boundary layer + IF ( jk == misfkb_par(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / rhisf_tbl_par(ji,jj) * rfrac_tbl_par(ji,jj) + END IF + END IF + ! + ! ice sheet coupling correction + IF ( ln_isfcpl ) THEN + ! + ! at kt = nit000, risfcpl_vol_n = 0 and risfcpl_vol_b = risfcpl_vol so contribution nul + IF ( ln_rstart .AND. kt == nit000+1 ) THEN + ztc_f = ztc_f + zfact1 * risfcpl_tsc(ji,jj,jk,jn) * r1_e1e2t(ji,jj) + ! Shouldn't volume increment be spread according thanks to zscale ? + ze3t_f = ze3t_f - zfact1 * risfcpl_vol(ji,jj,jk ) * r1_e1e2t(ji,jj) + END IF + ! + END IF + ! + END IF + ! + ze3t_f = 1.e0 / ze3t_f + pt(ji,jj,jk,jn,Kmm) = ztc_f * ze3t_f ! time filtered "now" field + ! + IF( ( l_trdtra .and. cdtype == 'TRA' ) .OR. ( l_trdtrc .and. cdtype == 'TRC' ) ) THEN + ztrd_atf(ji,jj,jk,jn) = (ztc_f - ztc_n) * zfact/ze3t_n + ENDIF + ! + END DO ; END DO ; END DO + ! + END DO + ! + IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) ) THEN + IF( l_trdtra .AND. cdtype == 'TRA' ) THEN + CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_tem, jptra_atf, ztrd_atf(:,:,:,jp_tem) ) + CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_sal, jptra_atf, ztrd_atf(:,:,:,jp_sal) ) + ENDIF + IF( l_trdtrc .AND. cdtype == 'TRC' ) THEN + DO jn = 1, kjpt + CALL trd_tra( kt, Kmm, Kaa, cdtype, jn, jptra_atf, ztrd_atf(:,:,:,jn) ) + END DO + ENDIF + DEALLOCATE( ztrd_atf ) + ENDIF + ! + END SUBROUTINE tra_atf_vvl + + !!====================================================================== +END MODULE traatf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traatf_qco.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traatf_qco.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4268aea3eb2c01a05d712b8b99eab7a1f377f6db --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traatf_qco.f90 @@ -0,0 +1,397 @@ + + + + + + + + + + + + + +MODULE traatf_qco + !!====================================================================== + !! *** MODULE traatf_qco *** + !! Ocean active tracers: Asselin time filtering for temperature and salinity + !!====================================================================== + !! History : OPA ! 1991-11 (G. Madec) Original code + !! 7.0 ! 1993-03 (M. Guyon) symetrical conditions + !! 8.0 ! 1996-02 (G. Madec & M. Imbard) opa release 8.0 + !! - ! 1996-04 (A. Weaver) Euler forward step + !! 8.2 ! 1999-02 (G. Madec, N. Grima) semi-implicit pressure grad. + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2002-11 (C. Talandier, A-M Treguier) Open boundaries + !! - ! 2005-04 (C. Deltel) Add Asselin trend in the ML budget + !! 2.0 ! 2006-02 (L. Debreu, C. Mazauric) Agrif implementation + !! 3.0 ! 2008-06 (G. Madec) time stepping always done in trazdf + !! 3.1 ! 2009-02 (G. Madec, R. Benshila) re-introduce the vvl option + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) semi-implicit hpg with asselin filter + modified LF-RA + !! - ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename tranxt.F90 -> traatfLF.F90. Now only does time filtering. + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_atf : time filtering on tracers + !! tra_atf_fix : time filtering on tracers : fixed volume case + !! tra_atf_vvl : time filtering on tracers : variable volume case + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! surface boundary condition: ocean + USE sbcrnf ! river runoffs + USE isf_oce ! ice shelf melting + USE zdf_oce ! ocean vertical mixing + USE domvvl ! variable volume + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE traqsr ! penetrative solar radiation (needed for nksr) + USE phycst ! physical constant + USE ldftra ! lateral physics : tracers + USE ldfslp ! lateral physics : slopes + USE bdy_oce , ONLY : ln_bdy + USE bdytra ! open boundary condition (bdy_tra routine) + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_atf_qco ! routine called by step.F90 + PUBLIC tra_atf_fix_lf ! to be used in trcnxt !!st WARNING discrepancy here interpol is used by PISCES + PUBLIC tra_atf_qco_lf ! to be used in trcnxt !!st WARNING discrepancy here interpol is used by PISCES + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traatf_qco.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_atf_qco( kt, Kbb, Kmm, Kaa, pts ) + !!---------------------------------------------------------------------- + !! *** ROUTINE traatfLF *** + !! + !! ** Purpose : Apply the boundary condition on the after temperature + !! and salinity fields and add the Asselin time filter on now fields. + !! + !! ** Method : At this stage of the computation, ta and sa are the + !! after temperature and salinity as the time stepping has + !! been performed in trazdf_imp or trazdf_exp module. + !! + !! - Apply lateral boundary conditions on (ta,sa) + !! at the local domain boundaries through lbc_lnk call, + !! at the one-way open boundaries (ln_bdy=T), + !! at the AGRIF zoom boundaries (lk_agrif=T) + !! + !! - Update lateral boundary conditions on AGRIF children + !! domains (lk_agrif=T) + !! + !! ** Action : - ts(Kmm) time filtered + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(dp) :: zfact ! local scalars + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'tra_atf_qco') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf_qco : apply Asselin time filter to "now" fields' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF +!!st Update after tracer on domain lateral boundaries as been removed outside + + ! trends computation initialisation + IF( l_trdtra ) THEN + ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,jpk) = 0._wp + ztrds(:,:,jpk) = 0._wp + IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_zdfp, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_zdfp, ztrds ) + ENDIF + ! total trend for the non-time-filtered variables. + zfact = 1.0 / rn_Dt + ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from pts(Kmm) terms + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kaa) * (1._wp + r3t(:,:,Kaa) * tmask(:,:,jk))/(1._wp + r3t(:,:,Kmm) * tmask(:,:,jk)) & + & - pts(:,:,jk,jp_tem,Kmm) ) * zfact + ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kaa) * (1._wp + r3t(:,:,Kaa) * tmask(:,:,jk))/(1._wp + r3t(:,:,Kmm) * tmask(:,:,jk)) & + & - pts(:,:,jk,jp_sal,Kmm) ) * zfact + END DO + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_tot, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_tot, ztrds ) + IF( ln_linssh ) THEN ! linear sea surface height only + ! Store now fields before applying the Asselin filter + ! in order to calculate Asselin filter trend later. + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kmm) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Kmm) + ENDIF + ENDIF + + IF( l_1st_euler ) THEN ! Euler time-stepping + ! + IF (l_trdtra .AND. .NOT. ln_linssh ) THEN ! Zero Asselin filter contribution must be explicitly written out since for vvl + ! ! Asselin filter is output by tra_atf_vvl that is not called on this time step + ztrdt(:,:,:) = 0._wp + ztrds(:,:,:) = 0._wp + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_atf, ztrds ) + END IF + ! + ELSE ! Leap-Frog + Asselin filter time stepping + ! + IF ( ln_linssh ) THEN ; CALL tra_atf_fix_lf( kt, Kbb, Kmm, Kaa, nit000, 'TRA', pts, jpts ) ! linear free surface + ELSE ; CALL tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, nit000, rn_Dt, 'TRA', pts, sbc_tsc, sbc_tsc_b, jpts ) ! non-linear free surface + ENDIF + ! + CALL lbc_lnk( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._dp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._dp ) + ! + ENDIF + ! + IF( l_trdtra .AND. ln_linssh ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kmm) - ztrdt(:,:,jk) ) * r1_Dt + ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kmm) - ztrds(:,:,jk) ) * r1_Dt + END DO + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_atf, ztrds ) + END IF + IF( l_trdtra ) DEALLOCATE( ztrdt , ztrds ) + ! + ! ! control print + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kmm), clinfo1=' nxt - Tn: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Kmm), clinfo2= ' Sn: ', mask2=tmask ) + ! + IF( ln_timing ) CALL timing_stop('tra_atf_qco') + ! + END SUBROUTINE tra_atf_qco + + + SUBROUTINE tra_atf_fix_lf( kt, Kbb, Kmm, Kaa, kit000, cdtype, pt, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_atf_fix *** + !! + !! ** Purpose : fixed volume: apply the Asselin time filter to the "now" field + !! + !! ** Method : - Apply a Asselin time filter on now fields. + !! + !! ** Action : - pt(Kmm) ready for the next time step + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztn, ztd ! local scalars + !!---------------------------------------------------------------------- + ! + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf_fix_lf : time filtering', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + DO jn = 1, kjpt + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ztn = pt(ji,jj,jk,jn,Kmm) + ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers + ! + pt(ji,jj,jk,jn,Kmm) = ztn + rn_atfp * ztd ! pt <-- filtered pt + END DO ; END DO ; END DO + ! + END DO + ! + END SUBROUTINE tra_atf_fix_lf + + + SUBROUTINE tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, kit000, p2dt, cdtype, pt, psbc_tc, psbc_tc_b, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_atf_vvl *** + !! + !! ** Purpose : Time varying volume: apply the Asselin time filter + !! + !! ** Method : - Apply a thickness weighted Asselin time filter on now fields. + !! pt(Kmm) = ( e3t_m*pt(Kmm) + rn_atfp*[ e3t_b*pt(Kbb) - 2 e3t_m*pt(Kmm) + e3t_a*pt(Kaa) ] ) + !! /( e3t_m + rn_atfp*[ e3t_b - 2 e3t_m + e3t_a ] ) + !! + !! ** Action : - pt(Kmm) ready for the next time step + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + REAL(wp) , INTENT(in ) :: p2dt ! time-step + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content + ! + LOGICAL :: ll_traqsr, ll_rnf, ll_isf ! local logical + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(dp) :: zfact, zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar + REAL(dp) :: zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf + !!---------------------------------------------------------------------- + ! + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf_qco : time filtering', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + IF( cdtype == 'TRA' ) THEN + ll_traqsr = ln_traqsr ! active tracers case and solar penetration + ll_rnf = ln_rnf ! active tracers case and river runoffs + ll_isf = ln_isf ! active tracers case and ice shelf melting + ELSE ! passive tracers case + ll_traqsr = .FALSE. ! NO solar penetration + ll_rnf = .FALSE. ! NO river runoffs ???? !!gm BUG ? + ll_isf = .FALSE. ! NO ice shelf melting/freezing !!gm BUG ?? + ENDIF + ! + IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) ) THEN + ALLOCATE( ztrd_atf(jpi,jpj,jpk,kjpt) ) + ztrd_atf(:,:,:,:) = 0.0_wp + ENDIF + zfact = 1._wp / p2dt + zfact1 = rn_atfp * p2dt + zfact2 = zfact1 * r1_rho0 + DO jn = 1, kjpt + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ze3t_b = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kbb)*tmask(ji,jj,jk))) + ze3t_n = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + ze3t_a = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kaa)*tmask(ji,jj,jk))) + ! ! tracer content at Before, now and after + ztc_b = pt(ji,jj,jk,jn,Kbb) * ze3t_b + ztc_n = pt(ji,jj,jk,jn,Kmm) * ze3t_n + ztc_a = pt(ji,jj,jk,jn,Kaa) * ze3t_a + ! + ztc_d = ztc_a - 2. * ztc_n + ztc_b + ! + ztc_f = ztc_n + rn_atfp * ztc_d + ! + ! Asselin correction on scale factors is done via ssh in r3t_f + ze3t_f = e3t_0(ji,jj,jk) * ( 1._wp + r3t_f(ji,jj) * tmask(ji,jj,jk) ) + + ! + IF( jk == mikt(ji,jj) ) THEN ! first level + ztc_f = ztc_f - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) + ENDIF + ! + ! solar penetration (temperature only) + IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr ) & + & ztc_f = ztc_f - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) ) + ! + ! + IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) ) & + & ztc_f = ztc_f - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / h_rnf(ji,jj) + + ! + ! ice shelf + IF( ll_isf ) THEN + ! + ! melt in the cavity + IF ( ln_isfcav_mlt ) THEN + ! level fully include in the Losch_2008 ice shelf boundary layer + IF ( jk >= misfkt_cav(ji,jj) .AND. jk < misfkb_cav(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / rhisf_tbl_cav(ji,jj) + END IF + ! level partially include in Losch_2008 ice shelf boundary layer + IF ( jk == misfkb_cav(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / rhisf_tbl_cav(ji,jj) & + & * rfrac_tbl_cav(ji,jj) + END IF + END IF + ! + ! parametrised melt (cavity closed) + IF ( ln_isfpar_mlt ) THEN + ! level fully include in the Losch_2008 ice shelf boundary layer + IF ( jk >= misfkt_par(ji,jj) .AND. jk < misfkb_par(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / rhisf_tbl_par(ji,jj) + END IF + ! level partially include in Losch_2008 ice shelf boundary layer + IF ( jk == misfkb_par(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) ) & + & * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) / rhisf_tbl_par(ji,jj) & + & * rfrac_tbl_par(ji,jj) + END IF + END IF + ! + ! ice sheet coupling correction + IF ( ln_isfcpl ) THEN + ! + ! at kt = nit000, risfcpl_vol_n = 0 and risfcpl_vol_b = risfcpl_vol so contribution nul + IF ( ln_rstart .AND. kt == nit000+1 ) THEN + ztc_f = ztc_f + zfact1 * risfcpl_tsc(ji,jj,jk,jn) * r1_e1e2t(ji,jj) + ! Shouldn't volume increment be spread according thanks to zscale ? + END IF + ! + END IF + ! + END IF + ! + ze3t_f = 1.e0 / ze3t_f + pt(ji,jj,jk,jn,Kmm) = ztc_f * ze3t_f ! time filtered "now" field + ! + IF( ( l_trdtra .and. cdtype == 'TRA' ) .OR. ( l_trdtrc .and. cdtype == 'TRC' ) ) THEN + ztrd_atf(ji,jj,jk,jn) = (ztc_f - ztc_n) * zfact/ze3t_n + ENDIF + ! + END DO ; END DO ; END DO + ! + END DO + ! + IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) ) THEN + IF( l_trdtra .AND. cdtype == 'TRA' ) THEN + CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_tem, jptra_atf, ztrd_atf(:,:,:,jp_tem) ) + CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_sal, jptra_atf, ztrd_atf(:,:,:,jp_sal) ) + ENDIF + IF( l_trdtrc .AND. cdtype == 'TRC' ) THEN + DO jn = 1, kjpt + CALL trd_tra( kt, Kmm, Kaa, cdtype, jn, jptra_atf, ztrd_atf(:,:,:,jn) ) + END DO + ENDIF + DEALLOCATE( ztrd_atf ) + ENDIF + ! + END SUBROUTINE tra_atf_qco_lf + + !!====================================================================== +END MODULE traatf_qco diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trabbc.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trabbc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b77ecbc3472706038f7de26439890203566dc6f9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trabbc.f90 @@ -0,0 +1,224 @@ + + + + + + + + + + + + + +MODULE trabbc + !!============================================================================== + !! *** MODULE trabbc *** + !! Ocean active tracers: bottom boundary condition (geothermal heat flux) + !!============================================================================== + !! History : OPA ! 1999-10 (G. Madec) original code + !! NEMO 1.0 ! 2002-08 (G. Madec) free form + modules + !! - ! 2002-11 (A. Bozec) tra_bbc_init: original code + !! 3.3 ! 2010-10 (G. Madec) dynamical allocation + suppression of key_trabbc + !! - ! 2010-11 (G. Madec) use mbkt array (deepest ocean t-level) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_bbc : update the tracer trend at ocean bottom + !! tra_bbc_init : initialization of geothermal heat flux trend + !!---------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! domain: ocean + USE phycst ! physical constants + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + ! + USE in_out_manager ! I/O manager + USE iom ! xIOS + USE fldread ! read input fields + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing library + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_bbc ! routine called by step.F90 + PUBLIC tra_bbc_init ! routine called by opa.F90 + + ! !!* Namelist nambbc: bottom boundary condition * + LOGICAL, PUBLIC :: ln_trabbc !: Geothermal heat flux flag + INTEGER :: nn_geoflx ! Geothermal flux (=1:constant flux, =2:read in file ) + REAL(wp) :: rn_geoflx_cst ! Constant value of geothermal heat flux + + REAL(wp), PUBLIC , ALLOCATABLE, DIMENSION(:,:) :: qgh_trd0 ! geothermal heating trend + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_qgh ! structure of input qgh (file informations, fields read) + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trabbc.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_bbc( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_bbc *** + !! + !! ** Purpose : Compute the bottom boundary contition on temperature + !! associated with geothermal heating and add it to the + !! general trend of temperature equations. + !! + !! ** Method : The geothermal heat flux set to its constant value of + !! 86.4 mW/m2 (Stein and Stein 1992, Huang 1999). + !! The temperature trend associated to this heat flux through the + !! ocean bottom can be computed once and is added to the temperature + !! trend juste above the bottom at each time step: + !! ta = ta + Qsf / (rho0 rcp e3T) for k= mbkt + !! Where Qsf is the geothermal heat flux. + !! + !! ** Action : - update the temperature trends with geothermal heating trend + !! - send the trend for further diagnostics (ln_trdtra=T) + !! + !! References : Stein, C. A., and S. Stein, 1992, Nature, 359, 123-129. + !! Emile-Geay and Madec, 2009, Ocean Science. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_bbc') + ! + IF( l_trdtra ) THEN ! Save the input temperature trend + ALLOCATE( ztrdt(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ENDIF + ! ! Add the geothermal trend on temperature + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) = pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) & + & + qgh_trd0(ji,jj) / (e3t_0(ji,jj,mbkt(ji,jj))*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,mbkt(ji,jj)))) + END DO ; END DO + ! + IF( l_trdtra ) THEN ! Send the trend for diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_bbc, ztrdt ) + DEALLOCATE( ztrdt ) + ENDIF + ! + CALL iom_put ( "hfgeou" , rho0_rcp * qgh_trd0(:,:) ) + + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbc - Ta: ', mask1=tmask, clinfo3='tra-ta' ) + ! + IF( ln_timing ) CALL timing_stop('tra_bbc') + ! + END SUBROUTINE tra_bbc + + + SUBROUTINE tra_bbc_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_bbc_init *** + !! + !! ** Purpose : Compute once for all the trend associated with geothermal + !! heating that will be applied at each time step at the + !! last ocean level + !! + !! ** Method : Read the nambbc namelist and check the parameters. + !! + !! ** Input : - Namlist nambbc + !! - NetCDF file : geothermal_heating.nc ( if necessary ) + !! + !! ** Action : - read/fix the geothermal heat qgh_trd0 + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: inum ! temporary logical unit + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: ierror ! local integer + ! + TYPE(FLD_N) :: sn_qgh ! informations about the geotherm. field to be read + CHARACTER(len=256) :: cn_dir ! Root directory for location of ssr files + !! + NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in reference namelist' ) + ! + READ ( numnam_cfg, nambbc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbc in configuration namelist' ) + IF(lwm) WRITE ( numond, nambbc ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'tra_bbc : Bottom Boundary Condition (bbc), apply a Geothermal heating' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' Namelist nambbc : set bbc parameters' + WRITE(numout,*) ' Apply a geothermal heating at ocean bottom ln_trabbc = ', ln_trabbc + WRITE(numout,*) ' type of geothermal flux nn_geoflx = ', nn_geoflx + WRITE(numout,*) ' Constant geothermal flux value rn_geoflx_cst = ', rn_geoflx_cst + WRITE(numout,*) + ENDIF + ! + IF( ln_trabbc ) THEN !== geothermal heating ==! + ! + ALLOCATE( qgh_trd0(jpi,jpj) ) ! allocation + ! + SELECT CASE ( nn_geoflx ) ! geothermal heat flux / (rauO * Cp) + ! + CASE ( 1 ) !* constant flux + IF(lwp) WRITE(numout,*) ' ==>>> constant heat flux = ', rn_geoflx_cst + qgh_trd0(:,:) = r1_rho0_rcp * rn_geoflx_cst + ! + CASE ( 2 ) !* variable geothermal heat flux : read the geothermal fluxes in mW/m2 + IF(lwp) WRITE(numout,*) ' ==>>> variable geothermal heat flux' + ! + ALLOCATE( sf_qgh(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'tra_bbc_init: unable to allocate sf_qgh structure' ) ; + RETURN + ENDIF + ALLOCATE( sf_qgh(1)%fnow(jpi,jpj,1) ) + IF( sn_qgh%ln_tint ) ALLOCATE( sf_qgh(1)%fdta(jpi,jpj,1,2) ) + ! fill sf_chl with sn_chl and control print + CALL fld_fill( sf_qgh, (/ sn_qgh /), cn_dir, 'tra_bbc_init', & + & 'bottom temperature boundary condition', 'nambbc', no_print ) + + CALL fld_read( nit000, 1, sf_qgh ) ! Read qgh data + qgh_trd0(:,:) = r1_rho0_rcp * sf_qgh(1)%fnow(:,:,1) * 1.e-3 ! conversion in W/m2 + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for nn_geoflx = ', nn_geoflx + CALL ctl_stop( ctmp1 ) + END SELECT + ! + ELSE + IF(lwp) WRITE(numout,*) ' ==>>> no geothermal heat flux' + ENDIF + ! + END SUBROUTINE tra_bbc_init + + !!====================================================================== +END MODULE trabbc diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trabbl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trabbl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..526808aeb568d709d3553f7f8f90528ef3c46714 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trabbl.f90 @@ -0,0 +1,571 @@ + + + + + + + + + + + + + +MODULE trabbl + !!============================================================================== + !! *** MODULE trabbl *** + !! Ocean physics : advective and/or diffusive bottom boundary layer scheme + !!============================================================================== + !! History : OPA ! 1996-06 (L. Mortier) Original code + !! 8.0 ! 1997-11 (G. Madec) Optimization + !! NEMO 1.0 ! 2002-08 (G. Madec) free form + modules + !! - ! 2004-01 (A. de Miranda, G. Madec, J.M. Molines ) add advective bbl + !! 3.3 ! 2009-11 (G. Madec) merge trabbl and trabbl_adv + style + optimization + !! - ! 2010-04 (G. Madec) Campin & Goosse advective bbl + !! - ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC + !! - ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level + !! - ! 2013-04 (F. Roquet, G. Madec) use of eosbn2 instead of local hard coded alpha and beta + !! 4.0 ! 2017-04 (G. Madec) ln_trabbl namelist variable instead of a CPP key + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_bbl_alloc : allocate trabbl arrays + !! tra_bbl : update the tracer trends due to the bottom boundary layer (advective and/or diffusive) + !! tra_bbl_dif : generic routine to compute bbl diffusive trend + !! tra_bbl_adv : generic routine to compute bbl advective trend + !! bbl : computation of bbl diffu. flux coef. & transport in bottom boundary layer + !! tra_bbl_init : initialization, namelist read, parameters control + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constant + USE eosbn2 ! equation of state + USE trd_oce ! trends: ocean variables + USE trdtra ! trends: active tracers + ! + USE iom ! IOM library + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions + USE prtctl ! Print control + USE timing ! Timing + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_bbl ! routine called by step.F90 + PUBLIC tra_bbl_init ! routine called by nemogcm.F90 + PUBLIC tra_bbl_dif ! routine called by trcbbl.F90 + PUBLIC tra_bbl_adv ! - - - + PUBLIC bbl ! routine called by trcbbl.F90 and dtadyn.F90 + + ! !!* Namelist nambbl * + LOGICAL , PUBLIC :: ln_trabbl !: bottom boundary layer flag + INTEGER , PUBLIC :: nn_bbl_ldf !: =1 : diffusive bbl or not (=0) + INTEGER , PUBLIC :: nn_bbl_adv !: =1/2 : advective bbl or not (=0) + ! ! =1 : advective bbl using the bottom ocean velocity + ! ! =2 : - - using utr_bbl proportional to grad(rho) + REAL(wp), PUBLIC :: rn_ahtbbl !: along slope bbl diffusive coefficient [m2/s] + REAL(wp), PUBLIC :: rn_gambbl !: lateral coeff. for bottom boundary layer scheme [s] + + LOGICAL , PUBLIC :: l_bbl !: flag to compute bbl diffu. flux coef and transport + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: utr_bbl , vtr_bbl ! u- (v-) transport in the bottom boundary layer + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: ahu_bbl , ahv_bbl ! masked diffusive bbl coeff. at u & v-pts + + INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: mbku_d , mbkv_d ! vertical index of the "lower" bottom ocean U/V-level (PUBLIC for TAM) + INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: mgrhu , mgrhv ! = +/-1, sign of grad(H) in u-(v-)direction (PUBLIC for TAM) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahu_bbl_0, ahv_bbl_0 ! diffusive bbl flux coefficients at u and v-points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: e3u_bbl_0, e3v_bbl_0 ! thichness of the bbl (e3) at u and v-points (PUBLIC for TAM) + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trabbl.F90 15053 2021-06-24 15:39:38Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION tra_bbl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION tra_bbl_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( utr_bbl (jpi,jpj) , ahu_bbl (jpi,jpj) , mbku_d(jpi,jpj) , mgrhu(jpi,jpj) , & + & vtr_bbl (jpi,jpj) , ahv_bbl (jpi,jpj) , mbkv_d(jpi,jpj) , mgrhv(jpi,jpj) , & + & ahu_bbl_0(jpi,jpj) , ahv_bbl_0(jpi,jpj) , & + & e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , STAT=tra_bbl_alloc ) + ! + CALL mpp_sum ( 'trabbl', tra_bbl_alloc ) + IF( tra_bbl_alloc > 0 ) CALL ctl_warn('tra_bbl_alloc: allocation of arrays failed.') + END FUNCTION tra_bbl_alloc + + + SUBROUTINE tra_bbl( kt, Kbb, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bbl *** + !! + !! ** Purpose : Compute the before tracer (t & s) trend associated + !! with the bottom boundary layer and add it to the general + !! trend of tracer equations. + !! + !! ** Method : Depending on namtra_bbl namelist parameters the bbl + !! diffusive and/or advective contribution to the tracer trend + !! is added to the general tracer trend + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step + INTEGER, INTENT(in ) :: Kbb, Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! Dummy loop indices + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'tra_bbl') + ! + IF( l_trdtra ) THEN !* Save the T-S input trends + ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) + ENDIF + + IF( l_bbl ) CALL bbl( kt, nit000, 'TRA', Kbb, Kmm ) !* bbl coef. and transport (only if not already done in trcbbl) + + IF( nn_bbl_ldf == 1 ) THEN !* Diffusive bbl + ! + CALL tra_bbl_dif( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) + !IF( sn_cfctl%l_prtctl ) & + !CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_ldf - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef + CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef + ! + ENDIF + ! + IF( nn_bbl_adv /= 0 ) THEN !* Advective bbl + ! + CALL tra_bbl_adv( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) + ! IF(sn_cfctl%l_prtctl) & + !CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport + CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport + ! + ENDIF + + IF( l_trdtra ) THEN ! send the trends for further diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_bbl, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_bbl, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop( 'tra_bbl') + ! + END SUBROUTINE tra_bbl + + + SUBROUTINE tra_bbl_dif( pt, pt_rhs, kjpt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_bbl_dif *** + !! + !! ** Purpose : Computes the bottom boundary horizontal and vertical + !! advection terms. + !! + !! ** Method : * diffusive bbl only (nn_bbl_ldf=1) : + !! When the product grad( rho) * grad(h) < 0 (where grad is an + !! along bottom slope gradient) an additional lateral 2nd order + !! diffusion along the bottom slope is added to the general + !! tracer trend, otherwise the additional trend is set to 0. + !! A typical value of ahbt is 2000 m2/s (equivalent to + !! a downslope velocity of 20 cm/s if the condition for slope + !! convection is satified) + !! + !! ** Action : pt_rhs increased by the bbl diffusive trend + !! + !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. + !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before and now tracer fields + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend + INTEGER , INTENT(in ) :: Kmm ! time level indices + ! + INTEGER :: ji, jj, jn ! dummy loop indices + INTEGER :: ik ! local integers + REAL(wp) :: zbtr ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zptb ! workspace + !!---------------------------------------------------------------------- + ! + DO jn = 1, kjpt ! tracer loop + ! ! =========== + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ik = mbkt(ji,jj) ! bottom T-level index + zptb(ji,jj) = pt(ji,jj,ik,jn) ! bottom before T and S + END DO ; END DO + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) ! Compute the trend + ik = mbkt(ji,jj) ! bottom T-level index + pt_rhs(ji,jj,ik,jn) = pt_rhs(ji,jj,ik,jn) & + & + ( ahu_bbl(ji ,jj ) * ( zptb(ji+1,jj ) - zptb(ji ,jj ) ) & + & - ahu_bbl(ji-1,jj ) * ( zptb(ji ,jj ) - zptb(ji-1,jj ) ) & + & + ahv_bbl(ji ,jj ) * ( zptb(ji ,jj+1) - zptb(ji ,jj ) ) & + & - ahv_bbl(ji ,jj-1) * ( zptb(ji ,jj ) - zptb(ji ,jj-1) ) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,ik)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,ik))) + END DO ; END DO + ! ! =========== + END DO ! end tracer + ! ! =========== + END SUBROUTINE tra_bbl_dif + + + ! NOTE: [tiling] tiling changes the results, but only the order of floating point operations is different + SUBROUTINE tra_bbl_adv( pt, pt_rhs, kjpt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_bbl *** + !! + !! ** Purpose : Compute the before passive tracer trend associated + !! with the bottom boundary layer and add it to the general trend + !! of tracer equations. + !! ** Method : advective bbl (nn_bbl_adv = 1 or 2) : + !! nn_bbl_adv = 1 use of the ocean near bottom velocity as bbl velocity + !! nn_bbl_adv = 2 follow Campin and Goosse (1999) implentation i.e. + !! transport proportional to the along-slope density gradient + !! + !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. + !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before and now tracer fields + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend + INTEGER , INTENT(in ) :: Kmm ! time level indices + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: iis , iid , ijs , ijd ! local integers + INTEGER :: ikus, ikud, ikvs, ikvd ! - - + REAL(wp) :: zbtr, ztra ! local scalars + REAL(wp) :: zu_bbl, zv_bbl ! - - + !!---------------------------------------------------------------------- + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + DO jj = ntsj-( 1-( 1+ 0 )*nthb), ntej+( 0 -( 0 + 1)*ntht) ; DO ji = ntsi-( 1-( 1+ 0)*nthl), ntei+( 0-( 0+ 1)*nthr) ! CAUTION start from i=1 to update i=2 when cyclic east-west + IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection + ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) + iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) + ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) + zu_bbl = ABS( utr_bbl(ji,jj) ) + ! + ! ! up -slope T-point (shelf bottom point) + zbtr = r1_e1e2t(iis,jj) / (e3t_0(iis,jj,ikus)*(1._wp+r3t(iis,jj,Kmm)*tmask(iis,jj,ikus))) + ztra = zu_bbl * ( pt(iid,jj,ikus,jn) - pt(iis,jj,ikus,jn) ) * zbtr + pt_rhs(iis,jj,ikus,jn) = pt_rhs(iis,jj,ikus,jn) + ztra + ! + DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) + zbtr = r1_e1e2t(iid,jj) / (e3t_0(iid,jj,jk)*(1._wp+r3t(iid,jj,Kmm)*tmask(iid,jj,jk))) + ztra = zu_bbl * ( pt(iid,jj,jk+1,jn) - pt(iid,jj,jk,jn) ) * zbtr + pt_rhs(iid,jj,jk,jn) = pt_rhs(iid,jj,jk,jn) + ztra + END DO + ! + zbtr = r1_e1e2t(iid,jj) / (e3t_0(iid,jj,ikud)*(1._wp+r3t(iid,jj,Kmm)*tmask(iid,jj,ikud))) + ztra = zu_bbl * ( pt(iis,jj,ikus,jn) - pt(iid,jj,ikud,jn) ) * zbtr + pt_rhs(iid,jj,ikud,jn) = pt_rhs(iid,jj,ikud,jn) + ztra + ENDIF + ! + IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero j-direction bbl advection + ! down-slope j/k-indices (deep) & up-slope j/k indices (shelf) + ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) + ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) + zv_bbl = ABS( vtr_bbl(ji,jj) ) + ! + ! up -slope T-point (shelf bottom point) + zbtr = r1_e1e2t(ji,ijs) / (e3t_0(ji,ijs,ikvs)*(1._wp+r3t(ji,ijs,Kmm)*tmask(ji,ijs,ikvs))) + ztra = zv_bbl * ( pt(ji,ijd,ikvs,jn) - pt(ji,ijs,ikvs,jn) ) * zbtr + pt_rhs(ji,ijs,ikvs,jn) = pt_rhs(ji,ijs,ikvs,jn) + ztra + ! + DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) + zbtr = r1_e1e2t(ji,ijd) / (e3t_0(ji,ijd,jk)*(1._wp+r3t(ji,ijd,Kmm)*tmask(ji,ijd,jk))) + ztra = zv_bbl * ( pt(ji,ijd,jk+1,jn) - pt(ji,ijd,jk,jn) ) * zbtr + pt_rhs(ji,ijd,jk,jn) = pt_rhs(ji,ijd,jk,jn) + ztra + END DO + ! ! down-slope T-point (deep bottom point) + zbtr = r1_e1e2t(ji,ijd) / (e3t_0(ji,ijd,ikvd)*(1._wp+r3t(ji,ijd,Kmm)*tmask(ji,ijd,ikvd))) + ztra = zv_bbl * ( pt(ji,ijs,ikvs,jn) - pt(ji,ijd,ikvd,jn) ) * zbtr + pt_rhs(ji,ijd,ikvd,jn) = pt_rhs(ji,ijd,ikvd,jn) + ztra + ENDIF + END DO ; END DO + ! ! =========== + END DO ! end tracer + ! ! =========== + END SUBROUTINE tra_bbl_adv + + + SUBROUTINE bbl( kt, kit000, cdtype, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bbl *** + !! + !! ** Purpose : Computes the bottom boundary horizontal and vertical + !! advection terms. + !! + !! ** Method : * diffusive bbl (nn_bbl_ldf=1) : + !! When the product grad( rho) * grad(h) < 0 (where grad is an + !! along bottom slope gradient) an additional lateral 2nd order + !! diffusion along the bottom slope is added to the general + !! tracer trend, otherwise the additional trend is set to 0. + !! A typical value of ahbt is 2000 m2/s (equivalent to + !! a downslope velocity of 20 cm/s if the condition for slope + !! convection is satified) + !! * advective bbl (nn_bbl_adv=1 or 2) : + !! nn_bbl_adv = 1 use of the ocean velocity as bbl velocity + !! nn_bbl_adv = 2 follow Campin and Goosse (1999) implentation + !! i.e. transport proportional to the along-slope density gradient + !! + !! NB: the along slope density gradient is evaluated using the + !! local density (i.e. referenced at a common local depth). + !! + !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. + !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level index + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ik ! local integers + INTEGER :: iis, iid, ikus, ikud ! - - + INTEGER :: ijs, ijd, ikvs, ikvd ! - - + REAL(wp) :: za, zb, zgdrho ! local scalars + REAL(wp) :: zsign, zsigna, zgbbl ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpts) :: zts, zab ! 3D workspace + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zub, zvb, zdep ! 2D workspace + !!---------------------------------------------------------------------- + ! + 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,*) 'trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ENDIF + ENDIF + ! !* bottom variables (T, S, alpha, beta, depth, velocity) + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ik = mbkt(ji,jj) ! bottom T-level index + zts (ji,jj,jp_tem) = ts(ji,jj,ik,jp_tem,Kbb) ! bottom before T and S + zts (ji,jj,jp_sal) = ts(ji,jj,ik,jp_sal,Kbb) + ! + zdep(ji,jj) = (gdept_0(ji,jj,ik)*(1._wp+r3t(ji,jj,Kmm))) ! bottom T-level reference depth + zub (ji,jj) = uu(ji,jj,mbku(ji,jj),Kmm) ! bottom velocity + zvb (ji,jj) = vv(ji,jj,mbkv(ji,jj),Kmm) + END DO ; END DO + ! + CALL eos_rab( zts, zdep, zab, Kmm ) + ! + ! !-------------------! + IF( nn_bbl_ldf == 1 ) THEN ! diffusive bbl ! + ! !-------------------! + DO jj = ntsj-( 1-( 1+ 0 )*nthb), ntej+( 0 -( 0 + 1)*ntht) ; DO ji = ntsi-( 1-( 1+ 0)*nthl), ntei+( 0-( 0+ 1)*nthr) ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) + ! ! i-direction + za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point + zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) + ! ! 2*masked bottom density gradient + zgdrho = ( za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) ) & + & - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) + ! + zsign = SIGN( 0.5_wp, -zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope ) + ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj) ! masked diffusive flux coeff. + ! + ! ! j-direction + za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point + zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) + ! ! 2*masked bottom density gradient + zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & + & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) + ! + zsign = SIGN( 0.5_wp, -zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of ( j-gradient * j-slope ) + ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) + END DO ; END DO + ! + ENDIF + ! + ! !-------------------! + IF( nn_bbl_adv /= 0 ) THEN ! advective bbl ! + ! !-------------------! + SELECT CASE ( nn_bbl_adv ) !* bbl transport type + ! + CASE( 1 ) != use of upper velocity + DO jj = ntsj-( 1-( 1+ 0 )*nthb), ntej+( 0 -( 0 + 1)*ntht) ; DO ji = ntsi-( 1-( 1+ 0)*nthl), ntei+( 0-( 0+ 1)*nthr) ! criteria: grad(rho).grad(h)<0 and grad(rho).grad(h)<0 + ! ! i-direction + za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point + zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) + ! ! 2*masked bottom density gradient + zgdrho = ( za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) ) & + - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) + ! + zsign = SIGN( 0.5_wp, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope + zsigna= SIGN( 0.5_wp, zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope + ! + ! ! bbl velocity + utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) + ! + ! ! j-direction + za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point + zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) + ! ! 2*masked bottom density gradient + zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & + & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) + zsign = SIGN( 0.5_wp, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope + zsigna= SIGN( 0.5_wp, zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope + ! + ! ! bbl transport + vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) + END DO ; END DO + ! + CASE( 2 ) != bbl velocity = F( delta rho ) + zgbbl = grav * rn_gambbl + DO jj = ntsj-( 1-( 1+ 0 )*nthb), ntej+( 0 -( 0 + 1)*ntht) ; DO ji = ntsi-( 1-( 1+ 0)*nthl), ntei+( 0-( 0+ 1)*nthr) ! criteria: rho_up > rho_down + ! ! i-direction + ! down-slope T-point i/k-index (deep) & up-slope T-point i/k-index (shelf) + iid = ji + MAX( 0, mgrhu(ji,jj) ) + iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) + ! + ikud = mbku_d(ji,jj) + ikus = mbku(ji,jj) + ! + za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point + zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) + ! ! masked bottom density gradient + zgdrho = 0.5 * ( za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) ) & + & - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) ) ) * umask(ji,jj,1) + zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep + ! + ! ! bbl transport (down-slope direction) + utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) + ! + ! ! j-direction + ! down-slope T-point j/k-index (deep) & of the up -slope T-point j/k-index (shelf) + ijd = jj + MAX( 0, mgrhv(ji,jj) ) + ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) + ! + ikvd = mbkv_d(ji,jj) + ikvs = mbkv(ji,jj) + ! + za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point + zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) + ! ! masked bottom density gradient + zgdrho = 0.5 * ( za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) ) & + & - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) ) ) * vmask(ji,jj,1) + zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep + ! + ! ! bbl transport (down-slope direction) + vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) + END DO ; END DO + END SELECT + ! + ENDIF + ! + END SUBROUTINE bbl + + + SUBROUTINE tra_bbl_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_bbl_init *** + !! + !! ** Purpose : Initialization for the bottom boundary layer scheme. + !! + !! ** Method : Read the nambbl namelist and check the parameters + !! called by nemo_init at the first timestep (kit000) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ii0, ii1, ij0, ij1, ios ! local integer + REAL(wp), DIMENSION(jpi,jpj) :: zmbku, zmbkv ! workspace + !! + NAMELIST/nambbl/ ln_trabbl, nn_bbl_ldf, nn_bbl_adv, rn_ahtbbl, rn_gambbl + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in reference namelist' ) + ! + READ ( numnam_cfg, nambbl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbl in configuration namelist' ) + IF(lwm) WRITE ( numond, nambbl ) + ! + l_bbl = .TRUE. !* flag to compute bbl coef and transport + ! + IF(lwp) THEN !* Parameter control and print + WRITE(numout,*) + WRITE(numout,*) 'tra_bbl_init : bottom boundary layer initialisation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist nambbl : set bbl parameters' + WRITE(numout,*) ' bottom boundary layer flag ln_trabbl = ', ln_trabbl + ENDIF + IF( .NOT.ln_trabbl ) RETURN + ! + IF(lwp) THEN + WRITE(numout,*) ' diffusive bbl (=1) or not (=0) nn_bbl_ldf = ', nn_bbl_ldf + WRITE(numout,*) ' advective bbl (=1/2) or not (=0) nn_bbl_adv = ', nn_bbl_adv + WRITE(numout,*) ' diffusive bbl coefficient rn_ahtbbl = ', rn_ahtbbl, ' m2/s' + WRITE(numout,*) ' advective bbl coefficient rn_gambbl = ', rn_gambbl, ' s' + ENDIF + ! + ! ! allocate trabbl arrays + IF( tra_bbl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_bbl_init : unable to allocate arrays' ) + ! + IF(lwp) THEN + IF( nn_bbl_adv == 1 ) WRITE(numout,*) ' * Advective BBL using upper velocity' + IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)' + ENDIF + ! + ! !* vertical index of "deep" bottom u- and v-points + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) ! (the "shelf" bottom k-indices are mbku and mbkv) + mbku_d(ji,jj) = MAX( mbkt(ji+1,jj ) , mbkt(ji,jj) ) ! >= 1 as mbkt=1 over land + mbkv_d(ji,jj) = MAX( 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 + zmbku(:,:) = REAL( mbku_d(:,:), wp ) ; zmbkv(:,:) = REAL( mbkv_d(:,:), wp ) + CALL lbc_lnk( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp) + mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ; mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 ) + ! + ! !* sign of grad(H) at u- and v-points; zero if grad(H) = 0 + mgrhu(:,:) = 0 ; mgrhv(:,:) = 0 + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + IF( gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN + mgrhu(ji,jj) = INT( SIGN( 1.0_wp, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) ) ) + ENDIF + ! + IF( gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN + mgrhv(ji,jj) = INT( SIGN( 1.0_wp, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) ) ) + ENDIF + END DO ; END DO + ! + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) !* bbl thickness at u- (v-) point; minimum of top & bottom e3u_0 (e3v_0) + e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj )), e3u_0(ji,jj,mbkt(ji,jj)) ) + e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) + END DO ; END DO + CALL lbc_lnk( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp ) ! lateral boundary conditions + ! + ! !* masked diffusive flux coefficients + ahu_bbl_0(:,:) = rn_ahtbbl * e2_e1u(:,:) * e3u_bbl_0(:,:) * umask(:,:,1) + ahv_bbl_0(:,:) = rn_ahtbbl * e1_e2v(:,:) * e3v_bbl_0(:,:) * vmask(:,:,1) + ! + END SUBROUTINE tra_bbl_init + + !!====================================================================== +END MODULE trabbl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tradmp.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tradmp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ed571a55aa2900e6a1963b693d811504dea665b7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tradmp.f90 @@ -0,0 +1,271 @@ + + + + + + + + + + + + + +MODULE tradmp + !!====================================================================== + !! *** MODULE tradmp *** + !! Ocean physics: internal restoring trend on active tracers (T and S) + !!====================================================================== + !! History : OPA ! 1991-03 (O. Marti, G. Madec) Original code + !! ! 1992-06 (M. Imbard) doctor norme + !! ! 1998-07 (M. Imbard, G. Madec) ORCA version + !! 7.0 ! 2001-02 (M. Imbard) add distance to coast, Original code + !! 8.1 ! 2001-02 (G. Madec, E. Durand) cleaning + !! NEMO 1.0 ! 2002-08 (G. Madec, E. Durand) free form + modules + !! 3.2 ! 2009-08 (G. Madec, C. Talandier) DOCTOR norm for namelist parameter + !! 3.3 ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC + !! 3.4 ! 2011-04 (G. Madec, C. Ethe) Merge of dtatem and dtasal + suppression of CPP keys + !! 3.6 ! 2015-06 (T. Graham) read restoring coefficient in a file + !! 3.7 ! 2015-10 (G. Madec) remove useless trends arrays + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_dmp_alloc : allocate tradmp arrays + !! tra_dmp : update the tracer trend with the internal damping + !! tra_dmp_init : initialization, namlist read, parameters control + !!---------------------------------------------------------------------- + USE oce ! ocean: variables + USE dom_oce ! ocean: domain variables + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE zdf_oce ! ocean: vertical physics + USE phycst ! physical constants + USE dtatsd ! data: temperature & salinity + USE zdfmxl ! vertical physics: mixed layer depth + ! + USE in_out_manager ! I/O manager + USE iom ! XIOS + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_dmp ! called by step.F90 + PUBLIC tra_dmp_init ! called by nemogcm.F90 + + ! !!* Namelist namtra_dmp : T & S newtonian damping * + LOGICAL , PUBLIC :: ln_tradmp !: internal damping flag + INTEGER , PUBLIC :: nn_zdmp !: = 0/1/2 flag for damping in the mixed layer + CHARACTER(LEN=200) , PUBLIC :: cn_resto !: name of netcdf file containing restoration coefficient field + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto !: restoring coeff. on T and S (s-1) + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: tradmp.F90 15023 2021-06-18 14:35:25Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION tra_dmp_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION tra_dmp_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( resto(jpi,jpj,jpk), STAT= tra_dmp_alloc ) + ! + CALL mpp_sum ( 'tradmp', tra_dmp_alloc ) + IF( tra_dmp_alloc > 0 ) CALL ctl_warn('tra_dmp_alloc: allocation of arrays failed') + ! + END FUNCTION tra_dmp_alloc + + + SUBROUTINE tra_dmp( kt, Kbb, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_dmp *** + !! + !! ** Purpose : Compute the tracer trend due to a newtonian damping + !! of the tracer field towards given data field and add it to the + !! general tracer trends. + !! + !! ** Method : Newtonian damping towards t_dta and s_dta computed + !! and add to the general tracer trends: + !! ta = ta + resto * (t_dta - tb) + !! sa = sa + resto * (s_dta - sb) + !! The trend is computed either throughout the water column + !! (nlmdmp=0) or in area of weak vertical mixing (nlmdmp=1) or + !! below the well mixed layer (nlmdmp=2) + !! + !! ** Action : - tsa: tracer trends updated with the damping trend + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kbb, Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk,jpts) :: zts_dta + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: zwrk + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_dmp') + ! + IF( l_trdtra .OR. iom_use('hflx_dmp_cea') .OR. iom_use('sflx_dmp_cea') ) THEN !* Save ta and sa trends + ALLOCATE( ztrdts(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk,jpts) ) + DO jn = 1, jpts + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ztrdts(ji,jj,jk,jn) = pts(ji,jj,jk,jn,Krhs) + END DO ; END DO ; END DO + END DO + ENDIF + ! !== input T-S data at kt ==! + CALL dta_tsd( kt, zts_dta ) ! read and interpolates T-S data at kt + ! + SELECT CASE ( nn_zdmp ) !== type of damping ==! + ! + CASE( 0 ) !* newtonian damping throughout the water column *! + DO jn = 1, jpts + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pts(ji,jj,jk,jn,Krhs) = pts(ji,jj,jk,jn,Krhs) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - pts(ji,jj,jk,jn,Kbb) ) + END DO ; END DO ; END DO + END DO + ! + CASE ( 1 ) !* no damping in the turbocline (avt > 5 cm2/s) *! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + IF( avt(ji,jj,jk) <= avt_c ) THEN + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) + pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) + ENDIF + END DO ; END DO ; END DO + ! + CASE ( 2 ) !* no damping in the mixed layer *! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + IF( (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) >= hmlp (ji,jj) ) THEN + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) + pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) + ENDIF + END DO ; END DO ; END DO + ! + END SELECT + ! + ! outputs (clem trunk) + IF( iom_use('hflx_dmp_cea') .OR. iom_use('sflx_dmp_cea') ) THEN + ALLOCATE( zwrk(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) ) ! Needed to handle expressions containing e3t when using 1 or key_linssh + zwrk(:,:,:) = 0._wp + + IF( iom_use('hflx_dmp_cea') ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zwrk(ji,jj,jk) = ( pts(ji,jj,jk,jp_tem,Krhs) - ztrdts(ji,jj,jk,jp_tem) ) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + CALL iom_put('hflx_dmp_cea', SUM( zwrk(:,:,:), dim=3 ) * rcp * rho0 ) ! W/m2 + ENDIF + IF( iom_use('sflx_dmp_cea') ) THEN + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zwrk(ji,jj,jk) = ( pts(ji,jj,jk,jp_sal,Krhs) - ztrdts(ji,jj,jk,jp_sal) ) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + CALL iom_put('sflx_dmp_cea', SUM( zwrk(:,:,:), dim=3 ) * rho0 ) ! g/m2/s + ENDIF + + DEALLOCATE( zwrk ) + ENDIF + ! + IF( l_trdtra ) THEN ! trend diagnostic + ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs) - ztrdts(:,:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) + DEALLOCATE( ztrdts ) + ENDIF + ! ! Control print + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' dmp - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! + IF( ln_timing ) CALL timing_stop('tra_dmp') + ! + END SUBROUTINE tra_dmp + + + SUBROUTINE tra_dmp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_dmp_init *** + !! + !! ** Purpose : Initialization for the newtonian damping + !! + !! ** Method : read the namtra_dmp namelist and check the parameters + !!---------------------------------------------------------------------- + INTEGER :: ios, imask ! local integers + ! + NAMELIST/namtra_dmp/ ln_tradmp, nn_zdmp, cn_resto + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' ) + ! + READ ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' ) + IF(lwm) WRITE ( numond, namtra_dmp ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'tra_dmp_init : T and S newtonian relaxation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtra_dmp : set relaxation parameters' + WRITE(numout,*) ' Apply relaxation or not ln_tradmp = ', ln_tradmp + WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp + WRITE(numout,*) ' Damping file name cn_resto = ', cn_resto + WRITE(numout,*) + ENDIF + ! + IF( ln_tradmp ) THEN + ! ! Allocate arrays + IF( tra_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' ) + ! + SELECT CASE (nn_zdmp) ! Check values of nn_zdmp + CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' tracer damping as specified by mask' + CASE ( 1 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixing layer (kz > 5 cm2/s)' + CASE ( 2 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixed layer' + CASE DEFAULT + CALL ctl_stop('tra_dmp_init : wrong value of nn_zdmp') + END SELECT + ! + !!TG: Initialisation of dtatsd - Would it be better to have dmpdta routine + ! so can damp to something other than intitial conditions files? + !!gm: In principle yes. Nevertheless, we can't anticipate demands that have never been formulated. + IF( .NOT.ln_tsd_dmp ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout, *) ' read T-S data not initialized, we force ln_tsd_dmp=T' + CALL dta_tsd_init( ld_tradmp=ln_tradmp ) ! forces the initialisation of T-S data + ENDIF + ! ! Read in mask from file + CALL iom_open ( cn_resto, imask) + CALL iom_get ( imask, jpdom_auto, 'resto', resto ) + CALL iom_close( imask ) + ENDIF + ! + END SUBROUTINE tra_dmp_init + + !!====================================================================== +END MODULE tradmp diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traisf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traisf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e62d2586f7f8741e9ac98ef7c572b4b6ef353e8b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traisf.f90 @@ -0,0 +1,184 @@ + + + + + + + + + + + + + +MODULE traisf + !!============================================================================== + !! *** MODULE traisf *** + !! Ocean active tracers: ice shelf boundary condition + !!============================================================================== + !! History : 4.0 ! 2019-09 (P. Mathiot) original file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_isf : update the tracer trend at ocean surface + !!---------------------------------------------------------------------- + USE isf_oce ! Ice shelf variables + USE par_oce , ONLY : nijtile, ntile, ntsi, ntei, ntsj, ntej + USE dom_oce ! ocean space domain variables + USE isfutils, ONLY : debug ! debug option + USE timing , ONLY : timing_start, timing_stop ! Timing + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_isf ! routine called by step.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trasbc.F90 10499 2019-01-10 15:12:24Z deazer $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_isf ( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_isf *** + !! + !! ** Purpose : Compute the temperature trend due to the ice shelf melting (qhoce + qhc) + !! + !! ** Action : - update pts(:,:,:,:,Krhs) for cav, par and cpl case + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_isf') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_isf : Ice shelf heat fluxes' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ENDIF + ! + ! cavity case + IF ( ln_isfcav_mlt ) CALL tra_isf_mlt(misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, risf_cav_tsc, risf_cav_tsc_b, pts(:,:,:,:,Krhs)) + ! + ! parametrisation case + IF ( ln_isfpar_mlt ) CALL tra_isf_mlt(misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, risf_par_tsc, risf_par_tsc_b, pts(:,:,:,:,Krhs)) + ! + ! ice sheet coupling case + IF ( ln_isfcpl ) THEN + ! + ! Dynamical stability at start up after change in under ice shelf cavity geometry is achieve by correcting the divergence. + ! This is achieved by applying a volume flux in order to keep the horizontal divergence after remapping + ! the same as at the end of the latest time step. So correction need to be apply at nit000 (euler time step) and + ! half of it at nit000+1 (leap frog time step). + ! in accordance to this, the heat content flux due to injected water need to be added in the temperature and salt trend + ! at time step nit000 and nit000+1 + IF ( kt == nit000 ) CALL tra_isf_cpl(Kmm, risfcpl_tsc , pts(:,:,:,:,Krhs)) + IF ( kt == nit000+1) CALL tra_isf_cpl(Kmm, risfcpl_tsc*0.5_wp, pts(:,:,:,:,Krhs)) + ! + ! ensure 0 trend due to unconservation of the ice shelf coupling + IF ( ln_isfcpl_cons ) CALL tra_isf_cpl(Kmm, risfcpl_cons_tsc, pts(:,:,:,:,Krhs)) + ! + END IF + ! + IF ( ln_isfdebug ) THEN + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only for the full domain + CALL debug('tra_isf: pts(:,:,:,:,Krhs) T', pts(:,:,:,1,Krhs)) + CALL debug('tra_isf: pts(:,:,:,:,Krhs) S', pts(:,:,:,2,Krhs)) + ENDIF + END IF + ! + IF( ln_timing ) CALL timing_stop('tra_isf') + ! + END SUBROUTINE tra_isf + ! + SUBROUTINE tra_isf_mlt(ktop, kbot, phtbl, pfrac, ptsc, ptsc_b, pts) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_isf_mlt *** + !! + !! *** Purpose : Compute the temperature trend due to the ice shelf melting (qhoce + qhc) for cav or par case + !! + !! *** Action :: Update pts(:,:,:,:,Krhs) with the surface boundary condition trend + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: pts + !!---------------------------------------------------------------------- + INTEGER , DIMENSION(jpi,jpj) , INTENT(in ) :: ktop , kbot + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl, pfrac + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc , ptsc_b + !!---------------------------------------------------------------------- + INTEGER :: ji,jj,jk ! loop index + INTEGER :: ikt, ikb ! top and bottom level of the tbl + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: ztc ! total ice shelf tracer trend + !!---------------------------------------------------------------------- + ! + ! compute 2d total trend due to isf + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ztc(ji,jj) = 0.5_wp * ( ptsc(ji,jj,jp_tem) + ptsc_b(ji,jj,jp_tem) ) / phtbl(ji,jj) + END DO ; END DO + ! + ! update pts(:,:,:,:,Krhs) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ! + ikt = ktop(ji,jj) + ikb = kbot(ji,jj) + ! + ! level fully include in the ice shelf boundary layer + DO jk = ikt, ikb - 1 + pts(ji,jj,jk,jp_tem) = pts(ji,jj,jk,jp_tem) + ztc(ji,jj) + END DO + ! + ! level partially include in ice shelf boundary layer + pts(ji,jj,ikb,jp_tem) = pts(ji,jj,ikb,jp_tem) + ztc(ji,jj) * pfrac(ji,jj) + ! + END DO ; END DO + ! + END SUBROUTINE tra_isf_mlt + ! + SUBROUTINE tra_isf_cpl( Kmm, ptsc, ptsa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_isf_cpl *** + !! + !! *** Action :: Update pts(:,:,:,:,Krhs) with the ice shelf coupling trend + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: ptsa + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: ptsc + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk + !!---------------------------------------------------------------------- + ! + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ptsa(ji,jj,jk,jp_tem) = ptsa(ji,jj,jk,jp_tem) + ptsc(ji,jj,jk,jp_tem) * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + ptsa(ji,jj,jk,jp_sal) = ptsa(ji,jj,jk,jp_sal) + ptsc(ji,jj,jk,jp_sal) * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + END SUBROUTINE tra_isf_cpl + ! +END MODULE traisf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traldf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traldf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2c981ceac6fd45b18c701246f92c43a46e9d8be7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traldf.f90 @@ -0,0 +1,141 @@ + + + + + + + + + + + + + +MODULE traldf + !!====================================================================== + !! *** MODULE traldf *** + !! Ocean Active tracers : lateral diffusive trends + !!===================================================================== + !! History : 9.0 ! 2005-11 (G. Madec) Original code + !! NEMO 3.0 ! 2008-01 (C. Ethe, G. Madec) merge TRC-TRA + !! 3.7 ! 2013-12 (G. Madec) remove the optional computation from T & S anomaly profiles and traldf_bilapg + !! - ! 2013-12 (F. Lemarie, G. Madec) triad operator (Griffies) + Method of Stabilizing Correction + !! - ! 2014-01 (G. Madec, S. Masson) restructuration/simplification of lateral diffusive operators + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_ldf : update the tracer trend with the lateral diffusion trend + !! tra_ldf_init : initialization, namelist read, and parameters control + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. + USE ldfslp ! lateral diffusion: iso-neutral slope + USE traldf_lap_blp ! lateral diffusion: laplacian iso-level operator (tra_ldf_lap/_blp routines) + USE traldf_iso ! lateral diffusion: laplacian iso-neutral standard operator (tra_ldf_iso routine ) + USE traldf_triad ! lateral diffusion: laplacian iso-neutral triad operator (tra_ldf_triad routine ) + USE trd_oce ! trends: ocean variables + USE trdtra ! ocean active tracers trends + ! + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_ldf ! called by step.F90 + PUBLIC tra_ldf_init ! called by nemogcm.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traldf.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_ldf( kt, Kbb, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf *** + !! + !! ** Purpose : compute the lateral ocean tracer physics. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + !! + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_ldf') + ! + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) + ENDIF + ! + SELECT CASE ( nldf_tra ) !* compute lateral mixing trend and add it to the general trend + CASE ( np_lap ) ! laplacian: iso-level operator + CALL tra_ldf_lap ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) + CASE ( np_lap_i ) ! laplacian: standard iso-neutral operator (Madec) + CALL tra_ldf_iso ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) + CASE ( np_lap_it ) ! laplacian: triad iso-neutral operator (griffies) + CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) + CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: iso-level & iso-neutral operators + CALL tra_ldf_blp ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, nldf_tra ) + END SELECT + ! + IF( l_trdtra ) THEN !* save the horizontal diffusive trends for further diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ldf, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ldf, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + ENDIF + ! !* print mean trends (used for debugging) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! + IF( ln_timing ) CALL timing_stop('tra_ldf') + ! + END SUBROUTINE tra_ldf + + + SUBROUTINE tra_ldf_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf_init *** + !! + !! ** Purpose : Choice of the operator for the lateral tracer diffusion + !! + !! ** Method : set nldf_tra from the namtra_ldf logicals + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ierr ! temporary integers + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN !== Namelist print ==! + WRITE(numout,*) + WRITE(numout,*) 'tra_ldf_init : lateral tracer diffusive operator' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtra_ldf: already read in ldftra module' + WRITE(numout,*) ' see ldf_tra_init report for lateral mixing parameters' + WRITE(numout,*) + ! + SELECT CASE( nldf_tra ) ! print the choice of operator + 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 + ENDIF + ! + END SUBROUTINE tra_ldf_init + + !!====================================================================== +END MODULE traldf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traldf_iso.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traldf_iso.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e1e5bdcd7fae4a6ab329111b6609c6f86a06d74d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traldf_iso.f90 @@ -0,0 +1,436 @@ + + + + + + + + + + + + + +MODULE traldf_iso + !!====================================================================== + !! *** MODULE traldf_iso *** + !! Ocean tracers: horizontal component of the lateral tracer mixing trend + !!====================================================================== + !! History : OPA ! 1994-08 (G. Madec, M. Imbard) + !! 8.0 ! 1997-05 (G. Madec) split into traldf and trazdf + !! NEMO ! 2002-08 (G. Madec) Free form, F90 + !! 1.0 ! 2005-11 (G. Madec) merge traldf and trazdf :-) + !! 3.3 ! 2010-09 (C. Ethe, G. Madec) Merge TRA-TRC + !! 3.7 ! 2014-01 (G. Madec, S. Masson) restructuration/simplification of aht/aeiv specification + !! - ! 2014-02 (F. Lemarie, G. Madec) triad operator (Griffies) + Method of Stabilizing Correction + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_ldf_iso : update the tracer trend with the horizontal component of a iso-neutral laplacian operator + !! and with the vertical part of the isopycnal or geopotential s-coord. operator + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domutl, ONLY : is_tile + USE trc_oce ! share passive tracers/Ocean variables + USE zdf_oce ! ocean vertical physics + USE ldftra ! lateral diffusion: tracer eddy coefficients + USE ldfslp ! iso-neutral slopes + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE phycst ! physical constants + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_ldf_iso ! routine called by step.F90 + + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat transport + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traldf_iso.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_ldf_iso( kt, Kmm, kit000, cdtype, pahu, pahv, & + & pgu , pgv , pgui, pgvi, & + & pt, pt2, pt_rhs, kjpt, kpass ) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend + !! + CALL tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), & + & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & + & pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) + END SUBROUTINE tra_ldf_iso + + + SUBROUTINE tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, & + & pgu , pgv , ktg , pgui, pgvi, ktgi, & + & pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf_iso *** + !! + !! ** Purpose : Compute the before horizontal tracer (t & s) diffusive + !! trend for a laplacian tensor (ezxcept the dz[ dz[.] ] term) and + !! add it to the general trend of tracer equation. + !! + !! ** Method : The horizontal component of the lateral diffusive trends + !! is provided by a 2nd order operator rotated along neural or geopo- + !! tential surfaces to which an eddy induced advection can be added + !! It is computed using before fields (forward in time) and isopyc- + !! nal or geopotential slopes computed in routine ldfslp. + !! + !! 1st part : masked horizontal derivative of T ( di[ t ] ) + !! ======== with partial cell update if ln_zps=T + !! with top cell update if ln_isfcav + !! + !! 2nd part : horizontal fluxes of the lateral mixing operator + !! ======== + !! zftu = pahu e2u*e3u/e1u di[ tb ] + !! - pahu e2u*uslp dk[ mi(mk(tb)) ] + !! zftv = pahv e1v*e3v/e2v dj[ tb ] + !! - pahv e2u*vslp dk[ mj(mk(tb)) ] + !! take the horizontal divergence of the fluxes: + !! difft = 1/(e1e2t*e3t) { di-1[ zftu ] + dj-1[ zftv ] } + !! Add this trend to the general trend (ta,sa): + !! ta = ta + difft + !! + !! 3rd part: vertical trends of the lateral mixing operator + !! ======== (excluding the vertical flux proportional to dk[t] ) + !! vertical fluxes associated with the rotated lateral mixing: + !! zftw = - { mi(mk(pahu)) * e2t*wslpi di[ mi(mk(tb)) ] + !! + mj(mk(pahv)) * e1t*wslpj dj[ mj(mk(tb)) ] } + !! take the horizontal divergence of the fluxes: + !! difft = 1/(e1e2t*e3t) dk[ zftw ] + !! Add this trend to the general trend (ta,sa): + !! pt_rhs = pt_rhs + difft + !! + !! ** Action : Update pt_rhs arrays with the before rotated diffusion + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktah+1:,(ntsj-nn_hls-1)*ktah+1: ,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktg+1:,(ntsj-nn_hls-1)*ktg+1: ,:), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktgi+1:,(ntsj-nn_hls-1)*ktgi+1: ,:), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktt+1:,(ntsj-nn_hls-1)*ktt+1: ,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktt2+1:,(ntsj-nn_hls-1)*ktt2+1: ,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktt_rhs+1:,(ntsj-nn_hls-1)*ktt_rhs+1:,:,:), INTENT(inout) :: pt_rhs ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ikt + INTEGER :: ierr, iij ! local integer + REAL(wp) :: zmsku, zahu_w, zabe1, zcof1, zcoef3 ! local scalars + REAL(wp) :: zmskv, zahv_w, zabe2, zcof2, zcoef4 ! - - + REAL(wp) :: zcoef0, ze3w_2, zsign ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zdkt, zdk1t, z2d + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw + !!---------------------------------------------------------------------- + ! + IF( kpass == 1 .AND. kt == kit000 ) THEN + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + akz (ji,jj,jk) = 0._wp + ah_wslp2(ji,jj,jk) = 0._wp + END DO ; END DO ; END DO + ENDIF + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + l_hst = .FALSE. + l_ptr = .FALSE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + ! Define pt_rhs halo points for multi-point haloes in bilaplacian case + IF( nldf_tra == np_blp_i .AND. kpass == 1 ) THEN ; iij = nn_hls + ELSE ; iij = 1 + ENDIF + + ! + IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign (eddy diffusivity >0) + ELSE ; zsign = -1._wp + ENDIF + + !!---------------------------------------------------------------------- + !! 0 - calculate ah_wslp2 and akz + !!---------------------------------------------------------------------- + ! + IF( kpass == 1 ) THEN !== first pass only ==! + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! + zmsku = wmask(ji,jj,jk) / MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) & + & + umask(ji-1,jj,jk-1) + umask(ji ,jj,jk) , 1._wp ) + zmskv = wmask(ji,jj,jk) / MAX( vmask(ji,jj ,jk-1) + vmask(ji,jj-1,jk) & + & + vmask(ji,jj-1,jk-1) + vmask(ji,jj ,jk) , 1._wp ) + ! + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zahu_w = ( ( pahu(ji ,jj,jk-1) + pahu(ji-1,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( pahu(ji-1,jj,jk-1) + pahu(ji ,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * zmsku + zahv_w = ( ( pahv(ji,jj ,jk-1) + pahv(ji,jj-1,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( pahv(ji,jj-1,jk-1) + pahv(ji,jj ,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * zmskv + ! + ah_wslp2(ji,jj,jk) = zahu_w * wslpi(ji,jj,jk) * wslpi(ji,jj,jk) & + & + zahv_w * wslpj(ji,jj,jk) * wslpj(ji,jj,jk) + END DO ; END DO ; END DO + ! + IF( ln_traldf_msc ) THEN ! stabilizing vertical diffusivity coefficient + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + akz(ji,jj,jk) = 0.25_wp * ( & + & ( ( pahu(ji ,jj,jk) + pahu(ji ,jj,jk-1) ) / ( e1u(ji ,jj) * e1u(ji ,jj) ) & + & + ( pahu(ji-1,jj,jk) + pahu(ji-1,jj,jk-1) ) / ( e1u(ji-1,jj) * e1u(ji-1,jj) ) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( ( pahv(ji,jj ,jk) + pahv(ji,jj ,jk-1) ) / ( e2v(ji,jj ) * e2v(ji,jj ) ) & + & + ( pahv(ji,jj-1,jk) + pahv(ji,jj-1,jk-1) ) / ( e2v(ji,jj-1) * e2v(ji,jj-1) ) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) + END DO ; END DO ; END DO + ! + IF( ln_traldf_blp ) THEN ! bilaplacian operator + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + akz(ji,jj,jk) = 16._wp & + & * ah_wslp2 (ji,jj,jk) & + & * ( akz (ji,jj,jk) & + & + ah_wslp2(ji,jj,jk) & + & / ( (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) ) + END DO ; END DO ; END DO + ELSEIF( ln_traldf_lap ) THEN ! laplacian operator + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ze3w_2 = (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + zcoef0 = rDt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 ) + akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * r1_Dt + END DO ; END DO ; END DO + ENDIF + ! + ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + akz(ji,jj,jk) = ah_wslp2(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ENDIF + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! + !!---------------------------------------------------------------------- + !! I - masked horizontal derivative + !!---------------------------------------------------------------------- + zdit(:,:,:) = 0._wp + zdjt(:,:,:) = 0._wp + + ! Horizontal tracer gradient + DO jk = 1, jpkm1 ; DO jj = ntsj-( iij), ntej+( iij-1) ; DO ji = ntsi-( iij), ntei+( iij-1) + zdit(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) + zdjt(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) + END DO ; END DO ; END DO + IF( ln_zps ) THEN ! botton and surface ocean correction of the horizontal gradient + DO jj = ntsj-( iij), ntej+( iij-1 ) ; DO ji = ntsi-( iij), ntei+( iij-1) ! bottom correction (partial bottom cell) + zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) + zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) + END DO ; END DO + IF( ln_isfcav ) THEN ! first wet level beneath a cavity + DO jj = ntsj-( iij), ntej+( iij-1 ) ; DO ji = ntsi-( iij), ntei+( iij-1) + IF( miku(ji,jj) > 1 ) zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn) + IF( mikv(ji,jj) > 1 ) zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn) + END DO ; END DO + ENDIF + ENDIF + ! + !!---------------------------------------------------------------------- + !! II - horizontal trend (full) + !!---------------------------------------------------------------------- + ! + DO jk = 1, jpkm1 ! Horizontal slab + ! + DO jj = ntsj-( iij), ntej+( iij ) ; DO ji = ntsi-( iij), ntei+( iij) + ! !== Vertical tracer gradient + zdk1t(ji,jj) = ( pt(ji,jj,jk,jn) - pt(ji,jj,jk+1,jn) ) * wmask(ji,jj,jk+1) ! level jk+1 + ! + IF( jk == 1 ) THEN ; zdkt(ji,jj) = zdk1t(ji,jj) ! surface: zdkt(jk=1)=zdkt(jk=2) + ELSE ; zdkt(ji,jj) = ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) * wmask(ji,jj,jk) + ENDIF + END DO ; END DO + ! + DO jj = ntsj-( iij), ntej+( iij-1 ) ; DO ji = ntsi-( iij), ntei+( iij-1) !== Horizontal fluxes + zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + ! + zmsku = 1. / MAX( wmask(ji+1,jj,jk ) + wmask(ji,jj,jk+1) & + & + wmask(ji+1,jj,jk+1) + wmask(ji,jj,jk ), 1. ) + ! + zmskv = 1. / MAX( wmask(ji,jj+1,jk ) + wmask(ji,jj,jk+1) & + & + wmask(ji,jj+1,jk+1) + wmask(ji,jj,jk ), 1. ) + ! + zcof1 = - pahu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku + zcof2 = - pahv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv + ! + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zftu(ji,jj,jk ) = ( zabe1 * zdit(ji,jj,jk) & + & + zcof1 * ( ( zdkt (ji+1,jj) + zdk1t(ji,jj) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zdk1t(ji+1,jj) + zdkt (ji,jj) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) ) * umask(ji,jj,jk) + zftv(ji,jj,jk) = ( zabe2 * zdjt(ji,jj,jk) & + & + zcof2 * ( ( zdkt (ji,jj+1) + zdk1t(ji,jj) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zdk1t(ji,jj+1) + zdkt (ji,jj) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) ) * vmask(ji,jj,jk) + END DO ; END DO + ! + DO jj = ntsj-( iij-1), ntej+( iij-1 ) ; DO ji = ntsi-( iij-1), ntei+( iij-1) !== horizontal divergence and add to pta + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & + & + zsign * ( ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zftv(ji,jj,jk) - zftv(ji,jj-1,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO + END DO ! End of slab + + !!---------------------------------------------------------------------- + !! III - vertical trend (full) + !!---------------------------------------------------------------------- + ! + ! Vertical fluxes + ! --------------- + ! ! Surface and bottom vertical fluxes set to zero + ztfw(:,:, 1 ) = 0._wp ; ztfw(:,:,jpk) = 0._wp + + DO jk = 2, jpkm1 ; DO jj = ntsj-( iij-1), ntej+( iij-1) ; DO ji = ntsi-( iij-1), ntei+( iij-1) ! interior (2=0) + ELSE ; zsign = -1._wp + ENDIF + + DO jk = 1, jpkm1 ; DO jj = ntsj-( iij), ntej+( iij-1) ; DO ji = ntsi-( iij), ntei+( iij-1) !== First derivative (gradient) ==! + zaheeu(ji,jj,jk) = zsign * pahu(ji,jj,jk) * e2_e1u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) !!gm * umask(ji,jj,jk) pah masked! + zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) !!gm * vmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! ! =========== ! + DO jn = 1, kjpt ! tracer loop ! + ! ! =========== ! + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( iij), ntej+( iij-1) ; DO ji = ntsi-( iij), ntei+( iij-1) !== First derivative (gradient) ==! + ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) + ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) + END DO ; END DO ; END DO + IF( ln_zps ) THEN ! set gradient at bottom/top ocean level + DO jj = ntsj-( iij), ntej+( iij-1 ) ; DO ji = ntsi-( iij), ntei+( iij-1) ! bottom + ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) + ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) + END DO ; END DO + IF( ln_isfcav ) THEN ! top in ocean cavities only + DO jj = ntsj-( iij), ntej+( iij-1 ) ; DO ji = ntsi-( iij), ntei+( iij-1) + IF( miku(ji,jj) > 1 ) ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn) + IF( mikv(ji,jj) > 1 ) ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn) + END DO ; END DO + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( iij-1), ntej+( iij-1) ; DO ji = ntsi-( iij-1), ntei+( iij-1) !== Second derivative (divergence) added to the general tracer trends ==! + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + ( ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) / ( e1e2t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) ) + END DO ; END DO ; END DO + ! + ! !== "Poleward" diffusive heat or salt transports ==! + IF( ( kpass == 1 .AND. .NOT.ln_traldf_blp ) .OR. & !== first pass only ( laplacian) ==! + ( kpass == 2 .AND. ln_traldf_blp ) ) THEN !== 2nd pass only (bilaplacian) ==! + + IF( l_ptr ) CALL dia_ptr_hst( jn, 'ldf', -ztv(:,:,:) ) + IF( l_hst ) CALL dia_ar5_hst( jn, 'ldf', -ztu(:,:,:), -ztv(:,:,:) ) + ENDIF + ! ! ================== + END DO ! end of tracer loop + ! ! ================== + ! + END SUBROUTINE tra_ldf_lap_t + + + SUBROUTINE tra_ldf_blp( kt, Kmm, kit000, cdtype, pahu, pahv , & + & pgu , pgv , pgui, pgvi, & + & pt , pt_rhs, kjpt, kldf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf_blp *** + !! + !! ** Purpose : Compute the before lateral tracer diffusive + !! trend and add it to the general trend of tracer equation. + !! + !! ** Method : The lateral diffusive trends is provided by a bilaplacian + !! operator applied to before field (forward in time). + !! It is computed by two successive calls to laplacian routine + !! + !! ** Action : pta updated with the before rotated bilaplacian diffusion + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kldf ! type of operator used + INTEGER , INTENT(in ) :: Kmm ! ocean time level indices + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before and now tracer fields + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk,kjpt) :: zlap ! laplacian at t-point + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls), kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points) + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls), kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points) + !!--------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 .AND. lwp ) THEN + WRITE(numout,*) + SELECT CASE ( kldf ) + CASE ( np_blp ) ; WRITE(numout,*) 'tra_ldf_blp : iso-level bilaplacian operator on ', cdtype + CASE ( np_blp_i ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)' + CASE ( np_blp_it ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)' + END SELECT + WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + + zlap(:,:,:,:) = 0._wp + ! + SELECT CASE ( kldf ) !== 1st laplacian applied to pt (output in zlap) ==! + ! + CASE ( np_blp ) ! iso-level bilaplacian + CALL tra_ldf_lap ( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt, zlap, kjpt, 1 ) + CASE ( np_blp_i ) ! rotated bilaplacian : standard operator (Madec) + CALL tra_ldf_iso ( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt, pt, zlap, kjpt, 1 ) + CASE ( np_blp_it ) ! rotated bilaplacian : triad operator (griffies) + CALL tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt, pt, zlap, kjpt, 1 ) + END SELECT + ! + IF (nn_hls==1) CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_dp ) ! Lateral boundary conditions (unchanged sign) + ! ! Partial top/bottom cell: GRADh( zlap ) + IF( ln_isfcav .AND. ln_zps ) THEN ; CALL zps_hde_isf( kt, Kmm, kjpt, zlap, zglu, zglv, zgui, zgvi ) ! both top & bottom + ELSEIF( ln_zps ) THEN ; CALL zps_hde ( kt, Kmm, kjpt, zlap, zglu, zglv ) ! only bottom + ENDIF + ! + SELECT CASE ( kldf ) !== 2nd laplacian applied to zlap (output in pt_rhs) ==! + ! + CASE ( np_blp ) ! iso-level bilaplacian + CALL tra_ldf_lap ( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt_rhs, kjpt, 2 ) + CASE ( np_blp_i ) ! rotated bilaplacian : standard operator (Madec) + CALL tra_ldf_iso ( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt , pt_rhs, kjpt, 2 ) + CASE ( np_blp_it ) ! rotated bilaplacian : triad operator (griffies) + CALL tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt , pt_rhs, kjpt, 2 ) + END SELECT + ! + END SUBROUTINE tra_ldf_blp + + !!============================================================================== +END MODULE traldf_lap_blp diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traldf_triad.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traldf_triad.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fa006ccbb234afaea85a9d3a9af7e2afe2353405 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traldf_triad.f90 @@ -0,0 +1,534 @@ + + + + + + + + + + + + + +MODULE traldf_triad + !!====================================================================== + !! *** MODULE traldf_triad *** + !! Ocean tracers: horizontal component of the lateral tracer mixing trend + !!====================================================================== + !! History : 3.3 ! 2010-10 (G. Nurser, C. Harris, G. Madec) Griffies operator (original code) + !! 3.7 ! 2013-12 (F. Lemarie, G. Madec) triad operator (Griffies) + Method of Stabilizing Correction + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_ldf_triad : update the tracer trend with the iso-neutral laplacian triad-operator + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domutl, ONLY : is_tile + USE phycst ! physical constants + USE trc_oce ! share passive tracers/Ocean variables + USE zdf_oce ! ocean vertical physics + USE ldftra ! lateral physics: eddy diffusivity + USE ldfslp ! lateral physics: iso-neutral slopes + USE traldf_iso ! lateral diffusion (Madec operator) (tra_ldf_iso routine) + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + USE zpshde ! partial step: hor. derivative (zps_hde routine) + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_ldf_triad ! routine called by traldf.F90 + + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat transport + + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traldf_triad.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, & + & pgu , pgv , pgui, pgvi, & + & pt, pt2, pt_rhs, kjpt, kpass ) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + INTEGER , INTENT(in ) :: Kmm ! ocean time level indices + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend + !! + CALL tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), & + & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & + & pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) + END SUBROUTINE tra_ldf_triad + + + SUBROUTINE tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, & + & pgu , pgv , ktg , pgui, pgvi, ktgi, & + & pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf_triad *** + !! + !! ** Purpose : Compute the before horizontal tracer (t & s) diffusive + !! trend for a laplacian tensor (ezxcept the dz[ dz[.] ] term) and + !! add it to the general trend of tracer equation. + !! + !! ** Method : The horizontal component of the lateral diffusive trends + !! is provided by a 2nd order operator rotated along neural or geopo- + !! tential surfaces to which an eddy induced advection can be added + !! It is computed using before fields (forward in time) and isopyc- + !! nal or geopotential slopes computed in routine ldfslp. + !! + !! see documentation for the desciption + !! + !! ** Action : pt_rhs updated with the before rotated diffusion + !! ah_wslp2 .... + !! akz stabilizing vertical diffusivity coefficient (used in trazdf_imp) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + INTEGER , INTENT(in) :: Kmm ! ocean time level indices + INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktah+1:,(ntsj-nn_hls-1)*ktah+1:, :) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktg+1:,(ntsj-nn_hls-1)*ktg+1:, :), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktgi+1:,(ntsj-nn_hls-1)*ktgi+1:, :), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktt+1:,(ntsj-nn_hls-1)*ktt+1:, :,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktt2+1:,(ntsj-nn_hls-1)*ktt2+1:, :,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktt_rhs+1:,(ntsj-nn_hls-1)*ktt_rhs+1:,:,:), INTENT(inout) :: pt_rhs ! tracer trend + ! + INTEGER :: ji, jj, jk, jn, kp, iij ! dummy loop indices + REAL(wp) :: zcoef0, ze3w_2, zsign ! - - + ! + REAL(wp) :: zslope2, zbu, zbv, zbu1, zbv1, zslope21, zah, zah1, zah_ip1, zah_jp1, zbu_ip1, zbv_jp1 + REAL(wp) :: ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt, zdyt_jp1, ze3wr_jp1, zdzt_jp1, zah_slp1, zah_slp_jp1, zaei_slp_jp1 + REAL(wp) :: zah_slp, zaei_slp, zdxt_ip1, ze3wr_ip1, zdzt_ip1, zah_slp_ip1, zaei_slp_ip1, zaei_slp1 + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),0:1) :: zdkt3d ! vertical tracer gradient at 2 levels + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls) ) :: z2d ! 2D workspace + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D - + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kpass == 1 .AND. kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_ldf_triad : rotated laplacian diffusion operator on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! + l_hst = .FALSE. + l_ptr = .FALSE. + IF( cdtype == 'TRA' ) THEN + IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf') ) l_ptr = .TRUE. + IF( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) l_hst = .TRUE. + ENDIF + ENDIF + ! + ! Define pt_rhs halo points for multi-point haloes in bilaplacian case + IF( nldf_tra == np_blp_it .AND. kpass == 1 ) THEN ; iij = nn_hls + ELSE ; iij = 1 + ENDIF + + ! + IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign (eddy diffusivity >0) + ELSE ; zsign = -1._wp + ENDIF + ! + !!---------------------------------------------------------------------- + !! 0 - calculate ah_wslp2, akz, and optionally zpsi_uw, zpsi_vw + !!---------------------------------------------------------------------- + ! + IF( kpass == 1 ) THEN !== first pass only and whatever the tracer is ==! + ! + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + akz (ji,jj,jk) = 0._wp + ah_wslp2(ji,jj,jk) = 0._wp + END DO ; END DO ; END DO + ! + DO kp = 0, 1 ! i-k triads + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ze3wr = 1._wp / (e3w_0(ji,jj,jk+kp)*(1._wp+r3t(ji,jj,Kmm))) + zbu = e1e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + zbu1 = e1e2u(ji-1,jj) * (e3u_0(ji-1,jj,jk)*(1._wp+r3u(ji-1,jj,Kmm)*umask(ji-1,jj,jk))) + zah = 0.25_wp * pahu(ji,jj,jk) + zah1 = 0.25_wp * pahu(ji-1,jj,jk) + ! Subtract s-coordinate slope at t-points to give slope rel to s-surfaces (do this by *adding* gradient of depth) + zslope2 = triadi_g(ji,jj,jk,1,kp) + ( (gdept_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kmm))) - (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) + zslope2 = zslope2 *zslope2 + zslope21 = triadi_g(ji,jj,jk,0,kp) + ( (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji-1,jj,jk)*(1._wp+r3t(ji-1,jj,Kmm))) ) * r1_e1u(ji-1,jj) * umask(ji-1,jj,jk+kp) + zslope21 = zslope21 *zslope21 + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + ( zah * zbu * ze3wr * r1_e1e2t(ji,jj) * zslope2 & + & + zah1 * zbu1 * ze3wr * r1_e1e2t(ji,jj) * zslope21 & + & ) ! bracket for halo 1 - halo 2 compatibility + akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + ( zah * r1_e1u(ji,jj) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) & + + zah1 * r1_e1u(ji-1,jj) * r1_e1u(ji-1,jj) * umask(ji-1,jj,jk+kp) & + & ) ! bracket for halo 1 - halo 2 compatibility + END DO ; END DO ; END DO + END DO + ! + DO kp = 0, 1 ! j-k triads + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ze3wr = 1.0_wp / (e3w_0(ji,jj,jk+kp)*(1._wp+r3t(ji,jj,Kmm))) + zbv = e1e2v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + zbv1 = e1e2v(ji,jj-1) * (e3v_0(ji,jj-1,jk)*(1._wp+r3v(ji,jj-1,Kmm)*vmask(ji,jj-1,jk))) + zah = 0.25_wp * pahv(ji,jj,jk) + zah1 = 0.25_wp * pahv(ji,jj-1,jk) + ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces + ! (do this by *adding* gradient of depth) + zslope2 = triadj_g(ji,jj,jk,1,kp) + ( (gdept_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kmm))) - (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) + zslope2 = zslope2 * zslope2 + zslope21 = triadj_g(ji,jj,jk,0,kp) + ( (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj-1,jk)*(1._wp+r3t(ji,jj-1,Kmm))) ) * r1_e2v(ji,jj-1) * vmask(ji,jj-1,jk+kp) + zslope21 = zslope21 * zslope21 + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + ( zah * zbv * ze3wr * r1_e1e2t(ji,jj) * zslope2 & + & + zah1 * zbv1 * ze3wr * r1_e1e2t(ji,jj) * zslope21 & + & ) ! bracket for halo 1 - halo 2 compatibility + akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + ( zah * r1_e2v(ji,jj) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) & + & + zah1 * r1_e2v(ji,jj-1) * r1_e2v(ji,jj-1) * vmask(ji,jj-1,jk+kp) & + & ) ! bracket for halo 1 - halo 2 compatibility + END DO ; END DO ; END DO + END DO + ! + IF( ln_traldf_msc ) THEN ! stabilizing vertical diffusivity coefficient + ! + IF( ln_traldf_blp ) THEN ! bilaplacian operator + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + akz(ji,jj,jk) = 16._wp & + & * ah_wslp2 (ji,jj,jk) & + & * ( akz (ji,jj,jk) & + & + ah_wslp2(ji,jj,jk) & + & / ( (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) ) + END DO ; END DO ; END DO + ELSEIF( ln_traldf_lap ) THEN ! laplacian operator + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ze3w_2 = (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + zcoef0 = rDt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 ) + akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * r1_Dt + END DO ; END DO ; END DO + ENDIF + ! + ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + akz(ji,jj,jk) = ah_wslp2(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ! + IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) THEN + zpsi_uw(:,:,:) = 0._wp + zpsi_vw(:,:,:) = 0._wp + + DO kp = 0, 1 + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp) & + & + ( 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * triadi_g(ji,jj,jk,1,kp) & + & + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * triadi_g(ji+1,jj,jk,0,kp) & + & ) ! bracket for halo 1 - halo 2 compatibility + zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp) & + & + ( 0.25_wp * aeiv(ji,jj,jk) * e1v(ji,jj) * triadj_g(ji,jj,jk,1,kp) & + & + 0.25_wp * aeiv(ji,jj,jk) * e1v(ji,jj) * triadj_g(ji,jj+1,jk,0,kp) & + & ) ! bracket for halo 1 - halo 2 compatibility + END DO ; END DO ; END DO + END DO + CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) + ENDIF + ! + ENDIF !== end 1st pass only ==! + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! Zero fluxes for each tracer +!!gm this should probably be done outside the jn loop + ztfw(:,:,:) = 0._wp + zftu(:,:,:) = 0._wp + zftv(:,:,:) = 0._wp + zdit(:,:,:) = 0._wp + zdjt(:,:,:) = 0._wp + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( iij), ntej+( iij-1) ; DO ji = ntsi-( iij), ntei+( iij-1) !== before lateral T & S gradients at T-level jk ==! + zdit(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) + zdjt(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) + END DO ; END DO ; END DO + IF( ln_zps .AND. l_grad_zps ) THEN ! partial steps: correction at top/bottom ocean level + DO jj = ntsj-( iij), ntej+( iij-1 ) ; DO ji = ntsi-( iij), ntei+( iij-1) ! bottom level + zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) + zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) + END DO ; END DO + IF( ln_isfcav ) THEN ! top level (ocean cavities only) + DO jj = ntsj-( iij), ntej+( iij-1 ) ; DO ji = ntsi-( iij), ntei+( iij-1) + IF( miku(ji,jj) > 1 ) zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn) + IF( mikv(ji,jj) > 1 ) zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn) + END DO ; END DO + ENDIF + ENDIF + ! + !!---------------------------------------------------------------------- + !! II - horizontal trend (full) + !!---------------------------------------------------------------------- + ! + DO jk = 1, jpkm1 + ! !== Vertical tracer gradient at level jk and jk+1 + DO jj = ntsj-( iij), ntej+( iij ) ; DO ji = ntsi-( iij), ntei+( iij) + zdkt3d(ji,jj,1) = ( pt(ji,jj,jk,jn) - pt(ji,jj,jk+1,jn) ) * tmask(ji,jj,jk+1) + END DO ; END DO + ! + ! ! surface boundary condition: zdkt3d(jk=0)=zdkt3d(jk=1) + IF( jk == 1 ) THEN ; zdkt3d(:,:,0) = zdkt3d(:,:,1) + ELSE + DO jj = ntsj-( iij), ntej+( iij ) ; DO ji = ntsi-( iij), ntei+( iij) + zdkt3d(ji,jj,0) = ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) * tmask(ji,jj,jk) + END DO ; END DO + ENDIF + ! + zaei_slp = 0._wp + zaei_slp_ip1 = 0._wp + zaei_slp_jp1 = 0._wp + zaei_slp1 = 0._wp + ! + IF( ln_botmix_triad ) THEN + DO kp = 0, 1 !== Horizontal & vertical fluxes + DO jj = ntsj-( iij), ntej+( iij-1 ) ; DO ji = ntsi-( iij), ntei+( iij-1) + ze1ur = r1_e1u(ji,jj) + zdxt = zdit(ji,jj,jk) * ze1ur + zdxt_ip1 = zdit(ji+1,jj,jk) * r1_e1u(ji+1,jj) + ze3wr = 1._wp / (e3w_0(ji,jj,jk+kp)*(1._wp+r3t(ji,jj,Kmm))) + ze3wr_ip1 = 1._wp / (e3w_0(ji+1,jj,jk+kp)*(1._wp+r3t(ji+1,jj,Kmm))) + zdzt = zdkt3d(ji,jj,kp) * ze3wr + zdzt_ip1 = zdkt3d(ji+1,jj,kp) * ze3wr_ip1 + ! + zbu = 0.25_wp * e1e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + zbu_ip1 = 0.25_wp * e1e2u(ji+1,jj) * (e3u_0(ji+1,jj,jk)*(1._wp+r3u(ji+1,jj,Kmm)*umask(ji+1,jj,jk))) + ! ln_botmix_triad is .T. don't mask zah for bottom half cells !!gm ????? ahu is masked.... + zah = pahu(ji,jj,jk) + zah_ip1 = pahu(ji+1,jj,jk) + zah_slp = zah * triadi(ji,jj,jk,1,kp) + zah_slp_ip1 = zah_ip1 * triadi(ji+1,jj,jk,1,kp) + zah_slp1 = zah * triadi(ji+1,jj,jk,0,kp) + IF( ln_ldfeiv ) THEN + zaei_slp = aeiu(ji,jj,jk) * triadi_g(ji,jj,jk,1,kp) + zaei_slp_ip1 = aeiu(ji+1,jj,jk) * triadi_g(ji+1,jj,jk,1,kp) + zaei_slp1 = aeiu(ji,jj,jk) * triadi_g(ji+1,jj,jk,0,kp) + ENDIF + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zftu(ji ,jj,jk ) = zftu(ji ,jj,jk ) & + & - ( ( zah * zdxt + ( zah_slp - zaei_slp ) * zdzt ) * zbu * ze1ur & + & + ( zah * zdxt + zah_slp1 * zdzt_ip1 - zaei_slp1 * zdzt_ip1 ) * zbu * ze1ur & + & ) ! bracket for halo 1 - halo 2 compatibility + ztfw(ji+1,jj,jk+kp) = ztfw(ji+1,jj,jk+kp) & + & - ( (zah_slp_ip1 + zaei_slp_ip1) * zdxt_ip1 * zbu_ip1 * ze3wr_ip1 & + & + ( zah_slp1 + zaei_slp1) * zdxt * zbu * ze3wr_ip1 & + & ) ! bracket for halo 1 - halo 2 compatibility + END DO ; END DO + END DO + ! + DO kp = 0, 1 + DO jj = ntsj-( iij), ntej+( iij-1 ) ; DO ji = ntsi-( iij), ntei+( iij-1) + ze2vr = r1_e2v(ji,jj) + zdyt = zdjt(ji,jj,jk) * ze2vr + zdyt_jp1 = zdjt(ji,jj+1,jk) * r1_e2v(ji,jj+1) + ze3wr = 1._wp / (e3w_0(ji,jj,jk+kp)*(1._wp+r3t(ji,jj,Kmm))) + ze3wr_jp1 = 1._wp / (e3w_0(ji,jj+1,jk+kp)*(1._wp+r3t(ji,jj+1,Kmm))) + zdzt = zdkt3d(ji,jj,kp) * ze3wr + zdzt_jp1 = zdkt3d(ji,jj+1,kp) * ze3wr_jp1 + zbv = 0.25_wp * e1e2v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + zbv_jp1 = 0.25_wp * e1e2v(ji,jj+1) * (e3v_0(ji,jj+1,jk)*(1._wp+r3v(ji,jj+1,Kmm)*vmask(ji,jj+1,jk))) + ! ln_botmix_triad is .T. don't mask zah for bottom half cells !!gm ????? ahu is masked.... + zah = pahv(ji,jj,jk) ! pahv(ji,jj+jp,jk) ???? + zah_jp1 = pahv(ji,jj+1,jk) + zah_slp = zah * triadj(ji,jj,jk,1,kp) + zah_slp1 = zah * triadj(ji,jj+1,jk,0,kp) + zah_slp_jp1 = zah_jp1 * triadj(ji,jj+1,jk,1,kp) + IF( ln_ldfeiv ) THEN + zaei_slp = aeiv(ji,jj,jk) * triadj_g(ji,jj,jk,1,kp) + zaei_slp_jp1 = aeiv(ji,jj+1,jk) * triadj_g(ji,jj+1,jk,1,kp) + zaei_slp1 = aeiv(ji,jj,jk) * triadj_g(ji,jj+1,jk,0,kp) + ENDIF + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zftv(ji,jj ,jk ) = zftv(ji,jj ,jk ) & + & - ( ( zah * zdyt + ( zah_slp - zaei_slp ) * zdzt ) * zbv * ze2vr & + & + ( zah * zdyt + zah_slp1 * zdzt_jp1 - zaei_slp1 * zdzt_jp1 ) * zbv * ze2vr & + & ) ! bracket for halo 1 - halo 2 compatibility + ztfw(ji,jj+1,jk+kp) = ztfw(ji,jj+1,jk+kp) & + & - ( ( zah_slp_jp1 + zaei_slp_jp1) * zdyt_jp1 * zbv_jp1 * ze3wr_jp1 & + & + ( zah_slp1 + zaei_slp1) * zdyt * zbv * ze3wr_jp1 & + & ) ! bracket for halo 1 - halo 2 compatibility + END DO ; END DO + END DO + ! + ELSE + ! + DO kp = 0, 1 !== Horizontal & vertical fluxes + DO jj = ntsj-( iij), ntej+( iij-1 ) ; DO ji = ntsi-( iij), ntei+( iij-1) + ze1ur = r1_e1u(ji,jj) + zdxt = zdit(ji,jj,jk) * ze1ur + zdxt_ip1 = zdit(ji+1,jj,jk) * r1_e1u(ji+1,jj) + ze3wr = 1._wp / (e3w_0(ji,jj,jk+kp)*(1._wp+r3t(ji,jj,Kmm))) + ze3wr_ip1 = 1._wp / (e3w_0(ji+1,jj,jk+kp)*(1._wp+r3t(ji+1,jj,Kmm))) + zdzt = zdkt3d(ji,jj,kp) * ze3wr + zdzt_ip1 = zdkt3d(ji+1,jj,kp) * ze3wr_ip1 + ! + zbu = 0.25_wp * e1e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + zbu_ip1 = 0.25_wp * e1e2u(ji+1,jj) * (e3u_0(ji+1,jj,jk)*(1._wp+r3u(ji+1,jj,Kmm)*umask(ji+1,jj,jk))) + ! ln_botmix_triad is .F. mask zah for bottom half cells + zah = pahu(ji,jj,jk) * umask(ji,jj,jk+kp) ! pahu(ji+ip,jj,jk) ===>> ???? + zah_ip1 = pahu(ji+1,jj,jk) * umask(ji+1,jj,jk+kp) + zah_slp = zah * triadi(ji,jj,jk,1,kp) + zah_slp_ip1 = zah_ip1 * triadi(ji+1,jj,jk,1,kp) + zah_slp1 = zah * triadi(ji+1,jj,jk,0,kp) + IF( ln_ldfeiv ) THEN + zaei_slp = aeiu(ji,jj,jk) * triadi_g(ji,jj,jk,1,kp) + zaei_slp_ip1 = aeiu(ji+1,jj,jk) * triadi_g(ji+1,jj,jk,1,kp) + zaei_slp1 = aeiu(ji,jj,jk) * triadi_g(ji+1,jj,jk,0,kp) + ENDIF + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zftu(ji ,jj,jk ) = zftu(ji ,jj,jk ) & + & - ( ( zah * zdxt + ( zah_slp - zaei_slp ) * zdzt ) * zbu * ze1ur & + & + ( zah * zdxt + zah_slp1 * zdzt_ip1 - zaei_slp1 * zdzt_ip1 ) * zbu * ze1ur & + & ) ! bracket for halo 1 - halo 2 compatibility + ztfw(ji+1,jj,jk+kp) = ztfw(ji+1,jj,jk+kp) & + & - ( (zah_slp_ip1 + zaei_slp_ip1) * zdxt_ip1 * zbu_ip1 * ze3wr_ip1 & + & + ( zah_slp1 + zaei_slp1) * zdxt * zbu * ze3wr_ip1 & + & ) ! bracket for halo 1 - halo 2 compatibility + END DO ; END DO + END DO + ! + DO kp = 0, 1 + DO jj = ntsj-( iij), ntej+( iij-1 ) ; DO ji = ntsi-( iij), ntei+( iij-1) + ze2vr = r1_e2v(ji,jj) + zdyt = zdjt(ji,jj,jk) * ze2vr + zdyt_jp1 = zdjt(ji,jj+1,jk) * r1_e2v(ji,jj+1) + ze3wr = 1._wp / (e3w_0(ji,jj,jk+kp)*(1._wp+r3t(ji,jj,Kmm))) + ze3wr_jp1 = 1._wp / (e3w_0(ji,jj+1,jk+kp)*(1._wp+r3t(ji,jj+1,Kmm))) + zdzt = zdkt3d(ji,jj,kp) * ze3wr + zdzt_jp1 = zdkt3d(ji,jj+1,kp) * ze3wr_jp1 + zbv = 0.25_wp * e1e2v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + zbv_jp1 = 0.25_wp * e1e2v(ji,jj+1) * (e3v_0(ji,jj+1,jk)*(1._wp+r3v(ji,jj+1,Kmm)*vmask(ji,jj+1,jk))) + ! ln_botmix_triad is .F. mask zah for bottom half cells + zah = pahv(ji,jj,jk) * vmask(ji,jj,jk+kp) ! pahv(ji,jj+jp,jk) ???? + zah_jp1 = pahv(ji,jj+1,jk) * vmask(ji,jj+1,jk+kp) + zah_slp = zah * triadj(ji,jj,jk,1,kp) + zah_slp1 = zah * triadj(ji,jj+1,jk,0,kp) + zah_slp_jp1 = zah_jp1 * triadj(ji,jj+1,jk,1,kp) + IF( ln_ldfeiv ) THEN + zaei_slp = aeiv(ji,jj,jk) * triadj_g(ji,jj,jk,1,kp) + zaei_slp_jp1 = aeiv(ji,jj+1,jk) * triadj_g(ji,jj+1,jk,1,kp) + zaei_slp1 = aeiv(ji,jj,jk) * triadj_g(ji,jj+1,jk,0,kp) + ENDIF + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zftv(ji,jj ,jk ) = zftv(ji,jj ,jk ) & + & - ( ( zah * zdyt + ( zah_slp - zaei_slp ) * zdzt ) * zbv * ze2vr & + & + ( zah * zdyt + zah_slp1 * zdzt_jp1 - zaei_slp1 * zdzt_jp1 ) * zbv * ze2vr & + & ) ! bracket for halo 1 - halo 2 compatibility + ztfw(ji,jj+1,jk+kp) = ztfw(ji,jj+1,jk+kp) & + & - ( ( zah_slp_jp1 + zaei_slp_jp1) * zdyt_jp1 * zbv_jp1 * ze3wr_jp1 & + & + ( zah_slp1 + zaei_slp1) * zdyt * zbv * ze3wr_jp1 & + & ) ! bracket for halo 1 - halo 2 compatibility + END DO ; END DO + END DO + ENDIF + ! !== horizontal divergence and add to the general trend ==! + DO jj = ntsj-( iij-1), ntej+( iij-1 ) ; DO ji = ntsi-( iij-1), ntei+( iij-1) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & + & + zsign * ( ( zftu(ji-1,jj ,jk) - zftu(ji,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zftv(ji,jj-1,jk) - zftv(ji,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) / ( e1e2t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) ) + END DO ; END DO + ! + END DO + ! + ! !== add the vertical 33 flux ==! + IF( ln_traldf_lap ) THEN ! laplacian case: eddy coef = ah_wslp2 - akz + DO jk = 2, jpkm1 ; DO jj = ntsj-( iij-1), ntej+( iij-1) ; DO ji = ntsi-( iij-1), ntei+( iij-1) + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * tmask(ji,jj,jk) & + & * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) ) & + & * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) + END DO ; END DO ; END DO + ELSE ! bilaplacian + SELECT CASE( kpass ) + CASE( 1 ) ! 1st pass : eddy coef = ah_wslp2 + DO jk = 2, jpkm1 ; DO jj = ntsj-( iij-1), ntej+( iij-1) ; DO ji = ntsi-( iij-1), ntei+( iij-1) + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * tmask(ji,jj,jk) & + & * ah_wslp2(ji,jj,jk) * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) + END DO ; END DO ; END DO + CASE( 2 ) ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt and pt2 gradients, resp. + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * tmask(ji,jj,jk) & + & * ( ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) ) & + & + akz (ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) ) ) + END DO ; END DO ; END DO + END SELECT + ENDIF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( iij-1), ntej+( iij-1) ; DO ji = ntsi-( iij-1), ntei+( iij-1) !== Divergence of vertical fluxes added to pta ==! + pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & + & + zsign * ( ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk) ) & + & / ( e1e2t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) ) + END DO ; END DO ; END DO + ! + IF( ( kpass == 1 .AND. ln_traldf_lap ) .OR. & !== first pass only ( laplacian) ==! + ( kpass == 2 .AND. ln_traldf_blp ) ) THEN !== 2nd pass (bilaplacian) ==! + ! + ! ! "Poleward" diffusive heat or salt transports (T-S case only) + IF( l_ptr ) CALL dia_ptr_hst( jn, 'ldf', zftv(:,:,:) ) + ! ! Diffusive heat transports + IF( l_hst ) CALL dia_ar5_hst( jn, 'ldf', zftu(:,:,:), zftv(:,:,:) ) + ! + ENDIF !== end pass selection ==! + ! + ! ! =============== + END DO ! end tracer loop + ! ! =============== + END SUBROUTINE tra_ldf_triad_t + + !!============================================================================== +END MODULE traldf_triad diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tramle.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tramle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d69db71c264a85c6f1212b9480f638850774daab --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tramle.f90 @@ -0,0 +1,401 @@ + + + + + + + + + + + + + +MODULE tramle + !!====================================================================== + !! *** MODULE tramle *** + !! Ocean tracers: Mixed Layer Eddy induced transport + !!====================================================================== + !! History : 3.3 ! 2010-08 (G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_mle_trp : update the effective transport with the Mixed Layer Eddy induced transport + !! tra_mle_init : initialisation of the Mixed Layer Eddy induced transport computation + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE phycst ! physical constant + USE zdfmxl ! mixed layer depth + ! + USE in_out_manager ! I/O manager + USE iom ! IOM library + USE lib_mpp ! MPP library + USE lbclnk ! lateral boundary condition / mpp link + + ! where OSMOSIS_OBL is used with integrated FK + USE zdf_oce, ONLY : ln_zdfosm + USE zdfosm, ONLY : ln_osm_mle, hmle, dbdx_mle, dbdy_mle, mld_prof + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_mle_trp ! routine called in traadv.F90 + PUBLIC tra_mle_init ! routine called in traadv.F90 + + ! !!* namelist namtra_mle * + LOGICAL, PUBLIC :: ln_mle !: flag to activate the Mixed Layer Eddy (MLE) parameterisation + INTEGER :: nn_mle ! MLE type: =0 standard Fox-Kemper ; =1 new formulation + INTEGER :: nn_mld_uv ! space interpolation of MLD at u- & v-pts (0=min,1=averaged,2=max) + INTEGER :: nn_conv ! =1 no MLE in case of convection ; =0 always MLE + REAL(wp) :: rn_ce ! MLE coefficient + ! ! parameters used in nn_mle = 0 case + REAL(wp) :: rn_lf ! typical scale of mixed layer front + REAL(wp) :: rn_time ! time scale for mixing momentum across the mixed layer + ! ! parameters used in nn_mle = 1 case + REAL(wp) :: rn_lat ! reference latitude for a 5 km scale of ML front + REAL(wp) :: rn_rho_c_mle ! Density criterion for definition of MLD used by FK + + REAL(wp) :: r5_21 = 5.e0 / 21.e0 ! factor used in mle streamfunction computation + REAL(wp) :: rb_c ! ML buoyancy criteria = g rho_c /rho0 where rho_c is defined in zdfmld + REAL(wp) :: rc_f ! MLE coefficient (= rn_ce / (5 km * fo) ) in nn_mle=1 case + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: rfu, rfv ! modified Coriolis parameter (f+tau) at u- & v-pts + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_ft ! inverse of the modified Coriolis parameter at t-pts + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: tramle.F90 14921 2021-05-28 12:19:26Z smueller $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_mle_trp( kt, kit000, pu, pv, pw, cdtype, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_mle_trp *** + !! + !! ** Purpose : Add to the transport the Mixed Layer Eddy induced transport + !! + !! ** Method : The 3 components of the Mixed Layer Eddy (MLE) induced + !! transport are computed as follows : + !! zu_mle = dk[ zpsi_uw ] + !! zv_mle = dk[ zpsi_vw ] + !! zw_mle = - di[ zpsi_uw ] - dj[ zpsi_vw ] + !! where zpsi is the MLE streamfunction at uw and vw points (see the doc) + !! and added to the input velocity : + !! p.n = p.n + z._mle + !! + !! ** Action : - (pu,pv,pw) increased by the mle transport + !! CAUTION, the transport is not updated at the last line/raw + !! this may be a problem for some advection schemes + !! + !! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008 + !! Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + ! TEMP: [tiling] Can be ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(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 + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: same 3 transport components + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the MLE induced transport + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ii, ij, ik, ikmax ! local integers + REAL(wp) :: zcuw, zmuw, zc ! local scalar + REAL(wp) :: zcvw, zmvw ! - - + INTEGER , DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: inml_mle + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zpsi_uw, zpsi_vw + !!---------------------------------------------------------------------- + ! + ! + IF(ln_osm_mle.and.ln_zdfosm) THEN + ikmax = MIN( MAXVAL( mld_prof(:,:) ), jpkm1 ) ! max level of the computation + ! + ! + SELECT CASE( nn_mld_uv ) ! MLD at u- & v-pts + CASE ( 0 ) != min of the 2 neighbour MLDs + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zhu(ji,jj) = MIN( hmle(ji+1,jj), hmle(ji,jj) ) + zhv(ji,jj) = MIN( hmle(ji,jj+1), hmle(ji,jj) ) + END DO ; END DO + CASE ( 1 ) != average of the 2 neighbour MLDs + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zhu(ji,jj) = MAX( hmle(ji+1,jj), hmle(ji,jj) ) + zhv(ji,jj) = MAX( hmle(ji,jj+1), hmle(ji,jj) ) + END DO ; END DO + CASE ( 2 ) != max of the 2 neighbour MLDs + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zhu(ji,jj) = MAX( hmle(ji+1,jj), hmle(ji,jj) ) + zhv(ji,jj) = MAX( hmle(ji,jj+1), hmle(ji,jj) ) + END DO ; END DO + END SELECT + IF( nn_mle == 0 ) THEN ! Fox-Kemper et al. 2010 formulation + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj) * e2u(ji,jj) & + & * dbdx_mle(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) & + & / ( MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) ) ) + ! + zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj) * e1v(ji,jj) & + & * dbdy_mle(ji,jj) * MIN( 111.e3_wp , e2v(ji,jj) ) & + & / ( MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) ) ) + END DO ; END DO + ! + ELSEIF( nn_mle == 1 ) THEN ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat) + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zpsim_u(ji,jj) = rc_f * zhu(ji,jj) * zhu(ji,jj) * e2u(ji,jj) & + & * dbdx_mle(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) + ! + zpsim_v(ji,jj) = rc_f * zhv(ji,jj) * zhv(ji,jj) * e1v(ji,jj) & + & * dbdy_mle(ji,jj) * MIN( 111.e3_wp , e2v(ji,jj) ) + END DO ; END DO + ENDIF + + ELSE !do not use osn_mle + ! !== MLD used for MLE ==! + ! ! compute from the 10m density to deal with the diurnal cycle + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + inml_mle(ji,jj) = mbkt(ji,jj) + 1 ! init. to number of ocean w-level (T-level + 1) + END DO ; END DO + IF ( nla10 > 0 ) THEN ! avoid case where first level is thicker than 10m + DO jk = jpkm1, nlb10, -1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! from the bottom to nlb10 (10m) + IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle ) inml_mle(ji,jj) = jk ! Mixed layer + END DO ; END DO ; END DO + ENDIF + ikmax = MIN( MAXVAL( inml_mle(:,:) ), jpkm1 ) ! max level of the computation + ! + ! + zmld(:,:) = 0._wp !== Horizontal shape of the MLE ==! + zbm (:,:) = 0._wp + zn2 (:,:) = 0._wp + DO jk = 1, ikmax ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! MLD and mean buoyancy and N2 over the mixed layer + zc = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1 ) ) ! zc being 0 outside the ML t-points + zmld(ji,jj) = zmld(ji,jj) + zc + zbm (ji,jj) = zbm (ji,jj) + zc * (rho0 - rhop(ji,jj,jk) ) * r1_rho0 + zn2 (ji,jj) = zn2 (ji,jj) + zc * (rn2(ji,jj,jk)+rn2(ji,jj,jk+1))*0.5_wp + END DO ; END DO ; END DO + + SELECT CASE( nn_mld_uv ) ! MLD at u- & v-pts + CASE ( 0 ) != min of the 2 neighbour MLDs + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) ) + zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) ) + END DO ; END DO + CASE ( 1 ) != average of the 2 neighbour MLDs + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp + zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp + END DO ; END DO + CASE ( 2 ) != max of the 2 neighbour MLDs + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) ) + zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) ) + END DO ; END DO + END SELECT + ! ! convert density into buoyancy + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zbm(ji,jj) = + grav * zbm(ji,jj) / MAX( (e3t_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,1))), zmld(ji,jj) ) + END DO ; END DO + ! + ! + ! !== Magnitude of the MLE stream function ==! + ! + ! di[bm] Ds + ! Psi = Ce H^2 ---------------- e2u mu(z) where fu Lf = MAX( fu*rn_fl , (Db H)^1/2 ) + ! e1u Lf fu and the e2u for the "transport" + ! (not *e3u as divided by e3u at the end) + ! + IF( nn_mle == 0 ) THEN ! Fox-Kemper et al. 2010 formulation + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj) * e2_e1u(ji,jj) & + & * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) & + & / ( MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) ) ) + ! + zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj) * e1_e2v(ji,jj) & + & * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) & + & / ( MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) ) ) + END DO ; END DO + ! + ELSEIF( nn_mle == 1 ) THEN ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat) + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zpsim_u(ji,jj) = rc_f * zhu(ji,jj) * zhu(ji,jj) * e2_e1u(ji,jj) & + & * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) + ! + zpsim_v(ji,jj) = rc_f * zhv(ji,jj) * zhv(ji,jj) * e1_e2v(ji,jj) & + & * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) + END DO ; END DO + ENDIF + ! + IF( nn_conv == 1 ) THEN ! No MLE in case of convection + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp ) zpsim_u(ji,jj) = 0._wp + IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp ) zpsim_v(ji,jj) = 0._wp + END DO ; END DO + ENDIF + ! + ENDIF ! end of ln_osm_mle conditional + ! !== structure function value at uw- and vw-points ==! + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zhu(ji,jj) = 1._wp / MAX(zhu(ji,jj), rsmall) ! hu --> 1/hu + zhv(ji,jj) = 1._wp / MAX(zhv(ji,jj), rsmall) + END DO ; END DO + ! + zpsi_uw(:,:,:) = 0._wp + zpsi_vw(:,:,:) = 0._wp + ! + DO jk = 2, ikmax ; DO jj = ntsj-( nn_hls), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) ! start from 2 : surface value = 0 + + zcuw = 1._wp - ( (gdepw_0(ji+1,jj,jk)*(1._wp+r3t(ji+1,jj,Kmm))) + (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) * zhu(ji,jj) + zcvw = 1._wp - ( (gdepw_0(ji,jj+1,jk)*(1._wp+r3t(ji,jj+1,Kmm))) + (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) * zhv(ji,jj) + zcuw = zcuw * zcuw + zcvw = zcvw * zcvw + zmuw = MAX( 0._wp , ( 1._wp - zcuw ) * ( 1._wp + r5_21 * zcuw ) ) + zmvw = MAX( 0._wp , ( 1._wp - zcvw ) * ( 1._wp + r5_21 * zcvw ) ) + ! + zpsi_uw(ji,jj,jk) = zpsim_u(ji,jj) * zmuw * wumask(ji,jj,jk) * wumask(ji,jj,1) + zpsi_vw(ji,jj,jk) = zpsim_v(ji,jj) * zmvw * wvmask(ji,jj,jk) * wvmask(ji,jj,1) + END DO ; END DO ; END DO + ! + ! !== transport increased by the MLE induced transport ==! + DO jk = 1, ikmax + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls)*nthr) + 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 DO ; END DO + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + 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) ) * wmask(ji,jj,1) + END DO ; END DO + END DO + + IF( cdtype == 'TRA') THEN !== outputs ==! + ! + IF (ln_osm_mle.and.ln_zdfosm) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zLf_NH(ji,jj) = SQRT( rb_c * hmle(ji,jj) ) * r1_ft(ji,jj) ! Lf = N H / f + END DO ; END DO + ELSE + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zLf_NH(ji,jj) = SQRT( rb_c * zmld(ji,jj) ) * r1_ft(ji,jj) ! Lf = N H / f + END DO ; END DO + ENDIF + ! + CALL iom_put( "Lf_NHpf" , zLf_NH ) ! Lf = N H / f + ! + ! divide by cross distance to give streamfunction with dimensions m^2/s + DO jk = 1, ikmax+1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zpsi_uw(ji,jj,jk) = zpsi_uw(ji,jj,jk) * r1_e2u(ji,jj) + zpsi_vw(ji,jj,jk) = zpsi_vw(ji,jj,jk) * r1_e1v(ji,jj) + END DO ; END DO ; END DO + CALL iom_put( "psiu_mle", zpsi_uw ) ! i-mle streamfunction + CALL iom_put( "psiv_mle", zpsi_vw ) ! j-mle streamfunction + ENDIF + ! + END SUBROUTINE tra_mle_trp + + SUBROUTINE tra_mle_init + !!--------------------------------------------------------------------- + !! *** ROUTINE tra_mle_init *** + !! + !! ** Purpose : Control the consistency between namelist options for + !! tracer advection schemes and set nadv + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ierr + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp) :: z1_t2, zfu, zfv ! - - + ! + NAMELIST/namtra_mle/ ln_mle , nn_mle, rn_ce, rn_lf, rn_time, rn_lat, nn_mld_uv, nn_conv, rn_rho_c_mle + !!---------------------------------------------------------------------- + + READ ( numnam_ref, namtra_mle, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_mle in reference namelist' ) + + READ ( numnam_cfg, namtra_mle, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_mle in configuration namelist' ) + IF(lwm) WRITE ( numond, namtra_mle ) + + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'tra_mle_init : mixed layer eddy (MLE) advection acting on tracers' + WRITE(numout,*) '~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtra_mle : mixed layer eddy advection applied on tracers' + WRITE(numout,*) ' use mixed layer eddy (MLE, i.e. Fox-Kemper param) (T/F) ln_mle = ', ln_mle + WRITE(numout,*) ' MLE type: =0 standard Fox-Kemper ; =1 new formulation nn_mle = ', nn_mle + WRITE(numout,*) ' magnitude of the MLE (typical value: 0.06 to 0.08) rn_ce = ', rn_ce + WRITE(numout,*) ' scale of ML front (ML radius of deformation) (rn_mle=0) rn_lf = ', rn_lf, 'm' + WRITE(numout,*) ' maximum time scale of MLE (rn_mle=0) rn_time = ', rn_time, 's' + WRITE(numout,*) ' reference latitude (degrees) of MLE coef. (rn_mle=1) rn_lat = ', rn_lat, 'deg' + WRITE(numout,*) ' space interp. of MLD at u-(v-)pts (0=min,1=averaged,2=max) nn_mld_uv = ', nn_mld_uv + WRITE(numout,*) ' =1 no MLE in case of convection ; =0 always MLE nn_conv = ', nn_conv + WRITE(numout,*) ' Density difference used to define ML for FK rn_rho_c_mle = ', rn_rho_c_mle + ENDIF + ! + IF(lwp) THEN + WRITE(numout,*) + IF( ln_mle ) THEN + WRITE(numout,*) ' ==>>> Mixed Layer Eddy induced transport added to tracer advection' + IF( nn_mle == 0 ) WRITE(numout,*) ' Fox-Kemper et al 2010 formulation' + IF( nn_mle == 1 ) WRITE(numout,*) ' New formulation' + ELSE + WRITE(numout,*) ' ==>>> Mixed Layer Eddy parametrisation NOT used' + ENDIF + ENDIF + ! + IF( ln_mle ) THEN ! MLE initialisation + ! + rb_c = grav * rn_rho_c_mle /rho0 ! Mixed Layer buoyancy criteria + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ML buoyancy criteria = ', rb_c, ' m/s2 ' + IF(lwp) WRITE(numout,*) ' associated ML density criteria defined in zdfmxl = ', rho_c, 'kg/m3' + ! + IF( nn_mle == 0 ) THEN ! MLE array allocation & initialisation + ALLOCATE( rfu(jpi,jpj) , rfv(jpi,jpj) , STAT= ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) + z1_t2 = 1._wp / ( rn_time * rn_time ) + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) ! "coriolis+ time^-1" at u- & v-points + zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp + zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp + rfu(ji,jj) = SQRT( zfu * zfu + z1_t2 ) + rfv(ji,jj) = SQRT( zfv * zfv + z1_t2 ) + END DO ; END DO + CALL lbc_lnk( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) + ! + ELSEIF( nn_mle == 1 ) THEN ! MLE array allocation & initialisation + rc_f = rn_ce / ( 5.e3_wp * 2._wp * omega * SIN( rad * rn_lat ) ) + ! + ENDIF + ! + ! ! 1/(f^2+tau^2)^1/2 at t-point (needed in both nn_mle case) + ALLOCATE( r1_ft(jpi,jpj) , STAT= ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'tra_adv_mle_init: failed to allocate r1_ft array' ) + ! + z1_t2 = 1._wp / ( rn_time * rn_time ) + r1_ft(:,:) = 1._wp / SQRT( ff_t(:,:) * ff_t(:,:) + z1_t2 ) + ! + ENDIF + ! + END SUBROUTINE tra_mle_init + + !!============================================================================== +END MODULE tramle diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tranpc.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tranpc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3dbcd86a572b12d4c125887176a897f91b883a07 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/tranpc.f90 @@ -0,0 +1,355 @@ + + + + + + + + + + + + + +MODULE tranpc + !!============================================================================== + !! *** MODULE tranpc *** + !! Ocean active tracers: non penetrative convective adjustment scheme + !!============================================================================== + !! History : 1.0 ! 1990-09 (G. Madec) Original code + !! ! 1996-01 (G. Madec) statement function for e3 + !! NEMO 1.0 ! 2002-06 (G. Madec) free form F90 + !! 3.0 ! 2008-06 (G. Madec) applied on ta, sa and called before tranxt in step.F90 + !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + !! 3.6 ! 2015-05 (L. Brodeau) new algorithm based on local Brunt-Vaisala freq. + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_npc : apply the non penetrative convection scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE zdf_oce ! ocean vertical physics + USE trd_oce ! ocean active tracer trends + USE trdtra ! ocean active tracer trends + USE eosbn2 ! equation of state (eos routine) + ! + USE lbclnk ! lateral boundary conditions (or mpp link) + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_npc ! routine called by step.F90 + + INTEGER :: nnpcc ! number of statically instable water column + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: tranpc.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_npc( kt, Kmm, Krhs, pts, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tranpc *** + !! + !! ** Purpose : Non-penetrative convective adjustment scheme. solve + !! the static instability of the water column on after fields + !! while conserving heat and salt contents. + !! + !! ** Method : updated algorithm able to deal with non-linear equation of state + !! (i.e. static stability computed locally) + !! + !! ** Action : - tsa: after tracers with the application of the npc scheme + !! - send the associated trends for on-line diagnostics (l_trdtra=T) + !! + !! References : Madec, et al., 1991, JPO, 21, 9, 1349-1371. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kmm, Krhs, Kaa ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low ! local integers + LOGICAL :: l_bottom_reached, l_column_treated + REAL(wp) :: zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z + REAL(wp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_rDt + REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp ! acceptance criteria for neutrality (N2==0) + REAL(wp), DIMENSION( jpk ) :: zvn2 ! vertical profile of N2 at 1 given point... + REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab ! vertical profile of T & S , and alpha & betaat 1 given point + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk ) :: zn2 ! N^2 + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk,jpts) :: zab ! alpha and beta + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace + ! + LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is + INTEGER :: ilc1, jlc1, klc1, nncpu ! actually happening in a water column at point "ilc1, jlc1" + LOGICAL :: lp_monitor_point = .FALSE. ! in CPU domain "nncpu" + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_npc') + ! + IF( MOD( kt, nn_npc ) == 0 ) THEN + ! + IF( l_trdtra ) THEN !* Save initial after fields + ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) + ENDIF + ! + IF( l_LB_debug ) THEN + ! Location of 1 known convection site to follow what's happening in the water column + ilc1 = 45 ; jlc1 = 3 ; ! ORCA2 4x4, Antarctic coast, more than 2 unstable portions in the water column... + nncpu = 1 ; ! the CPU domain contains the convection spot + klc1 = mbkt(ilc1,jlc1) ! bottom of the ocean for debug point... + ENDIF + ! + CALL eos_rab( pts(:,:,:,:,Kaa), zab, Kmm ) ! after alpha and beta (given on T-points) + CALL bn2 ( pts(:,:,:,:,Kaa), zab, zn2, Kmm ) ! after Brunt-Vaisala (given on W-points) + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) nnpcc = 0 ! Do only on the first tile + ! + DO jj = ntsj-( 0-( 0+ 0 )*nthb), ntej+( 0 -( 0 + 0)*ntht) ; DO ji = ntsi-( 0-( 0+ 0)*nthl), ntei+( 0-( 0+ 0)*nthr) ! interior column only + ! + IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points + ! ! consider one ocean column + zvts(:,jp_tem) = pts(ji,jj,:,jp_tem,Kaa) ! temperature + zvts(:,jp_sal) = pts(ji,jj,:,jp_sal,Kaa) ! salinity + ! + zvab(:,jp_tem) = zab(ji,jj,:,jp_tem) ! Alpha + zvab(:,jp_sal) = zab(ji,jj,:,jp_sal) ! Beta + zvn2(:) = zn2(ji,jj,:) ! N^2 + ! + IF( l_LB_debug ) THEN !LB debug: + lp_monitor_point = .FALSE. + IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. + ! writing only if on CPU domain where conv region is: + lp_monitor_point = (narea == nncpu).AND.lp_monitor_point + ENDIF !LB debug end + ! + ikbot = mbkt(ji,jj) ! ikbot: ocean bottom T-level + ikp = 1 ! because N2 is irrelevant at the surface level (will start at ikp=2) + ilayer = 0 + jiter = 0 + l_column_treated = .FALSE. + ! + DO WHILE ( .NOT. l_column_treated ) + ! + jiter = jiter + 1 + ! + IF( jiter >= 400 ) EXIT + ! + l_bottom_reached = .FALSE. + ! + DO WHILE ( .NOT. l_bottom_reached ) + ! + ikp = ikp + 1 + ! + !! Testing level ikp for instability + !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF( zvn2(ikp) < -zn2_zero ) THEN ! Instability found! + ! + ilayer = ilayer + 1 ! yet another instable portion of the water column found.... + ! + IF( lp_monitor_point ) THEN + WRITE(numout,*) + IF( ilayer == 1 .AND. jiter == 1 ) THEN ! first time a column is spoted with an instability + WRITE(numout,*) + WRITE(numout,*) 'Time step = ',kt,' !!!' + ENDIF + WRITE(numout,*) ' * Iteration #',jiter,': found instable portion #',ilayer, & + & ' in column! Starting at ikp =', ikp + WRITE(numout,*) ' *** N2 for point (i,j) = ',ji,' , ',jj + DO jk = 1, klc1 + WRITE(numout,*) jk, zvn2(jk) + END DO + WRITE(numout,*) + ENDIF + ! + IF( jiter == 1 ) nnpcc = nnpcc + 1 + ! + IF( lp_monitor_point ) WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer + ! + !! ikup is the uppermost point where mixing will start: + ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying + ! + !! If the points above ikp-1 have N2 == 0 they must also be mixed: + IF( ikp > 2 ) THEN + DO jk = ikp-1, 2, -1 + IF( ABS(zvn2(jk)) < zn2_zero ) THEN + ikup = ikup - 1 ! 1 more upper level has N2=0 and must be added for the mixing + ELSE + EXIT + ENDIF + END DO + ENDIF + ! + IF( ikup < 1 ) CALL ctl_stop( 'tra_npc : PROBLEM #1') + ! + zsum_temp = 0._wp + zsum_sali = 0._wp + zsum_alfa = 0._wp + zsum_beta = 0._wp + zsum_z = 0._wp + + DO jk = ikup, ikbot ! Inside the instable (and overlying neutral) portion of the column + ! + zdz = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + zsum_temp = zsum_temp + zvts(jk,jp_tem)*zdz + zsum_sali = zsum_sali + zvts(jk,jp_sal)*zdz + zsum_alfa = zsum_alfa + zvab(jk,jp_tem)*zdz + zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz + zsum_z = zsum_z + zdz + ! + IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line + !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): + IF( zvn2(jk+1) > zn2_zero ) EXIT + END DO + + ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 + IF( ikup == ikdown ) CALL ctl_stop( 'tra_npc : PROBLEM #2') + + ! Mixing Temperature, salinity, alpha and beta from ikup to ikdown included: + zta = zsum_temp/zsum_z + zsa = zsum_sali/zsum_z + zalfa = zsum_alfa/zsum_z + zbeta = zsum_beta/zsum_z + + IF( lp_monitor_point ) THEN + WRITE(numout,*) 'MIXED T, S, alfa and beta between ikup =',ikup, & + & ' and ikdown =',ikdown,', in layer #',ilayer + WRITE(numout,*) ' => Mean temp. in that portion =', zta + WRITE(numout,*) ' => Mean sali. in that portion =', zsa + WRITE(numout,*) ' => Mean Alfa in that portion =', zalfa + WRITE(numout,*) ' => Mean Beta in that portion =', zbeta + ENDIF + + !! Homogenaizing the temperature, salinity, alpha and beta in this portion of the column + DO jk = ikup, ikdown + zvts(jk,jp_tem) = zta + zvts(jk,jp_sal) = zsa + zvab(jk,jp_tem) = zalfa + zvab(jk,jp_sal) = zbeta + END DO + + + !! Updating N2 in the relvant portion of the water column + !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion + !! => Need to re-compute N2! will use Alpha and Beta! + + ikup = MAX(2,ikup) ! ikup can never be 1 ! + ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! + + DO jk = ikup, ik_low ! we must go 1 point deeper than ikdown! + + !! Interpolating alfa and beta at W point: + zrw = ((gdepw_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))) & + & / ((gdept_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))) + zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw + zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw + + !! N2 at W point, doing exactly as in eosbn2.F90: + zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & + & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) & + & / (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * tmask(ji,jj,jk) + + !! OR, faster => just considering the vertical gradient of density + !! as only the signa maters... + !zvn2(jk) = ( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & + ! & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) + + END DO + + ikp = MIN(ikdown+1,ikbot) + + + ENDIF !IF( zvn2(ikp) < 0. ) + + + IF( ikp == ikbot ) l_bottom_reached = .TRUE. + ! + END DO ! DO WHILE ( .NOT. l_bottom_reached ) + + IF( ikp /= ikbot ) CALL ctl_stop( 'tra_npc : PROBLEM #3') + + ! ******* At this stage ikp == ikbot ! ******* + + IF( ilayer > 0 ) THEN !! least an unstable layer has been found + ! + IF( lp_monitor_point ) THEN + WRITE(numout,*) + WRITE(numout,*) 'After ',jiter,' iteration(s), we neutralized ',ilayer,' instable layer(s)' + WRITE(numout,*) ' ==> N2 at i,j=',ji,',',jj,' now looks like this:' + DO jk = 1, klc1 + WRITE(numout,*) jk, zvn2(jk) + END DO + WRITE(numout,*) + ENDIF + ! + ikp = 1 ! starting again at the surface for the next iteration + ilayer = 0 + ENDIF + ! + IF( ikp >= ikbot ) l_column_treated = .TRUE. + ! + END DO ! DO WHILE ( .NOT. l_column_treated ) + + !! Updating pts: + pts(ji,jj,:,jp_tem,Kaa) = zvts(:,jp_tem) + pts(ji,jj,:,jp_sal,Kaa) = zvts(:,jp_sal) + + !! LB: Potentially some other global variable beside theta and S can be treated here + !! like BGC tracers. + + IF( lp_monitor_point ) WRITE(numout,*) + + ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN + + END DO ; END DO + ! + IF( l_trdtra ) THEN ! send the Non penetrative mixing trends for diagnostic + z1_rDt = 1._wp / (2._wp * rn_Dt) + ztrdt(:,:,:) = ( pts(:,:,:,jp_tem,Kaa) - ztrdt(:,:,:) ) * z1_rDt + ztrds(:,:,:) = ( pts(:,:,:,jp_sal,Kaa) - ztrds(:,:,:) ) * z1_rDt + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_npc, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_npc, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + ENDIF + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only for the full domain + IF( lwp .AND. l_LB_debug ) THEN + WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', nnpcc + WRITE(numout,*) + ENDIF + ENDIF + ! + ENDIF ! IF( MOD( kt, nn_npc ) == 0 ) THEN + ! + IF( ln_timing ) CALL timing_stop('tra_npc') + ! + END SUBROUTINE tra_npc + + !!====================================================================== +END MODULE tranpc diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traqsr.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traqsr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..efe83a8a76918d5143ac446665a2f2f479a5683e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/traqsr.f90 @@ -0,0 +1,481 @@ + + + + + + + + + + + + + +MODULE traqsr + !!====================================================================== + !! *** MODULE traqsr *** + !! Ocean physics: solar radiation penetration in the top ocean levels + !!====================================================================== + !! History : OPA ! 1990-10 (B. Blanke) Original code + !! 7.0 ! 1991-11 (G. Madec) + !! ! 1996-01 (G. Madec) s-coordinates + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! - ! 2005-11 (G. Madec) zco, zps, sco coordinate + !! 3.2 ! 2009-04 (G. Madec & NEMO team) + !! 3.6 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model + !! 3.6 ! 2015-12 (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll + !! 3.7 ! 2015-11 (G. Madec, A. Coward) remove optimisation for fix volume + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_qsr : temperature trend due to the penetration of solar radiation + !! tra_qsr_init : initialization of the qsr penetration + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain + USE domtile + USE sbc_oce ! surface boundary condition: ocean + USE trc_oce ! share SMS/Ocean variables + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE iom ! I/O library + USE fldread ! read input fields + USE restart ! ocean restart + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_qsr ! routine called by step.F90 (ln_traqsr=T) + PUBLIC tra_qsr_init ! routine called by nemogcm.F90 + + ! !!* Namelist namtra_qsr: penetrative solar radiation + LOGICAL , PUBLIC :: ln_traqsr !: light absorption (qsr) flag + LOGICAL , PUBLIC :: ln_qsr_rgb !: Red-Green-Blue light absorption flag + LOGICAL , PUBLIC :: ln_qsr_2bd !: 2 band light absorption flag + LOGICAL , PUBLIC :: ln_qsr_bio !: bio-model light absorption flag + INTEGER , PUBLIC :: nn_chldta !: use Chlorophyll data (=1) or not (=0) + REAL(wp), PUBLIC :: rn_abs !: fraction absorbed in the very near surface (RGB & 2 bands) + REAL(wp), PUBLIC :: rn_si0 !: very near surface depth of extinction (RGB & 2 bands) + REAL(wp), PUBLIC :: rn_si1 !: deepest depth of extinction (water type I) (2 bands) + ! + INTEGER , PUBLIC :: nksr !: levels below which the light cannot penetrate (depth larger than 391 m) + + INTEGER, PARAMETER :: np_RGB = 1 ! R-G-B light penetration with constant Chlorophyll + INTEGER, PARAMETER :: np_RGBc = 2 ! R-G-B light penetration with Chlorophyll data + INTEGER, PARAMETER :: np_2BD = 3 ! 2 bands light penetration + INTEGER, PARAMETER :: np_BIO = 4 ! bio-model light penetration + ! + INTEGER :: nqsr ! user choice of the type of light penetration + REAL(wp) :: xsi0r ! inverse of rn_si0 + REAL(wp) :: xsi1r ! inverse of rn_si1 + ! + REAL(wp) , PUBLIC, DIMENSION(3,61) :: rkrgb ! tabulated attenuation coefficients for RGB absorption + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_chl ! structure of input Chl (file informations, fields read) + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traqsr.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_qsr( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_qsr *** + !! + !! ** Purpose : Compute the temperature trend due to the solar radiation + !! penetration and add it to the general temperature trend. + !! + !! ** Method : The profile of the solar radiation within the ocean is defined + !! through 2 wavebands (rn_si0,rn_si1) or 3 wavebands (RGB) and a ratio rn_abs + !! Considering the 2 wavebands case: + !! I(k) = Qsr*( rn_abs*EXP(z(k)/rn_si0) + (1.-rn_abs)*EXP(z(k)/rn_si1) ) + !! The temperature trend associated with the solar radiation penetration + !! is given by : zta = 1/e3t dk[ I ] / (rho0*Cp) + !! At the bottom, boudary condition for the radiation is no flux : + !! all heat which has not been absorbed in the above levels is put + !! in the last ocean level. + !! The computation is only done down to the level where + !! I(k) < 1.e-15 W/m2 (i.e. over the top nksr levels) . + !! + !! ** Action : - update ta with the penetrative solar radiation trend + !! - send trend for further diagnostics (l_trdtra=T) + !! + !! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. + !! Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. + !! Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step + INTEGER, INTENT(in ) :: Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: irgb ! local integers + REAL(wp) :: zchl, zcoef, z1_2 ! local scalars + REAL(wp) :: zc0 , zc1 , zc2 , zc3 ! - - + REAL(wp) :: zzc0, zzc1, zzc2, zzc3 ! - - + REAL(wp) :: zz0 , zz1 , ze3t, zlui ! - - + REAL(wp) :: zCb, zCmax, zpsi, zpsimax, zrdpsi, zCze + REAL(wp) :: zlogc, zlogze, zlogCtot, zlogCze + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ze0, ze1, ze2, ze3 + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, zetot, ztmp3d + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_qsr') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + ENDIF + ! + IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend + ALLOCATE( ztrdt(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ENDIF + ! + ! !-----------------------------------! + ! ! before qsr induced heat content ! + ! !-----------------------------------! + IF( kt == nit000 ) THEN !== 1st time step ==! + IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN ! read in restart + z1_2 = 0.5_wp + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file' + CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b ) ! before heat content trend due to Qsr flux + ENDIF + ELSE ! No restart or Euler forward at 1st time step + z1_2 = 1._wp + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + qsr_hc_b(ji,jj,jk) = 0._wp + END DO ; END DO ; END DO + ENDIF + ELSE !== Swap of qsr heat content ==! + z1_2 = 0.5_wp + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + qsr_hc_b(ji,jj,jk) = qsr_hc(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ! + ! !--------------------------------! + SELECT CASE( nqsr ) ! now qsr induced heat content ! + ! !--------------------------------! + ! + CASE( np_BIO ) !== bio-model fluxes ==! + ! + DO jk = 1, nksr ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( etot3(ji,jj,jk) - etot3(ji,jj,jk+1) ) + END DO ; END DO ; END DO + ! + CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==! + ! + ALLOCATE( ze0 (ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) , ze1 (ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) , & + & ze2 (ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) , ze3 (ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) , & + & ztmp3d(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),nksr + 1) ) + ! + IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll + 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_chl ) ! Read Chl data and provides it at the current time step + IF( ln_tile ) CALL dom_tile_start( ldhold=.TRUE. ) ! Revert to tile domain + ENDIF + ! + ! Separation in R-G-B depending on the surface Chl + ! perform and store as many of the 2D calculations as possible + ! before the 3D loop (use the temporary 2D arrays to replace the + ! most expensive calculations) + ! + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + ! zlogc = log(zchl) + zlogc = LOG ( MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) ) + ! zc1 : log(zCze) = log (1.12 * zchl**0.803) + zc1 = 0.113328685307 + 0.803 * zlogc + ! zc2 : log(zCtot) = log(40.6 * zchl**0.459) + zc2 = 3.703768066608 + 0.459 * zlogc + ! zc3 : log(zze) = log(568.2 * zCtot**(-0.746)) + zc3 = 6.34247346942 - 0.746 * zc2 + ! IF( log(zze) > log(102.) ) log(zze) = log(200.0 * zCtot**(-0.293)) + IF( zc3 > 4.62497281328 ) zc3 = 5.298317366548 - 0.293 * zc2 + ! + ze0(ji,jj) = zlogc ! ze0 = log(zchl) + ze1(ji,jj) = EXP( zc1 ) ! ze1 = zCze + ze2(ji,jj) = 1._wp / ( 0.710 + zlogc * ( 0.159 + zlogc * 0.021 ) ) ! ze2 = 1/zdelpsi + ze3(ji,jj) = EXP( - zc3 ) ! ze3 = 1/zze + END DO ; END DO + +! + DO jk = 1, nksr + 1 ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + ! zchl = ALOG( ze0(ji,jj) ) + zlogc = ze0(ji,jj) + ! + zCb = 0.768 + zlogc * ( 0.087 - zlogc * ( 0.179 + zlogc * 0.025 ) ) + zCmax = 0.299 - zlogc * ( 0.289 - zlogc * 0.579 ) + zpsimax = 0.6 - zlogc * ( 0.640 - zlogc * ( 0.021 + zlogc * 0.115 ) ) + ! zdelpsi = 0.710 + zlogc * ( 0.159 + zlogc * 0.021 ) + ! + zCze = ze1(ji,jj) + zrdpsi = ze2(ji,jj) ! 1/zdelpsi + zpsi = ze3(ji,jj) * (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ! gdepw/zze + ! + ! NB. make sure zchl value is such that: zchl = MIN( 10. , MAX( 0.03, zchl ) ) + zchl = MIN( 10. , MAX( 0.03, zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) * zrdpsi )**2 ) ) ) ) + ! Convert chlorophyll value to attenuation coefficient look-up table index + ztmp3d(ji,jj,jk) = 41 + 20.*LOG10(zchl) + 1.e-15 + END DO ; END DO ; END DO + ELSE !* constant chlorophyll + zchl = 0.05 + ! NB. make sure constant value is such that: + zchl = MIN( 10. , MAX( 0.03, zchl ) ) + ! Convert chlorophyll value to attenuation coefficient look-up table index + zlui = 41 + 20.*LOG10(zchl) + 1.e-15 + DO jk = 1, nksr + 1 + ztmp3d(:,:,jk) = zlui + END DO + ENDIF + ! + zcoef = ( 1. - rn_abs ) / 3._wp !* surface equi-partition in R-G-B + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + ze0(ji,jj) = rn_abs * qsr(ji,jj) + ze1(ji,jj) = zcoef * qsr(ji,jj) + ze2(ji,jj) = zcoef * qsr(ji,jj) + ze3(ji,jj) = zcoef * qsr(ji,jj) + ! store the surface SW radiation; re-use the surface ztmp3d array + ! since the surface attenuation coefficient is not used + ztmp3d(ji,jj,1) = qsr(ji,jj) + END DO ; END DO + ! + ! !* interior equi-partition in R-G-B depending on vertical profile of Chl + DO jk = 2, nksr + 1 ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + ze3t = (e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1))) + irgb = NINT( ztmp3d(ji,jj,jk) ) + zc0 = ze0(ji,jj) * EXP( - ze3t * xsi0r ) + zc1 = ze1(ji,jj) * EXP( - ze3t * rkrgb(1,irgb) ) + zc2 = ze2(ji,jj) * EXP( - ze3t * rkrgb(2,irgb) ) + zc3 = ze3(ji,jj) * EXP( - ze3t * rkrgb(3,irgb) ) + ze0(ji,jj) = zc0 + ze1(ji,jj) = zc1 + ze2(ji,jj) = zc2 + ze3(ji,jj) = zc3 + ztmp3d(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + DO jk = 1, nksr ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) !* now qsr induced heat content + qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) ) + END DO ; END DO ; END DO + ! + DEALLOCATE( ze0 , ze1 , ze2 , ze3 , ztmp3d ) + ! + CASE( np_2BD ) !== 2-bands fluxes ==! + ! + zz0 = rn_abs * r1_rho0_rcp ! surface equi-partition in 2-bands + zz1 = ( 1. - rn_abs ) * r1_rho0_rcp + DO jk = 1, nksr ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) !* now qsr induced heat content + zc0 = zz0 * EXP( -(gdepw_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm)))*xsi0r ) + zz1 * EXP( -(gdepw_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm)))*xsi1r ) + zc1 = zz0 * EXP( -(gdepw_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm)))*xsi0r ) + zz1 * EXP( -(gdepw_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm)))*xsi1r ) + qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) ) + END DO ; END DO ; END DO + ! + END SELECT + ! + ! !-----------------------------! + ! ! update to the temp. trend ! + ! !-----------------------------! + DO jk = 1, nksr ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & + & + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) & + & / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + ! sea-ice: store the 1st ocean level attenuation coefficient + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rho0_rcp * qsr(ji,jj) ) + ELSE ; fraqsr_1lev(ji,jj) = 1._wp + ENDIF + END DO ; END DO + ! + IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution + ALLOCATE( zetot(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) ) + zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero + DO jk = nksr, 1, -1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-(0), ntei+( 0) + zetot(ji,jj,jk) = zetot(ji,jj,jk+1) + qsr_hc(ji,jj,jk) * rho0_rcp + END DO ; END DO ; END DO + CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation + DEALLOCATE( zetot ) + ENDIF + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF( lrst_oce ) THEN ! write in the ocean restart file + CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc ) + CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev ) + ENDIF + ENDIF + ! + IF( l_trdtra ) THEN ! qsr tracers trends saved for diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt ) + DEALLOCATE( ztrdt ) + ENDIF + ! ! print mean trends (used for debugging) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' qsr - Ta: ', mask1=tmask, clinfo3='tra-ta' ) + ! + IF( ln_timing ) CALL timing_stop('tra_qsr') + ! + END SUBROUTINE tra_qsr + + + SUBROUTINE tra_qsr_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_qsr_init *** + !! + !! ** Purpose : Initialization for the penetrative solar radiation + !! + !! ** Method : The profile of solar radiation within the ocean is set + !! from two length scale of penetration (rn_si0,rn_si1) and a ratio + !! (rn_abs). These parameters are read in the namtra_qsr namelist. The + !! default values correspond to clear water (type I in Jerlov' + !! (1968) classification. + !! called by tra_qsr at the first timestep (nit000) + !! + !! ** Action : - initialize rn_si0, rn_si1 and rn_abs + !! + !! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ios, irgb, ierror, ioptio ! local integer + REAL(wp) :: zz0, zc0 , zc1, zcoef ! local scalars + REAL(wp) :: zz1, zc2 , zc3, zchl ! - - + ! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N) :: sn_chl ! informations about the chlorofyl field to be read + !! + NAMELIST/namtra_qsr/ sn_chl, cn_dir, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, & + & nn_chldta, rn_abs, rn_si0, rn_si1 + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' ) + ! + READ ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist' ) + IF(lwm) WRITE ( numond, namtra_qsr ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'tra_qsr_init : penetration of the surface solar radiation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtra_qsr : set the parameter of penetration' + WRITE(numout,*) ' RGB (Red-Green-Blue) light penetration ln_qsr_rgb = ', ln_qsr_rgb + WRITE(numout,*) ' 2 band light penetration ln_qsr_2bd = ', ln_qsr_2bd + WRITE(numout,*) ' bio-model light penetration ln_qsr_bio = ', ln_qsr_bio + WRITE(numout,*) ' RGB : Chl data (=1) or cst value (=0) nn_chldta = ', nn_chldta + WRITE(numout,*) ' RGB & 2 bands: fraction of light (rn_si1) rn_abs = ', rn_abs + WRITE(numout,*) ' RGB & 2 bands: shortess depth of extinction rn_si0 = ', rn_si0 + WRITE(numout,*) ' 2 bands: longest depth of extinction rn_si1 = ', rn_si1 + WRITE(numout,*) + ENDIF + ! + ioptio = 0 ! Parameter control + IF( ln_qsr_rgb ) ioptio = ioptio + 1 + IF( ln_qsr_2bd ) ioptio = ioptio + 1 + IF( ln_qsr_bio ) ioptio = ioptio + 1 + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE type of light penetration in namelist namtra_qsr', & + & ' 2 bands, 3 RGB bands or bio-model light penetration' ) + ! + IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = np_RGB + IF( ln_qsr_rgb .AND. nn_chldta == 1 ) nqsr = np_RGBc + IF( ln_qsr_2bd ) nqsr = np_2BD + IF( ln_qsr_bio ) nqsr = np_BIO + ! + ! ! Initialisation + xsi0r = 1._wp / rn_si0 + xsi1r = 1._wp / rn_si1 + ! + SELECT CASE( nqsr ) + ! + CASE( np_RGB , np_RGBc ) !== Red-Green-Blue light penetration ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> R-G-B light penetration ' + ! + CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef. + ! + nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction + ! + IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' + ! + IF( nqsr == np_RGBc ) THEN ! Chl data : set sf_chl structure + IF(lwp) WRITE(numout,*) ' ==>>> Chlorophyll read in a file' + ALLOCATE( sf_chl(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'tra_qsr_init: unable to allocate sf_chl structure' ) ; RETURN + ENDIF + ALLOCATE( sf_chl(1)%fnow(jpi,jpj,1) ) + IF( sn_chl%ln_tint ) ALLOCATE( sf_chl(1)%fdta(jpi,jpj,1,2) ) + ! ! fill sf_chl with sn_chl and control print + CALL fld_fill( sf_chl, (/ sn_chl /), cn_dir, 'tra_qsr_init', & + & 'Solar penetration function of read chlorophyll', 'namtra_qsr' , no_print ) + ENDIF + IF( nqsr == np_RGB ) THEN ! constant Chl + IF(lwp) WRITE(numout,*) ' ==>>> Constant Chlorophyll concentration = 0.05' + ENDIF + ! + CASE( np_2BD ) !== 2 bands light penetration ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> 2 bands light penetration' + ! + nksr = trc_oce_ext_lev( rn_si1, 100._wp ) ! level of light extinction + IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' + ! + CASE( np_BIO ) !== BIO light penetration ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> bio-model light penetration' + IF( .NOT.lk_top ) CALL ctl_stop( 'No bio model : ln_qsr_bio = true impossible ' ) + ! + CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef. + ! + nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction + ! + IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' + ! + END SELECT + ! + qsr_hc(:,:,:) = 0._wp ! now qsr heat content set to zero where it will not be computed + ! + ! 1st ocean level attenuation coefficient (used in sbcssm) + IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev' , fraqsr_1lev ) + ELSE + fraqsr_1lev(:,:) = 1._wp ! default : no penetration + ENDIF + ! + END SUBROUTINE tra_qsr_init + + !!====================================================================== +END MODULE traqsr diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trasbc.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trasbc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8b95e0029f23cef0c0819653c6d168df9266e7e2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trasbc.f90 @@ -0,0 +1,226 @@ + + + + + + + + + + + + + +MODULE trasbc + !!============================================================================== + !! *** MODULE trasbc *** + !! Ocean active tracers: surface boundary condition + !!============================================================================== + !! History : OPA ! 1998-10 (G. Madec, G. Roullet, M. Imbard) Original code + !! 8.2 ! 2001-02 (D. Ludicone) sea ice and free surface + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps + !! - ! 2010-09 (C. Ethe, G. Madec) Merge TRA-TRC + !! 3.6 ! 2014-11 (P. Mathiot) isf melting forcing + !! 4.1 ! 2019-09 (P. Mathiot) isf moved in traisf + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_sbc : update the tracer trend at ocean surface + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE sbc_oce ! surface boundary condition: ocean + USE dom_oce ! ocean space domain variables + USE phycst ! physical constant + USE eosbn2 ! Equation Of State + USE sbcmod ! ln_rnf + USE sbcrnf ! River runoff + USE traqsr ! solar radiation penetration + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE iom ! xIOS server + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_sbc ! routine called by step.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trasbc.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_sbc ( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_sbc *** + !! + !! ** Purpose : Compute the tracer surface boundary condition trend of + !! (flux through the interface, concentration/dilution effect) + !! and add it to the general trend of tracer equations. + !! + !! ** Method : The (air+ice)-sea flux has two components: + !! (1) Fext, external forcing (i.e. flux through the (air+ice)-sea interface); + !! (2) Fwe , tracer carried with the water that is exchanged with air+ice. + !! The input forcing fields (emp, rnf, sfx) contain Fext+Fwe, + !! they are simply added to the tracer trend (ts(Krhs)). + !! In linear free surface case (ln_linssh=T), the volume of the + !! ocean does not change with the water exchanges at the (air+ice)-sea + !! interface. Therefore another term has to be added, to mimic the + !! concentration/dilution effect associated with water exchanges. + !! + !! ** Action : - Update ts(Krhs) with the surface boundary condition trend + !! - send trends to trdtra module for further diagnostics(l_trdtra=T) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer Eq. + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ikt, ikb ! local integers + REAL(wp) :: zfact, z1_e3t, zdep, ztim ! local scalar + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_sbc') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_sbc : TRAcer Surface Boundary Condition' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ENDIF + ! + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) + ENDIF + ! +!!gm This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist) + IF( .NOT.ln_traqsr ) THEN ! no solar radiation penetration + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + qns(ji,jj) = qns(ji,jj) + qsr(ji,jj) ! total heat flux in qns + qsr(ji,jj) = 0._wp ! qsr set to zero + END DO ; END DO + ENDIF + + !---------------------------------------- + ! EMP, SFX and QNS effects + !---------------------------------------- + ! !== Set before sbc tracer content fields ==! + IF( kt == nit000 ) THEN !* 1st time-step + IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN ! Restart: read in restart file + zfact = 0.5_wp + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) WRITE(numout,*) ' nit000-1 sbc tracer content field read in the restart file' + sbc_tsc(:,:,:) = 0._wp + CALL iom_get( numror, jpdom_auto, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem) ) ! before heat content sbc trend + CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) ) ! before salt content sbc trend + ENDIF + ELSE ! No restart or restart not found: Euler forward time stepping + zfact = 1._wp + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + sbc_tsc(ji,jj,:) = 0._wp + sbc_tsc_b(ji,jj,:) = 0._wp + END DO ; END DO + ENDIF + ELSE !* other time-steps: swap of forcing fields + zfact = 0.5_wp + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + sbc_tsc_b(ji,jj,:) = sbc_tsc(ji,jj,:) + END DO ; END DO + ENDIF + ! !== Now sbc tracer content fields ==! + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + sbc_tsc(ji,jj,jp_tem) = r1_rho0_rcp * qns(ji,jj) ! non solar heat flux + sbc_tsc(ji,jj,jp_sal) = r1_rho0 * sfx(ji,jj) ! salt flux due to freezing/melting + END DO ; END DO + IF( ln_linssh ) THEN !* linear free surface + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) !==>> add concentration/dilution effect due to constant volume cell + sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) + sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) + END DO ; END DO !==>> output c./d. term + IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) + IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) + ENDIF + ! + DO jn = 1, jpts !== update tracer trend ==! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) & + & / (e3t_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,1))) + END DO ; END DO + END DO + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF( lrst_oce ) THEN !== write sbc_tsc in the ocean restart file ==! + CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem) ) + CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal) ) + ENDIF + ENDIF + ! + !---------------------------------------- + ! River Runoff effects + !---------------------------------------- + ! + IF( ln_rnf ) THEN ! input of heat and salt due to river runoff + zfact = 0.5_wp + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + IF( rnf(ji,jj) /= 0._wp ) THEN + zdep = zfact / h_rnf(ji,jj) + DO jk = 1, nk_rnf(ji,jj) + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & + & + ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep + IF( ln_rnf_sal ) pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) & + & + ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep + END DO + ENDIF + END DO ; END DO + ENDIF + + IF( iom_use('rnf_x_sst') ) CALL iom_put( "rnf_x_sst", rnf*pts(:,:,1,jp_tem,Kmm) ) ! runoff term on sst + IF( iom_use('rnf_x_sss') ) CALL iom_put( "rnf_x_sss", rnf*pts(:,:,1,jp_sal,Kmm) ) ! runoff term on sss + + ! + IF( l_trdtra ) THEN ! save the horizontal diffusive trends for further diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_nsr, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_nsr, ztrds ) + DEALLOCATE( ztrdt , ztrds ) + ENDIF + ! + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' sbc - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! + IF( ln_timing ) CALL timing_stop('tra_sbc') + ! + END SUBROUTINE tra_sbc + + !!====================================================================== +END MODULE trasbc diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trazdf.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trazdf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a1a6d3d55649bb5d55677447a67fc1f290765d18 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trazdf.f90 @@ -0,0 +1,295 @@ + + + + + + + + + + + + + +MODULE trazdf + !!============================================================================== + !! *** MODULE trazdf *** + !! Ocean active tracers: vertical component of the tracer mixing trend + !!============================================================================== + !! History : 1.0 ! 2005-11 (G. Madec) Original code + !! 3.0 ! 2008-01 (C. Ethe, G. Madec) merge TRC-TRA + !! 4.0 ! 2017-06 (G. Madec) remove explict time-stepping option + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_zdf : Update the tracer trend with the vertical diffusion + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE domvvl ! variable volume + USE phycst ! physical constant + USE zdf_oce ! ocean vertical physics variables + USE zdfmfc ! Mass FLux Convection + USE sbc_oce ! surface boundary condition: ocean + USE ldftra ! lateral diffusion: eddy diffusivity + USE ldfslp ! lateral diffusion: iso-neutral slope + USE trd_oce ! trends: ocean variables + USE trdtra ! trends: tracer trend manager + USE eosbn2, ONLY: ln_SEOS, rn_b0 + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_zdf ! called by step.F90 + PUBLIC tra_zdf_imp ! called by trczdf.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trazdf.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_zdf( kt, Kbb, Kmm, Krhs, pts, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_zdf *** + !! + !! ** Purpose : compute the vertical ocean tracer physics. + !!--------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kbb, Kmm, Krhs, Kaa ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! Dummy loop indices + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_zdf') + ! + IF( kt == nit000 ) THEN + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' + IF(lwp)WRITE(numout,*) '~~~~~~~ ' + ENDIF + ENDIF + ! + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) + ENDIF + ! + ! !* compute lateral mixing trend and add it to the general trend + CALL tra_zdf_imp( kt, nit000, 'TRA', rDt, Kbb, Kmm, Krhs, pts, Kaa, jpts ) + +!!gm WHY here ! and I don't like that ! + ! DRAKKAR SSS control { + ! JMM avoid negative salinities near river outlet ! Ugly fix + ! JMM : restore negative salinities to small salinities: +!!jc: discard this correction in case salinity is not used in eos + IF ( .NOT.(ln_SEOS.AND.(rn_b0==0._wp)) ) THEN + WHERE( pts(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:,jp_sal,Kaa) < 0._wp ) pts(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:,jp_sal,Kaa) = 0.1_wp + ENDIF +!!gm + + IF( l_trdtra ) THEN ! save the vertical diffusive trends for further diagnostics + DO jk = 1, jpk + ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*(e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kaa)*tmask(:,:,jk))) & + & - pts(:,:,jk,jp_tem,Kbb)*(e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kbb)*tmask(:,:,jk))) ) & + & / ( (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk)))*rDt ) ) & + & - ztrdt(:,:,jk) + ztrds(:,:,jk) = ( ( pts(:,:,jk,jp_sal,Kaa)*(e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kaa)*tmask(:,:,jk))) & + & - pts(:,:,jk,jp_sal,Kbb)*(e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kbb)*tmask(:,:,jk))) ) & + & / ( (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk)))*rDt ) ) & + & - ztrds(:,:,jk) + END DO +!!gm this should be moved in trdtra.F90 and done on all trends + CALL lbc_lnk( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) +!!gm + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_zdf, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_zdf, ztrds ) + DEALLOCATE( ztrdt , ztrds ) + ENDIF + ! ! print mean trends (used for debugging) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kaa), clinfo1=' zdf - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Kaa), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! + IF( ln_timing ) CALL timing_stop('tra_zdf') + ! + END SUBROUTINE tra_zdf + + + SUBROUTINE tra_zdf_imp( kt, kit000, cdtype, p2dt, Kbb, Kmm, Krhs, pt, Kaa, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_zdf_imp *** + !! + !! ** Purpose : Compute the after tracer through a implicit computation + !! of the vertical tracer diffusion (including the vertical component + !! of lateral mixing (only for 2nd order operator, for fourth order + !! it is already computed and add to the general trend in traldf) + !! + !! ** Method : The vertical diffusion of a tracer ,t , is given by: + !! difft = dz( avt dz(t) ) = 1/e3t dk+1( avt/e3w dk(t) ) + !! It is computed using a backward time scheme (t=after field) + !! which provide directly the after tracer field. + !! If ln_zdfddm=T, use avs for salinity or for passive tracers + !! Surface and bottom boundary conditions: no diffusive flux on + !! both tracers (bottom, applied through the masked field avt). + !! If iso-neutral mixing, add to avt the contribution due to lateral mixing. + !! + !! ** Action : - pt(:,:,:,:,Kaa) becomes the after tracer + !!--------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: zzwi, zzws! local scalars + REAL(dp) :: zrhs! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zws + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zwi, zwt, zwd + !!--------------------------------------------------------------------- + ! + ! ! ============= ! + DO jn = 1, kjpt ! tracer loop ! + ! ! ============= ! + ! Matrix construction + ! -------------------- + ! Build matrix if temperature or salinity (only in double diffusion case) or first passive tracer + ! + IF( ( cdtype == 'TRA' .AND. ( jn == jp_tem .OR. ( jn == jp_sal .AND. ln_zdfddm ) ) ) .OR. & + & ( cdtype == 'TRC' .AND. jn == 1 ) ) THEN + ! + ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers + IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN + DO jk = 2, jpk ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + zwt(ji,jj,jk) = avt(ji,jj,jk) + END DO ; END DO ; END DO + ELSE + DO jk = 2, jpk ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) + zwt(ji,jj,jk) = avs(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + zwt(:,:,1) = 0._wp + ! + IF( l_ldfslp ) THEN ! isoneutral diffusion: add the contribution + IF( ln_traldf_msc ) THEN ! MSC iso-neutral operator + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk) + END DO ; END DO ; END DO + ELSE ! standard or triad iso-neutral operator + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ENDIF + ! + ! Diagonal, lower (i), upper (s) (including the bottom boundary condition since avt is masked) + IF( ln_zad_Aimp ) THEN ! Adaptive implicit vertical advection + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zzwi = - p2dt * zwt(ji,jj,jk ) / (e3w_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm))) + zzws = - p2dt * zwt(ji,jj,jk+1) / (e3w_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) + zwd(ji,jj,jk) = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kaa)*tmask(ji,jj,jk))) - zzwi - zzws & + & + p2dt * ( MAX( wi(ji,jj,jk ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) + zwi(ji,jj,jk) = zzwi + p2dt * MIN( wi(ji,jj,jk ) , 0._wp ) + zws(ji,jj,jk) = zzws - p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) + END DO ; END DO ; END DO + ELSE + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zwi(ji,jj,jk) = - p2dt * zwt(ji,jj,jk ) / (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + zws(ji,jj,jk) = - p2dt * zwt(ji,jj,jk+1) / (e3w_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) + zwd(ji,jj,jk) = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kaa)*tmask(ji,jj,jk))) - zwi(ji,jj,jk) - zws(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ! + ! Modification of diagonal to add MF scheme + IF ( ln_zdfmfc ) THEN + CALL diag_mfc( zwi, zwd, zws, p2dt, Kaa ) + END IF + ! + !! Matrix inversion from the first level + !!---------------------------------------------------------------------- + ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk ) + ! + ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 ) + ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 ) + ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 ) + ! ( ... )( ... ) ( ... ) + ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk ) + ! + ! m is decomposed in the product of an upper and lower triangular matrix. + ! The 3 diagonal terms are in 3d arrays: zwd, zws, zwi. + ! Suffices i,s and d indicate "inferior" (below diagonal), diagonal + ! and "superior" (above diagonal) components of the tridiagonal system. + ! The solution will be in the 4d array pta. + ! The 3d array zwt is used as a work space array. + ! En route to the solution pt(:,:,:,:,Kaa) is used a to evaluate the rhs and then + ! used as a work space array: its value is modified. + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) ! done one for all passive tracers (so included in the IF instruction) + zwt(ji,jj,1) = zwd(ji,jj,1) + END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) + END DO ; END DO ; END DO + ! + ENDIF + ! + ! Modification of rhs to add MF scheme + IF ( ln_zdfmfc ) THEN + CALL rhs_mfc( pt(:,:,:,jn,Krhs), jn ) + END IF + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + pt(ji,jj,1,jn,Kaa) = (e3t_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kbb)*tmask(ji,jj,1))) * pt(ji,jj,1,jn,Kbb) & + & + p2dt * (e3t_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,1))) * pt(ji,jj,1,jn,Krhs) + END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zrhs = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kbb)*tmask(ji,jj,jk))) * pt(ji,jj,jk,jn,Kbb) & + & + p2dt * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * pt(ji,jj,jk,jn,Krhs) ! zrhs=right hand side + pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pt(ji,jj,jk-1,jn,Kaa) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer) + pt(ji,jj,jpkm1,jn,Kaa) = pt(ji,jj,jpkm1,jn,Kaa) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) + END DO ; END DO + DO jk = jpk-2, 1, -1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pt(ji,jj,jk,jn,Kaa) = ( pt(ji,jj,jk,jn,Kaa) - zws(ji,jj,jk) * pt(ji,jj,jk+1,jn,Kaa) ) & + & / zwt(ji,jj,jk) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! ! ================= ! + END DO ! end tracer loop ! + ! ! ================= ! + END SUBROUTINE tra_zdf_imp + + !!============================================================================== +END MODULE trazdf diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trc_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trc_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..38aeb4d73faef8eb2dbbe203d2d4098b397e29be --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trc_oce.f90 @@ -0,0 +1,266 @@ + + + + + + + + + + + + + +MODULE trc_oce + !!====================================================================== + !! *** MODULE trc_oce *** + !! Ocean passive tracer : share SMS/Ocean variables + !!====================================================================== + !! History : 1.0 ! 2004-03 (C. Ethe) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trc_oce_rgb : tabulated attenuation coefficients for RGB light penetration + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE dom_oce ! ocean space and time domain + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_oce_rgb ! routine called by traqsr.F90 + PUBLIC trc_oce_rgb_read ! routine called by traqsr.F90 + PUBLIC trc_oce_ext_lev ! function called by traqsr.F90 at least + PUBLIC trc_oce_alloc ! function called by nemogcm.F90 + + LOGICAL , PUBLIC :: l_co2cpl = .false. !: atmospheric pco2 recieved from oasis + LOGICAL , PUBLIC :: l_offline = .false. !: offline passive tracers flag + REAL(wp), PUBLIC :: r_si2 !: largest depth of extinction (blue & 0.01 mg.m-3) (RGB) + LOGICAL , PUBLIC :: ln_trcdc2dm !: Diurnal cycle for TOP + ! + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: etot3 !: light absortion coefficient + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: oce_co2 !: ocean carbon flux + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_mean !: daily mean qsr + + !!---------------------------------------------------------------------- + !! Default option No bio-model light absorption + !!---------------------------------------------------------------------- + LOGICAL, PUBLIC, PARAMETER :: lk_top = .FALSE. !: TOP model + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trc_oce.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trc_oce_alloc() + !!---------------------------------------------------------------------- + !! *** trc_oce_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( etot3(jpi,jpj,jpk), oce_co2(jpi,jpj), qsr_mean(jpi,jpj), STAT=trc_oce_alloc ) + + IF( trc_oce_alloc /= 0 ) CALL ctl_warn('trc_oce_alloc: failed to allocate etot3 array') + ! + END FUNCTION trc_oce_alloc + + + SUBROUTINE trc_oce_rgb( prgb ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_opt_init *** + !! + !! ** Purpose : Initialization of of the optical scheme + !! + !! ** Method : Set a look up table for the optical coefficients + !! i.e. the attenuation coefficient for R-G-B light + !! tabulated in Chlorophyll class (from JM Andre) + !! + !! ** Action : prgb(3,61) tabulated R-G-B attenuation coef. + !! + !! Reference : Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(3,61), INTENT(out) :: prgb ! tabulated attenuation coefficient + ! + INTEGER :: jc ! dummy loop indice + INTEGER :: irgb ! temporary integer + REAL(wp) :: zchl ! temporary scalar + REAL(wp), DIMENSION(4,61) :: zrgb ! tabulated attenuation coefficient (formerly read in 'kRGB61.txt') + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' trc_oce_rgb : Initialisation of the optical look-up table' + WRITE(numout,*) ' ~~~~~~~~~~~ ' + ENDIF + ! + ! Chlorophyll ! Blue attenuation ! Green attenuation ! Red attenuation ! + zrgb(1, 1) = 0.010 ; zrgb(2, 1) = 0.01618 ; zrgb(3, 1) = 0.07464 ; zrgb(4, 1) = 0.37807 + zrgb(1, 2) = 0.011 ; zrgb(2, 2) = 0.01654 ; zrgb(3, 2) = 0.07480 ; zrgb(4, 2) = 0.37823 + zrgb(1, 3) = 0.013 ; zrgb(2, 3) = 0.01693 ; zrgb(3, 3) = 0.07499 ; zrgb(4, 3) = 0.37840 + zrgb(1, 4) = 0.014 ; zrgb(2, 4) = 0.01736 ; zrgb(3, 4) = 0.07518 ; zrgb(4, 4) = 0.37859 + zrgb(1, 5) = 0.016 ; zrgb(2, 5) = 0.01782 ; zrgb(3, 5) = 0.07539 ; zrgb(4, 5) = 0.37879 + zrgb(1, 6) = 0.018 ; zrgb(2, 6) = 0.01831 ; zrgb(3, 6) = 0.07562 ; zrgb(4, 6) = 0.37900 + zrgb(1, 7) = 0.020 ; zrgb(2, 7) = 0.01885 ; zrgb(3, 7) = 0.07586 ; zrgb(4, 7) = 0.37923 + zrgb(1, 8) = 0.022 ; zrgb(2, 8) = 0.01943 ; zrgb(3, 8) = 0.07613 ; zrgb(4, 8) = 0.37948 + zrgb(1, 9) = 0.025 ; zrgb(2, 9) = 0.02005 ; zrgb(3, 9) = 0.07641 ; zrgb(4, 9) = 0.37976 + zrgb(1,10) = 0.028 ; zrgb(2,10) = 0.02073 ; zrgb(3,10) = 0.07672 ; zrgb(4,10) = 0.38005 + zrgb(1,11) = 0.032 ; zrgb(2,11) = 0.02146 ; zrgb(3,11) = 0.07705 ; zrgb(4,11) = 0.38036 + zrgb(1,12) = 0.035 ; zrgb(2,12) = 0.02224 ; zrgb(3,12) = 0.07741 ; zrgb(4,12) = 0.38070 + zrgb(1,13) = 0.040 ; zrgb(2,13) = 0.02310 ; zrgb(3,13) = 0.07780 ; zrgb(4,13) = 0.38107 + zrgb(1,14) = 0.045 ; zrgb(2,14) = 0.02402 ; zrgb(3,14) = 0.07821 ; zrgb(4,14) = 0.38146 + zrgb(1,15) = 0.050 ; zrgb(2,15) = 0.02501 ; zrgb(3,15) = 0.07866 ; zrgb(4,15) = 0.38189 + zrgb(1,16) = 0.056 ; zrgb(2,16) = 0.02608 ; zrgb(3,16) = 0.07914 ; zrgb(4,16) = 0.38235 + zrgb(1,17) = 0.063 ; zrgb(2,17) = 0.02724 ; zrgb(3,17) = 0.07967 ; zrgb(4,17) = 0.38285 + zrgb(1,18) = 0.071 ; zrgb(2,18) = 0.02849 ; zrgb(3,18) = 0.08023 ; zrgb(4,18) = 0.38338 + zrgb(1,19) = 0.079 ; zrgb(2,19) = 0.02984 ; zrgb(3,19) = 0.08083 ; zrgb(4,19) = 0.38396 + zrgb(1,20) = 0.089 ; zrgb(2,20) = 0.03131 ; zrgb(3,20) = 0.08149 ; zrgb(4,20) = 0.38458 + zrgb(1,21) = 0.100 ; zrgb(2,21) = 0.03288 ; zrgb(3,21) = 0.08219 ; zrgb(4,21) = 0.38526 + zrgb(1,22) = 0.112 ; zrgb(2,22) = 0.03459 ; zrgb(3,22) = 0.08295 ; zrgb(4,22) = 0.38598 + zrgb(1,23) = 0.126 ; zrgb(2,23) = 0.03643 ; zrgb(3,23) = 0.08377 ; zrgb(4,23) = 0.38676 + zrgb(1,24) = 0.141 ; zrgb(2,24) = 0.03842 ; zrgb(3,24) = 0.08466 ; zrgb(4,24) = 0.38761 + zrgb(1,25) = 0.158 ; zrgb(2,25) = 0.04057 ; zrgb(3,25) = 0.08561 ; zrgb(4,25) = 0.38852 + zrgb(1,26) = 0.178 ; zrgb(2,26) = 0.04289 ; zrgb(3,26) = 0.08664 ; zrgb(4,26) = 0.38950 + zrgb(1,27) = 0.200 ; zrgb(2,27) = 0.04540 ; zrgb(3,27) = 0.08775 ; zrgb(4,27) = 0.39056 + zrgb(1,28) = 0.224 ; zrgb(2,28) = 0.04811 ; zrgb(3,28) = 0.08894 ; zrgb(4,28) = 0.39171 + zrgb(1,29) = 0.251 ; zrgb(2,29) = 0.05103 ; zrgb(3,29) = 0.09023 ; zrgb(4,29) = 0.39294 + zrgb(1,30) = 0.282 ; zrgb(2,30) = 0.05420 ; zrgb(3,30) = 0.09162 ; zrgb(4,30) = 0.39428 + zrgb(1,31) = 0.316 ; zrgb(2,31) = 0.05761 ; zrgb(3,31) = 0.09312 ; zrgb(4,31) = 0.39572 + zrgb(1,32) = 0.355 ; zrgb(2,32) = 0.06130 ; zrgb(3,32) = 0.09474 ; zrgb(4,32) = 0.39727 + zrgb(1,33) = 0.398 ; zrgb(2,33) = 0.06529 ; zrgb(3,33) = 0.09649 ; zrgb(4,33) = 0.39894 + zrgb(1,34) = 0.447 ; zrgb(2,34) = 0.06959 ; zrgb(3,34) = 0.09837 ; zrgb(4,34) = 0.40075 + zrgb(1,35) = 0.501 ; zrgb(2,35) = 0.07424 ; zrgb(3,35) = 0.10040 ; zrgb(4,35) = 0.40270 + zrgb(1,36) = 0.562 ; zrgb(2,36) = 0.07927 ; zrgb(3,36) = 0.10259 ; zrgb(4,36) = 0.40480 + zrgb(1,37) = 0.631 ; zrgb(2,37) = 0.08470 ; zrgb(3,37) = 0.10495 ; zrgb(4,37) = 0.40707 + zrgb(1,38) = 0.708 ; zrgb(2,38) = 0.09056 ; zrgb(3,38) = 0.10749 ; zrgb(4,38) = 0.40952 + zrgb(1,39) = 0.794 ; zrgb(2,39) = 0.09690 ; zrgb(3,39) = 0.11024 ; zrgb(4,39) = 0.41216 + zrgb(1,40) = 0.891 ; zrgb(2,40) = 0.10374 ; zrgb(3,40) = 0.11320 ; zrgb(4,40) = 0.41502 + zrgb(1,41) = 1.000 ; zrgb(2,41) = 0.11114 ; zrgb(3,41) = 0.11639 ; zrgb(4,41) = 0.41809 + zrgb(1,42) = 1.122 ; zrgb(2,42) = 0.11912 ; zrgb(3,42) = 0.11984 ; zrgb(4,42) = 0.42142 + zrgb(1,43) = 1.259 ; zrgb(2,43) = 0.12775 ; zrgb(3,43) = 0.12356 ; zrgb(4,43) = 0.42500 + zrgb(1,44) = 1.413 ; zrgb(2,44) = 0.13707 ; zrgb(3,44) = 0.12757 ; zrgb(4,44) = 0.42887 + zrgb(1,45) = 1.585 ; zrgb(2,45) = 0.14715 ; zrgb(3,45) = 0.13189 ; zrgb(4,45) = 0.43304 + zrgb(1,46) = 1.778 ; zrgb(2,46) = 0.15803 ; zrgb(3,46) = 0.13655 ; zrgb(4,46) = 0.43754 + zrgb(1,47) = 1.995 ; zrgb(2,47) = 0.16978 ; zrgb(3,47) = 0.14158 ; zrgb(4,47) = 0.44240 + zrgb(1,48) = 2.239 ; zrgb(2,48) = 0.18248 ; zrgb(3,48) = 0.14701 ; zrgb(4,48) = 0.44765 + zrgb(1,49) = 2.512 ; zrgb(2,49) = 0.19620 ; zrgb(3,49) = 0.15286 ; zrgb(4,49) = 0.45331 + zrgb(1,50) = 2.818 ; zrgb(2,50) = 0.21102 ; zrgb(3,50) = 0.15918 ; zrgb(4,50) = 0.45942 + zrgb(1,51) = 3.162 ; zrgb(2,51) = 0.22703 ; zrgb(3,51) = 0.16599 ; zrgb(4,51) = 0.46601 + zrgb(1,52) = 3.548 ; zrgb(2,52) = 0.24433 ; zrgb(3,52) = 0.17334 ; zrgb(4,52) = 0.47313 + zrgb(1,53) = 3.981 ; zrgb(2,53) = 0.26301 ; zrgb(3,53) = 0.18126 ; zrgb(4,53) = 0.48080 + zrgb(1,54) = 4.467 ; zrgb(2,54) = 0.28320 ; zrgb(3,54) = 0.18981 ; zrgb(4,54) = 0.48909 + zrgb(1,55) = 5.012 ; zrgb(2,55) = 0.30502 ; zrgb(3,55) = 0.19903 ; zrgb(4,55) = 0.49803 + zrgb(1,56) = 5.623 ; zrgb(2,56) = 0.32858 ; zrgb(3,56) = 0.20898 ; zrgb(4,56) = 0.50768 + zrgb(1,57) = 6.310 ; zrgb(2,57) = 0.35404 ; zrgb(3,57) = 0.21971 ; zrgb(4,57) = 0.51810 + zrgb(1,58) = 7.079 ; zrgb(2,58) = 0.38154 ; zrgb(3,58) = 0.23129 ; zrgb(4,58) = 0.52934 + zrgb(1,59) = 7.943 ; zrgb(2,59) = 0.41125 ; zrgb(3,59) = 0.24378 ; zrgb(4,59) = 0.54147 + zrgb(1,60) = 8.912 ; zrgb(2,60) = 0.44336 ; zrgb(3,60) = 0.25725 ; zrgb(4,60) = 0.55457 + zrgb(1,61) = 10.000 ; zrgb(2,61) = 0.47804 ; zrgb(3,61) = 0.27178 ; zrgb(4,61) = 0.56870 + ! + prgb(:,:) = zrgb(2:4,:) + ! + r_si2 = 1.e0 / zrgb(2, 1) ! blue with the smallest chlorophyll concentration) + IF(lwp) WRITE(numout,*) ' RGB longest depth of extinction r_si2 = ', r_si2 + ! + DO jc = 1, 61 ! check + zchl = zrgb(1,jc) + irgb = NINT( 41 + 20.* LOG10( zchl ) + 1.e-15 ) + IF( irgb /= jc ) THEN + IF(lwp) WRITE(numout,*) ' jc =', jc, ' Chl = ', zchl, ' Chl class = ', irgb + CALL ctl_stop( 'trc_oce_rgb : inconsistency in Chl tabulated attenuation coeff.' ) + ENDIF + END DO + ! + END SUBROUTINE trc_oce_rgb + + + SUBROUTINE trc_oce_rgb_read( prgb ) + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_opt_init *** + !! + !! ** Purpose : Initialization of of the optical scheme + !! + !! ** Method : read the look up table for the optical coefficients + !! + !! ** input : xkrgb(61) precomputed array corresponding to the + !! attenuation coefficient (from JM Andre) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(3,61), INTENT(out) :: prgb ! tabulated attenuation coefficient + ! + INTEGER :: jc, jb ! dummy loop indice + INTEGER :: irgb ! temporary integer + REAL(wp) :: zchl ! temporary scalar + INTEGER :: numlight + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' trc_oce_rgb_read : optical look-up table read in kRGB61.txt file' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~' + WRITE(numout,*) + ENDIF + ! + CALL ctl_opn( numlight, 'kRGB61.txt', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + DO jc = 1, 61 + READ(numlight,*) zchl, ( prgb(jb,jc), jb = 1, 3 ) + irgb = NINT( 41 + 20.* LOG10( zchl ) + 1.e-15 ) + IF(lwp) WRITE(numout,*) ' jc =', jc, ' Chl = ', zchl, ' irgb = ', irgb + IF( irgb /= jc ) THEN + IF(lwp) WRITE(numout,*) ' jc =', jc, ' Chl = ', zchl, ' Chl class = ', irgb + CALL ctl_stop( 'trc_oce_rgb_read : inconsistency in Chl tabulated attenuation coeff.' ) + ENDIF + END DO + CLOSE( numlight ) + ! + r_si2 = 1.e0 / prgb(1, 1) ! blue with the smallest chlorophyll concentration) + IF(lwp) WRITE(numout,*) ' RGB longest depth of extinction r_si2 = ', r_si2 + ! + END SUBROUTINE trc_oce_rgb_read + + + FUNCTION trc_oce_ext_lev( prldex, pqsr_frc ) RESULT( pjl ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_oce_ext_lev *** + !! + !! ** Purpose : compute max. level for light penetration + !! + !! ** Method : the function provides the level at which irradiance + !! becomes negligible (i.e. = 1.e-15 W/m2) for 3 or 2 bands light + !! penetration: I(z) = pqsr_frc * EXP(hext/prldex) = 1.e-15 W/m2 + !! # prldex is the longest depth of extinction: + !! - prldex = 23 m (2 bands case) + !! - prldex = 62 m (3 bands case: blue waveband & 0.01 mg/m2 for the chlorophyll) + !! # pqsr_frc is the fraction of solar radiation which penetrates, + !! considering Qsr=240 W/m2 and rn_abs = 0.58: + !! - pqsr_frc = Qsr * (1-rn_abs) = 1.00e2 W/m2 (2 bands case) + !! - pqsr_frc = Qsr * (1-rn_abs)/3 = 0.33e2 W/m2 (3 bands case & equi-partition) + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: prldex ! longest depth of extinction + REAL(wp), INTENT(in) :: pqsr_frc ! frac. solar radiation which penetrates + ! + INTEGER :: jk, pjl ! levels + REAL(wp) :: zhext ! deepest level till which light penetrates + REAL(wp) :: zprec = 15._wp ! precision to reach -LOG10(1.e-15) + REAL(wp) :: zem ! temporary scalar + !!---------------------------------------------------------------------- + ! + ! It is not necessary to compute anything below the following depth + zhext = prldex * ( LOG(10._wp) * zprec + LOG(pqsr_frc) ) + ! + ! Level of light extinction + pjl = jpkm1 + DO jk = jpkm1, 1, -1 + IF(SUM(tmask(:,:,jk)) > 0 ) THEN + zem = MAXVAL( gdepw_0(:,:,jk+1) * tmask(:,:,jk) ) + IF( zem >= zhext ) pjl = jk ! last T-level reached by Qsr + ELSE + pjl = jk ! or regional sea-bed depth + ENDIF + END DO + ! + END FUNCTION trc_oce_ext_lev + + !!====================================================================== +END MODULE trc_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trd_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trd_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5313f98c4e5720fac1ae28be8c2bf8aa54b78f0a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trd_oce.f90 @@ -0,0 +1,92 @@ + + + + + + + + + + + + + +MODULE trd_oce + !!====================================================================== + !! *** MODULE trd_oce *** + !! Ocean trends : set tracer and momentum trend variables + !!====================================================================== + !! History : 1.0 ! 2004-08 (C. Talandier) Original code + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE trdmxl_oce ! ocean active mixed layer tracers trends variables + USE trdvor_oce ! ocean vorticity trends variables + + IMPLICIT NONE + PUBLIC + + ! !!* Namelist namtrd: diagnostics on dynamics/tracer trends * + LOGICAL , PUBLIC :: ln_dyn_trd = .FALSE. !: (T) 3D momentum trends or (F) not + LOGICAL , PUBLIC :: ln_tra_trd = .FALSE. !: (T) 3D tracer trends or (F) not + LOGICAL , PUBLIC :: ln_KE_trd = .FALSE. !: (T) 3D Kinetic Energy trends or (F) not + LOGICAL , PUBLIC :: ln_PE_trd = .FALSE. !: (T) 3D Potential Energy trends or (F) not + LOGICAL , PUBLIC :: ln_vor_trd = .FALSE. !: (T) 3D barotropic vorticity trends or (F) not + LOGICAL , PUBLIC :: ln_glo_trd = .FALSE. !: (T) global domain averaged diag for T, T^2, KE, and PE + LOGICAL , PUBLIC :: ln_dyn_mxl = .FALSE. !: (T) 2D tracer trends averaged over the mixed layer + LOGICAL , PUBLIC :: ln_tra_mxl = .FALSE. !: (T) 2D momentum trends averaged over the mixed layer + INTEGER , PUBLIC :: nn_trd = 10 !: time step frequency for ln_glo_trd=T only + + LOGICAL , PUBLIC :: l_trdtra !: tracers trend flag (set from namelist in trdini) + LOGICAL , PUBLIC :: l_trddyn !: momentum trend flag (set from namelist in trdini) + + LOGICAL , PUBLIC :: l_trdtrc = .FALSE. !: tracers trend flag + ! !!!* Active tracers trends indexes + INTEGER, PUBLIC, PARAMETER :: jptot_tra = 21 !: Total trend nb: change it when adding/removing one indice below + ! =============== ! + INTEGER, PUBLIC, PARAMETER :: jptra_xad = 1 !: x- horizontal advection + INTEGER, PUBLIC, PARAMETER :: jptra_yad = 2 !: y- horizontal advection + INTEGER, PUBLIC, PARAMETER :: jptra_zad = 3 !: z- vertical advection + INTEGER, PUBLIC, PARAMETER :: jptra_sad = 4 !: z- vertical advection + INTEGER, PUBLIC, PARAMETER :: jptra_totad = 5 !: total advection + INTEGER, PUBLIC, PARAMETER :: jptra_ldf = 6 !: lateral diffusion + INTEGER, PUBLIC, PARAMETER :: jptra_zdf = 7 !: vertical diffusion + INTEGER, PUBLIC, PARAMETER :: jptra_zdfp = 8 !: "PURE" vert. diffusion (ln_traldf_iso=T) + INTEGER, PUBLIC, PARAMETER :: jptra_evd = 9 !: EVD term (convection) + INTEGER, PUBLIC, PARAMETER :: jptra_bbc = 10 !: Bottom Boundary Condition (geoth. heating) + INTEGER, PUBLIC, PARAMETER :: jptra_bbl = 11 !: Bottom Boundary Layer (diffusive and/or advective) + INTEGER, PUBLIC, PARAMETER :: jptra_osm = 21 !: Non-local terms from OSMOSIS OBL model + INTEGER, PUBLIC, PARAMETER :: jptra_npc = 12 !: non-penetrative convection treatment + INTEGER, PUBLIC, PARAMETER :: jptra_dmp = 13 !: internal restoring (damping) + INTEGER, PUBLIC, PARAMETER :: jptra_qsr = 14 !: penetrative solar radiation + INTEGER, PUBLIC, PARAMETER :: jptra_nsr = 15 !: non solar radiation / C/D on salinity (+runoff if ln_rnf=T) + INTEGER, PUBLIC, PARAMETER :: jptra_atf = 16 !: Asselin time filter + INTEGER, PUBLIC, PARAMETER :: jptra_tot = 17 !: Model total trend + ! + ! !!!* Passive tracers trends indices (use if "key_top" defined) + INTEGER, PUBLIC, PARAMETER :: jptra_sms = 18 !: sources m. sinks + INTEGER, PUBLIC, PARAMETER :: jptra_radn = 19 !: corr. trn<0 in trcrad + INTEGER, PUBLIC, PARAMETER :: jptra_radb = 20 !: corr. trb<0 in trcrad (like atf) + ! + ! !!!* Momentum trends indices + INTEGER, PUBLIC, PARAMETER :: jptot_dyn = 13 !: Total trend nb: change it when adding/removing one indice below + ! =============== ! + INTEGER, PUBLIC, PARAMETER :: jpdyn_hpg = 1 !: hydrostatic pressure gradient + INTEGER, PUBLIC, PARAMETER :: jpdyn_spg = 2 !: surface pressure gradient + INTEGER, PUBLIC, PARAMETER :: jpdyn_keg = 3 !: kinetic energy gradient or horizontal advection + INTEGER, PUBLIC, PARAMETER :: jpdyn_rvo = 4 !: relative vorticity or metric term + INTEGER, PUBLIC, PARAMETER :: jpdyn_pvo = 5 !: planetary vorticity + INTEGER, PUBLIC, PARAMETER :: jpdyn_zad = 6 !: vertical advection + INTEGER, PUBLIC, PARAMETER :: jpdyn_ldf = 7 !: horizontal diffusion + INTEGER, PUBLIC, PARAMETER :: jpdyn_zdf = 8 !: vertical diffusion + INTEGER, PUBLIC, PARAMETER :: jpdyn_bfr = 9 !: bottom stress + INTEGER, PUBLIC, PARAMETER :: jpdyn_atf = 10 !: Asselin time filter + INTEGER, PUBLIC, PARAMETER :: jpdyn_tau = 11 !: surface stress + INTEGER, PUBLIC, PARAMETER :: jpdyn_bfri = 12 !: implicit bottom friction (ln_drgimp=.TRUE.) + INTEGER, PUBLIC, PARAMETER :: jpdyn_ken = 13 !: use for calculation of KE + ! + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trd_oce.F90 14239 2020-12-23 08:57:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trd_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trddyn.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trddyn.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a22dd3511511149b1c4353523cb946abb15a7218 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trddyn.f90 @@ -0,0 +1,210 @@ + + + + + + + + + + + + + +MODULE trddyn + !!====================================================================== + !! *** MODULE trddyn *** + !! Ocean diagnostics: ocean dynamic trends + !!===================================================================== + !! History : 3.5 ! 2012-02 (G. Madec) creation from trdmod: split DYN and TRA trends + !! and manage 3D trends output for U, V, and KE + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_dyn : manage the type of momentum trend diagnostics (3D I/O, domain averaged, KE) + !! trd_dyn_iom : output 3D momentum and/or tracer trends using IOM + !! trd_dyn_init : initialization step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE phycst ! physical constants + USE sbc_oce ! surface boundary condition: ocean + USE zdf_oce ! ocean vertical physics: variables +!!gm USE zdfdrg ! ocean vertical physics: bottom friction + USE trd_oce ! trends: ocean variables + USE trdken ! trends: Kinetic ENergy + USE trdglo ! trends: global domain averaged + USE trdvor ! trends: vertical averaged vorticity + USE trdmxl ! trends: mixed layer averaged + ! + USE in_out_manager ! I/O manager + USE lbclnk ! lateral boundary condition + USE iom ! I/O manager library + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_dyn ! called by all dynXXX modules + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trddyn.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_dyn( putrd, pvtrd, ktrd, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_mod *** + !! + !! ** Purpose : Dispatch momentum trend computation, e.g. 3D output, + !! integral constraints, barotropic vorticity, kinetic enrgy, + !! and/or mixed layer budget. + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + !!---------------------------------------------------------------------- + ! + putrd(:,:,:) = putrd(:,:,:) * umask(:,:,:) ! mask the trends + pvtrd(:,:,:) = pvtrd(:,:,:) * vmask(:,:,:) + ! + +!!gm NB : here a lbc_lnk should probably be added + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! 3D output of momentum and/or tracers trends using IOM interface + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_dyn_trd ) CALL trd_dyn_iom( putrd, pvtrd, ktrd, kt, Kmm ) + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! Integral Constraints Properties for momentum and/or tracers trends + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_glo_trd ) CALL trd_glo( putrd, pvtrd, ktrd, 'DYN', kt, Kmm ) + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! Kinetic Energy trends + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF( ln_KE_trd ) CALL trd_ken( putrd, pvtrd, ktrd, kt, Kmm ) + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! Vorticity trends + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF( ln_vor_trd ) CALL trd_vor( putrd, pvtrd, ktrd, kt, Kmm ) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Mixed layer trends for active tracers + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!!gm IF( ln_dyn_mxl ) CALL trd_mxl_dyn + ! + END SUBROUTINE trd_dyn + + + SUBROUTINE trd_dyn_iom( putrd, pvtrd, ktrd, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_dyn_iom *** + !! + !! ** Purpose : output 3D trends using IOM + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbu, ikbv ! local integers + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2dx, z2dy ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3dx, z3dy ! 3D workspace + !!---------------------------------------------------------------------- + ! + SELECT CASE( ktrd ) + CASE( jpdyn_hpg ) ; CALL iom_put( "utrd_hpg", putrd ) ! hydrostatic pressure gradient + CALL iom_put( "vtrd_hpg", pvtrd ) + CASE( jpdyn_spg ) ; CALL iom_put( "utrd_spg", putrd ) ! surface pressure gradient + CALL iom_put( "vtrd_spg", pvtrd ) + CASE( jpdyn_pvo ) ; CALL iom_put( "utrd_pvo", putrd ) ! planetary vorticity + CALL iom_put( "vtrd_pvo", pvtrd ) + CASE( jpdyn_rvo ) ; CALL iom_put( "utrd_rvo", putrd ) ! relative vorticity (or metric term) + CALL iom_put( "vtrd_rvo", pvtrd ) + CASE( jpdyn_keg ) ; CALL iom_put( "utrd_keg", putrd ) ! Kinetic Energy gradient (or had) + CALL iom_put( "vtrd_keg", pvtrd ) + ALLOCATE( z3dx(jpi,jpj,jpk) , z3dy(jpi,jpj,jpk) ) + z3dx(:,:,:) = 0._wp ! U.dxU & V.dyV (approximation) + z3dy(:,:,:) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! no mask as un,vn are masked + z3dx(ji,jj,jk) = uu(ji,jj,jk,Kmm) * ( uu(ji+1,jj,jk,Kmm) - uu(ji-1,jj,jk,Kmm) ) / ( 2._wp * e1u(ji,jj) ) + z3dy(ji,jj,jk) = vv(ji,jj,jk,Kmm) * ( vv(ji,jj+1,jk,Kmm) - vv(ji,jj-1,jk,Kmm) ) / ( 2._wp * e2v(ji,jj) ) + END DO ; END DO ; END DO + CALL lbc_lnk( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) + CALL iom_put( "utrd_udx", z3dx ) + CALL iom_put( "vtrd_vdy", z3dy ) + DEALLOCATE( z3dx , z3dy ) + CASE( jpdyn_zad ) ; CALL iom_put( "utrd_zad", putrd ) ! vertical advection + CALL iom_put( "vtrd_zad", pvtrd ) + CASE( jpdyn_ldf ) ; CALL iom_put( "utrd_ldf", putrd ) ! lateral diffusion + CALL iom_put( "vtrd_ldf", pvtrd ) + CASE( jpdyn_zdf ) ; CALL iom_put( "utrd_zdf", putrd ) ! vertical diffusion + CALL iom_put( "vtrd_zdf", pvtrd ) + ! + ! ! wind stress trends + ALLOCATE( z2dx(jpi,jpj) , z2dy(jpi,jpj) ) + z2dx(:,:) = ( utau_b(:,:) + utau(:,:) ) / ( (e3u_0(:,:,1)*(1._wp+r3u(:,:,Kmm)*umask(:,:,1))) * rho0 ) + z2dy(:,:) = ( vtau_b(:,:) + vtau(:,:) ) / ( (e3v_0(:,:,1)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,1))) * rho0 ) + CALL iom_put( "utrd_tau", z2dx ) + CALL iom_put( "vtrd_tau", z2dy ) + DEALLOCATE( z2dx , z2dy ) +!!gm to be changed : computation should be done in dynzdf.F90 +!!gm + missing the top friction +! ! ! bottom stress tends (implicit case) +! IF( ln_drgimp ) THEN +! ALLOCATE( z3dx(jpi,jpj,jpk) , z3dy(jpi,jpj,jpk) ) +! z3dx(:,:,:) = 0._wp ; z3dy(:,:,:) = 0._wp ! after velocity known (now filed at this stage) +! DO jk = 1, jpkm1 +! DO jj = 2, jpjm1 +! DO ji = 2, jpim1 +! ikbu = mbku(ji,jj) ! deepest ocean u- & v-levels +! ikbv = mbkv(ji,jj) +! z3dx(ji,jj,jk) = 0.5 * ( rCdU_bot(ji+1,jj) + rCdU_bot(ji,jj) ) & +! & * uu(ji,jj,ikbu,Kmm) / (e3u_0(ji,jj,ikbu)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,ikbu))) +! z3dy(ji,jj,jk) = 0.5 * ( rCdU_bot(ji,jj+1) + rCdU_bot(ji,jj) ) & +! & * vv(ji,jj,ikbv,Kmm) / (e3v_0(ji,jj,ikbv)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,ikbv))) +! END DO +! END DO +! END DO +! CALL lbc_lnk( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) +! CALL iom_put( "utrd_bfr", z3dx ) +! CALL iom_put( "vtrd_bfr", z3dy ) +! DEALLOCATE( z3dx , z3dy ) +! ENDIF +!!gm end + CASE( jpdyn_bfr ) ! called if ln_drgimp=F + CALL iom_put( "utrd_bfr", putrd ) ! bottom friction (explicit case) + CALL iom_put( "vtrd_bfr", pvtrd ) + CASE( jpdyn_atf ) ; CALL iom_put( "utrd_atf", putrd ) ! asselin filter trends + CALL iom_put( "vtrd_atf", pvtrd ) + END SELECT + ! + END SUBROUTINE trd_dyn_iom + + !!====================================================================== +END MODULE trddyn diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdglo.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdglo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..73d8811f3ae4964bb52d23cc0ad96edecac8cea1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdglo.f90 @@ -0,0 +1,575 @@ + + + + + + + + + + + + + +MODULE trdglo + !!====================================================================== + !! *** MODULE trdglo *** + !! Ocean diagnostics: global domain averaged tracer and momentum trends + !!===================================================================== + !! History : 1.0 ! 2004-08 (C. Talandier) New trends organization + !! 3.5 ! 2012-02 (G. Madec) add 3D tracer zdf trend output using iom + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_glo : domain averaged budget of trends (including kinetic energy and T^2 trends) + !! glo_dyn_wri : print dynamic trends in ocean.output file + !! glo_tra_wri : print global T & T^2 trends in ocean.output file + !! trd_glo_init : initialization step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! surface boundary condition: ocean + USE trd_oce ! trends: ocean variables + USE phycst ! physical constants + USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. + USE ldfdyn ! ocean dynamics: lateral physics + USE zdf_oce ! ocean vertical physics +!!gm USE zdfdrg ! ocean vertical physics: bottom friction + USE zdfddm ! ocean vertical physics: double diffusion + USE eosbn2 ! equation of state + USE phycst ! physical constants + ! + USE lib_mpp ! distibuted memory computing library + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_glo ! called by trdtra and trddyn modules + PUBLIC trd_glo_init ! called by trdini module + + ! !!! Variables used for diagnostics + REAL(wp) :: tvolt ! volume of the whole ocean computed at t-points + REAL(wp) :: tvolu ! volume of the whole ocean computed at u-points + REAL(wp) :: tvolv ! volume of the whole ocean computed at v-points + REAL(wp) :: rpktrd ! potential to kinetic energy conversion + REAL(wp) :: peke ! conversion potential energy - kinetic energy trend + + ! !!! domain averaged trends + REAL(wp), DIMENSION(jptot_tra) :: tmo, smo ! temperature and salinity trends + REAL(wp), DIMENSION(jptot_tra) :: t2 , s2 ! T^2 and S^2 trends + REAL(wp), DIMENSION(jptot_dyn) :: umo, vmo ! momentum trends + REAL(wp), DIMENSION(jptot_dyn) :: hke ! kinetic energy trends (u^2+v^2) + + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdglo.F90 13497 2020-09-21 12:37:46Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_glo( ptrdx, ptrdy, ktrd, ctype, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_glo *** + !! + !! ** Purpose : compute and print global domain averaged trends for + !! T, T^2, momentum, KE, and KE<->PE + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend + INTEGER , INTENT(in ) :: ktrd ! tracer trend index + CHARACTER(len=3) , INTENT(in ) :: ctype ! momentum or tracers trends type (='DYN'/'TRA') + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbu, ikbv ! local integers + REAL(wp):: zvm, zvt, zvs, z1_2rho0 ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: ztswu, ztswv, z2dx, z2dy ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( MOD(kt,nn_trd) == 0 .OR. kt == nit000 .OR. kt == nitend ) THEN + ! + SELECT CASE( ctype ) + ! + CASE( 'TRA' ) !== Tracers (T & S) ==! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) ! global sum of mask volume trend and trend*T (including interior mask) + zvm = e1e2t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * tmask(ji,jj,jk) * tmask_i(ji,jj) + zvt = ptrdx(ji,jj,jk) * zvm + zvs = ptrdy(ji,jj,jk) * zvm + tmo(ktrd) = tmo(ktrd) + zvt + smo(ktrd) = smo(ktrd) + zvs + t2 (ktrd) = t2(ktrd) + zvt * ts(ji,jj,jk,jp_tem,Kmm) + s2 (ktrd) = s2(ktrd) + zvs * ts(ji,jj,jk,jp_sal,Kmm) + END DO ; END DO ; END DO + ! ! linear free surface: diagnose advective flux trough the fixed k=1 w-surface + IF( ln_linssh .AND. ktrd == jptra_zad ) THEN + tmo(jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_tem,Kmm) * e1e2t(:,:) * tmask_i(:,:) ) + smo(jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_sal,Kmm) * e1e2t(:,:) * tmask_i(:,:) ) + t2 (jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_tem,Kmm) * ts(:,:,1,jp_tem,Kmm) * e1e2t(:,:) * tmask_i(:,:) ) + s2 (jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_sal,Kmm) * ts(:,:,1,jp_sal,Kmm) * e1e2t(:,:) * tmask_i(:,:) ) + ENDIF + ! + IF( ktrd == jptra_atf ) THEN ! last trend (asselin time filter) + ! + CALL glo_tra_wri( kt ) ! print the results in ocean.output + ! + tmo(:) = 0._wp ! prepare the next time step (domain averaged array reset to zero) + smo(:) = 0._wp + t2 (:) = 0._wp + s2 (:) = 0._wp + ! + ENDIF + ! + CASE( 'DYN' ) !== Momentum and KE ==! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) + zvt = ptrdx(ji,jj,jk) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk) & + & * e1e2u (ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + zvs = ptrdy(ji,jj,jk) * tmask_i(ji,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) & + & * e1e2v (ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + umo(ktrd) = umo(ktrd) + zvt + vmo(ktrd) = vmo(ktrd) + zvs + hke(ktrd) = hke(ktrd) + uu(ji,jj,jk,Kmm) * zvt + vv(ji,jj,jk,Kmm) * zvs + END DO ; END DO ; END DO + ! + IF( ktrd == jpdyn_zdf ) THEN ! zdf trend: compute separately the surface forcing trend + z1_2rho0 = 0.5_wp / rho0 + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + zvt = ( utau_b(ji,jj) + utau(ji,jj) ) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk) & + & * z1_2rho0 * e1e2u(ji,jj) + zvs = ( vtau_b(ji,jj) + vtau(ji,jj) ) * tmask_i(ji,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) & + & * z1_2rho0 * e1e2v(ji,jj) + umo(jpdyn_tau) = umo(jpdyn_tau) + zvt + vmo(jpdyn_tau) = vmo(jpdyn_tau) + zvs + hke(jpdyn_tau) = hke(jpdyn_tau) + uu(ji,jj,1,Kmm) * zvt + vv(ji,jj,1,Kmm) * zvs + END DO ; END DO + ENDIF + ! +!!gm miss placed calculation ===>>>> to be done in dynzdf.F90 +! IF( ktrd == jpdyn_atf ) THEN ! last trend (asselin time filter) +! ! +! IF( ln_drgimp ) THEN ! implicit drag case: compute separately the bottom friction +! z1_2rho0 = 0.5_wp / rho0 +! DO jj = 1, jpjm1 +! DO ji = 1, jpim1 +! ikbu = mbku(ji,jj) ! deepest ocean u- & v-levels +! ikbv = mbkv(ji,jj) +! zvt = 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * uu(ji,jj,ikbu,Kmm) * e1e2u(ji,jj) +! zvs = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv(ji,jj,ikbv,Kmm) * e1e2v(ji,jj) +! umo(jpdyn_bfri) = umo(jpdyn_bfri) + zvt +! vmo(jpdyn_bfri) = vmo(jpdyn_bfri) + zvs +! hke(jpdyn_bfri) = hke(jpdyn_bfri) + uu(ji,jj,ikbu,Kmm) * zvt + vv(ji,jj,ikbv,Kmm) * zvs +! END DO +! END DO +! ENDIF +! +!!gm top drag case is missing +! +! ! +! CALL glo_dyn_wri( kt ) ! print the results in ocean.output +! ! +! umo(:) = 0._wp ! reset for the next time step +! vmo(:) = 0._wp +! hke(:) = 0._wp +! ! +! ENDIF +!!gm end + ! + END SELECT + ! + ENDIF + ! + END SUBROUTINE trd_glo + + + SUBROUTINE glo_dyn_wri( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE glo_dyn_wri *** + !! + !! ** Purpose : write global averaged U, KE, PE<->KE trends in ocean.output + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcof ! local scalar + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zkx, zky, zkz, zkepe + !!---------------------------------------------------------------------- + + ! I. Momentum trends + ! ------------------- + + IF( MOD( kt, nn_trd ) == 0 .OR. kt == nit000 .OR. kt == nitend ) THEN + + ! I.1 Conversion potential energy - kinetic energy + ! -------------------------------------------------- + ! c a u t i o n here, trends are computed at kt+1 (now , but after the swap) + zkx (:,:,:) = 0._wp + zky (:,:,:) = 0._wp + zkz (:,:,:) = 0._wp + zkepe(:,:,:) = 0._wp + + CALL eos( ts(:,:,:,:,Kmm), rhd, REAL(rhop,sp) ) ! now potential density + + zcof = 0.5_wp / rho0 ! Density flux at w-point + zkz(:,:,1) = 0._wp + DO jk = 2, jpk + zkz(:,:,jk) = zcof * e1e2t(:,:) * ww(:,:,jk) * ( rhop(:,:,jk) + rhop(:,:,jk-1) ) * tmask_i(:,:) + END DO + + zcof = 0.5_wp / rho0 ! Density flux at u and v-points + DO jk = 1, jpkm1 ; DO jj = ntsj-( 1), ntej+( 0) ; DO ji = ntsi-( 1), ntei+( 0) + zkx(ji,jj,jk) = zcof * e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) & + & * uu(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji+1,jj,jk) ) + zky(ji,jj,jk) = zcof * e1v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) & + & * vv(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) ) + END DO ; END DO ; END DO + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! Density flux divergence at t-point + zkepe(ji,jj,jk) = - ( zkz(ji,jj,jk) - zkz(ji ,jj ,jk+1) & + & + zkx(ji,jj,jk) - zkx(ji-1,jj ,jk ) & + & + zky(ji,jj,jk) - zky(ji ,jj-1,jk ) ) & + & / ( e1e2t(ji,jj) * (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) ) * tmask(ji,jj,jk) * tmask_i(ji,jj) + END DO ; END DO ; END DO + + ! I.2 Basin averaged kinetic energy trend + ! ---------------------------------------- + peke = 0._wp + DO jk = 1, jpkm1 + peke = peke + SUM( zkepe(:,:,jk) * (gdept_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) * e1e2t(:,:) & + & * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) ) + END DO + peke = grav * peke + + ! I.3 Sums over the global domain + ! --------------------------------- + IF( lk_mpp ) THEN + CALL mpp_sum( 'trdglo', peke ) + CALL mpp_sum( 'trdglo', umo , jptot_dyn ) + CALL mpp_sum( 'trdglo', vmo , jptot_dyn ) + CALL mpp_sum( 'trdglo', hke , jptot_dyn ) + ENDIF + + ! I.2 Print dynamic trends in the ocean.output file + ! -------------------------------------------------- + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9500) kt + WRITE (numout,9501) umo(jpdyn_hpg) / tvolu, vmo(jpdyn_hpg) / tvolv + WRITE (numout,9502) umo(jpdyn_keg) / tvolu, vmo(jpdyn_keg) / tvolv + WRITE (numout,9503) umo(jpdyn_rvo) / tvolu, vmo(jpdyn_rvo) / tvolv + WRITE (numout,9504) umo(jpdyn_pvo) / tvolu, vmo(jpdyn_pvo) / tvolv + WRITE (numout,9505) umo(jpdyn_zad) / tvolu, vmo(jpdyn_zad) / tvolv + WRITE (numout,9506) umo(jpdyn_ldf) / tvolu, vmo(jpdyn_ldf) / tvolv + WRITE (numout,9507) umo(jpdyn_zdf) / tvolu, vmo(jpdyn_zdf) / tvolv + WRITE (numout,9508) umo(jpdyn_spg) / tvolu, vmo(jpdyn_spg) / tvolv + WRITE (numout,9509) umo(jpdyn_bfr) / tvolu, vmo(jpdyn_bfr) / tvolv + WRITE (numout,9510) umo(jpdyn_atf) / tvolu, vmo(jpdyn_atf) / tvolv + WRITE (numout,9511) + WRITE (numout,9512) & + & ( umo(jpdyn_hpg) + umo(jpdyn_keg) + umo(jpdyn_rvo) + umo(jpdyn_pvo) & + & + umo(jpdyn_zad) + umo(jpdyn_ldf) + umo(jpdyn_zdf) + umo(jpdyn_spg) & + & + umo(jpdyn_bfr) + umo(jpdyn_atf) ) / tvolu, & + & ( vmo(jpdyn_hpg) + vmo(jpdyn_keg) + vmo(jpdyn_rvo) + vmo(jpdyn_pvo) & + & + vmo(jpdyn_zad) + vmo(jpdyn_ldf) + vmo(jpdyn_zdf) + vmo(jpdyn_spg) & + & + vmo(jpdyn_bfr) + vmo(jpdyn_atf) ) / tvolv + WRITE (numout,9513) umo(jpdyn_tau) / tvolu, vmo(jpdyn_tau) / tvolv +!!gm IF( ln_drgimp ) WRITE (numout,9514) umo(jpdyn_bfri) / tvolu, vmo(jpdyn_bfri) / tvolv + ENDIF + + 9500 FORMAT(' momentum trend at it= ', i6, ' :', /' ==============================') + 9501 FORMAT(' hydro pressure gradient u= ', e20.13, ' v= ', e20.13) + 9502 FORMAT(' ke gradient u= ', e20.13, ' v= ', e20.13) + 9503 FORMAT(' relative vorticity term u= ', e20.13, ' v= ', e20.13) + 9504 FORMAT(' planetary vorticity term u= ', e20.13, ' v= ', e20.13) + 9505 FORMAT(' vertical advection u= ', e20.13, ' v= ', e20.13) + 9506 FORMAT(' horizontal diffusion u= ', e20.13, ' v= ', e20.13) + 9507 FORMAT(' vertical diffusion u= ', e20.13, ' v= ', e20.13) + 9508 FORMAT(' surface pressure gradient u= ', e20.13, ' v= ', e20.13) + 9509 FORMAT(' explicit bottom friction u= ', e20.13, ' v= ', e20.13) + 9510 FORMAT(' Asselin time filter u= ', e20.13, ' v= ', e20.13) + 9511 FORMAT(' -----------------------------------------------------------------------------') + 9512 FORMAT(' total trend u= ', e20.13, ' v= ', e20.13) + 9513 FORMAT(' incl. surface wind stress u= ', e20.13, ' v= ', e20.13) + 9514 FORMAT(' bottom stress u= ', e20.13, ' v= ', e20.13) + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9520) kt + WRITE (numout,9521) hke(jpdyn_hpg) / tvolt + WRITE (numout,9522) hke(jpdyn_keg) / tvolt + WRITE (numout,9523) hke(jpdyn_rvo) / tvolt + WRITE (numout,9524) hke(jpdyn_pvo) / tvolt + WRITE (numout,9525) hke(jpdyn_zad) / tvolt + WRITE (numout,9526) hke(jpdyn_ldf) / tvolt + WRITE (numout,9527) hke(jpdyn_zdf) / tvolt + WRITE (numout,9528) hke(jpdyn_spg) / tvolt + WRITE (numout,9529) hke(jpdyn_bfr) / tvolt + WRITE (numout,9530) hke(jpdyn_atf) / tvolt + WRITE (numout,9531) + WRITE (numout,9532) & + & ( hke(jpdyn_hpg) + hke(jpdyn_keg) + hke(jpdyn_rvo) + hke(jpdyn_pvo) & + & + hke(jpdyn_zad) + hke(jpdyn_ldf) + hke(jpdyn_zdf) + hke(jpdyn_spg) & + & + hke(jpdyn_bfr) + hke(jpdyn_atf) ) / tvolt + WRITE (numout,9533) hke(jpdyn_tau) / tvolt +!!gm IF( ln_drgimp ) WRITE (numout,9534) hke(jpdyn_bfri) / tvolt + ENDIF + + 9520 FORMAT(' kinetic energy trend at it= ', i6, ' :', /' ====================================') + 9521 FORMAT(' hydro pressure gradient u2= ', e20.13) + 9522 FORMAT(' ke gradient u2= ', e20.13) + 9523 FORMAT(' relative vorticity term u2= ', e20.13) + 9524 FORMAT(' planetary vorticity term u2= ', e20.13) + 9525 FORMAT(' vertical advection u2= ', e20.13) + 9526 FORMAT(' horizontal diffusion u2= ', e20.13) + 9527 FORMAT(' vertical diffusion u2= ', e20.13) + 9528 FORMAT(' surface pressure gradient u2= ', e20.13) + 9529 FORMAT(' explicit bottom friction u2= ', e20.13) + 9530 FORMAT(' Asselin time filter u2= ', e20.13) + 9531 FORMAT(' --------------------------------------------------') + 9532 FORMAT(' total trend u2= ', e20.13) + 9533 FORMAT(' incl. surface wind stress u2= ', e20.13) + 9534 FORMAT(' bottom stress u2= ', e20.13) + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9540) kt + WRITE (numout,9541) ( hke(jpdyn_keg) + hke(jpdyn_rvo) + hke(jpdyn_zad) ) / tvolt + WRITE (numout,9542) ( hke(jpdyn_keg) + hke(jpdyn_zad) ) / tvolt + WRITE (numout,9543) ( hke(jpdyn_pvo) ) / tvolt + WRITE (numout,9544) ( hke(jpdyn_rvo) ) / tvolt + WRITE (numout,9545) ( hke(jpdyn_spg) ) / tvolt + WRITE (numout,9546) ( hke(jpdyn_ldf) ) / tvolt + WRITE (numout,9547) ( hke(jpdyn_zdf) ) / tvolt + WRITE (numout,9548) ( hke(jpdyn_hpg) ) / tvolt, rpktrd / tvolt + WRITE (numout,*) + WRITE (numout,*) + ENDIF + + 9540 FORMAT(' energetic consistency at it= ', i6, ' :', /' =========================================') + 9541 FORMAT(' 0 = non linear term (true if KE conserved) : ', e20.13) + 9542 FORMAT(' 0 = ke gradient + vertical advection : ', e20.13) + 9543 FORMAT(' 0 = coriolis term (true if KE conserving scheme) : ', e20.13) + 9544 FORMAT(' 0 = vorticity term (true if KE conserving scheme) : ', e20.13) + 9545 FORMAT(' 0 = surface pressure gradient ??? : ', e20.13) + 9546 FORMAT(' 0 < horizontal diffusion : ', e20.13) + 9547 FORMAT(' 0 < vertical diffusion : ', e20.13) + 9548 FORMAT(' pressure gradient u2 = - 1/rho0 u.dz(rhop) : ', e20.13, ' u.dz(rhop) =', e20.13) + ! + ! Save potential to kinetic energy conversion for next time step + rpktrd = peke + ! + ENDIF + ! + END SUBROUTINE glo_dyn_wri + + + SUBROUTINE glo_tra_wri( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE glo_tra_wri *** + !! + !! ** Purpose : write global domain averaged of T and T^2 trends in ocean.output + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: jk ! loop indices + !!---------------------------------------------------------------------- + + ! I. Tracers trends + ! ----------------- + + IF( MOD(kt,nn_trd) == 0 .OR. kt == nit000 .OR. kt == nitend ) THEN + + ! I.1 Sums over the global domain + ! ------------------------------- + IF( lk_mpp ) THEN + CALL mpp_sum( 'trdglo', tmo, jptot_tra ) + CALL mpp_sum( 'trdglo', smo, jptot_tra ) + CALL mpp_sum( 'trdglo', t2 , jptot_tra ) + CALL mpp_sum( 'trdglo', s2 , jptot_tra ) + ENDIF + + ! I.2 Print tracers trends in the ocean.output file + ! -------------------------------------------------- + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9400) kt + WRITE (numout,9401) tmo(jptra_xad) / tvolt, smo(jptra_xad) / tvolt + WRITE (numout,9411) tmo(jptra_yad) / tvolt, smo(jptra_yad) / tvolt + WRITE (numout,9402) tmo(jptra_zad) / tvolt, smo(jptra_zad) / tvolt + WRITE (numout,9403) tmo(jptra_ldf) / tvolt, smo(jptra_ldf) / tvolt + WRITE (numout,9404) tmo(jptra_zdf) / tvolt, smo(jptra_zdf) / tvolt + WRITE (numout,9405) tmo(jptra_npc) / tvolt, smo(jptra_npc) / tvolt + WRITE (numout,9406) tmo(jptra_dmp) / tvolt, smo(jptra_dmp) / tvolt + WRITE (numout,9407) tmo(jptra_qsr) / tvolt + WRITE (numout,9408) tmo(jptra_nsr) / tvolt, smo(jptra_nsr) / tvolt + WRITE (numout,9409) + WRITE (numout,9410) ( tmo(jptra_xad) + tmo(jptra_yad) + tmo(jptra_zad) + tmo(jptra_ldf) + tmo(jptra_zdf) & + & + tmo(jptra_npc) + tmo(jptra_dmp) + tmo(jptra_qsr) + tmo(jptra_nsr) ) / tvolt, & + & ( smo(jptra_xad) + smo(jptra_yad) + smo(jptra_zad) + smo(jptra_ldf) + smo(jptra_zdf) & + & + smo(jptra_npc) + smo(jptra_dmp) + smo(jptra_nsr) ) / tvolt + ENDIF + +9400 FORMAT(' tracer trend at it= ',i6,' : temperature', & + ' salinity',/' ============================') +9401 FORMAT(' zonal advection ',e20.13,' ',e20.13) +9411 FORMAT(' meridional advection ',e20.13,' ',e20.13) +9402 FORMAT(' vertical advection ',e20.13,' ',e20.13) +9403 FORMAT(' horizontal diffusion ',e20.13,' ',e20.13) +9404 FORMAT(' vertical diffusion ',e20.13,' ',e20.13) +9405 FORMAT(' static instability mixing ',e20.13,' ',e20.13) +9406 FORMAT(' damping term ',e20.13,' ',e20.13) +9407 FORMAT(' penetrative qsr ',e20.13) +9408 FORMAT(' non solar radiation ',e20.13,' ',e20.13) +9409 FORMAT(' -------------------------------------------------------------------------') +9410 FORMAT(' total trend ',e20.13,' ',e20.13) + + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9420) kt + WRITE (numout,9421) t2(jptra_xad) / tvolt, s2(jptra_xad) / tvolt + WRITE (numout,9431) t2(jptra_yad) / tvolt, s2(jptra_yad) / tvolt + WRITE (numout,9422) t2(jptra_zad) / tvolt, s2(jptra_zad) / tvolt + WRITE (numout,9423) t2(jptra_ldf) / tvolt, s2(jptra_ldf) / tvolt + WRITE (numout,9424) t2(jptra_zdf) / tvolt, s2(jptra_zdf) / tvolt + WRITE (numout,9425) t2(jptra_npc) / tvolt, s2(jptra_npc) / tvolt + WRITE (numout,9426) t2(jptra_dmp) / tvolt, s2(jptra_dmp) / tvolt + WRITE (numout,9427) t2(jptra_qsr) / tvolt + WRITE (numout,9428) t2(jptra_nsr) / tvolt, s2(jptra_nsr) / tvolt + WRITE (numout,9429) + WRITE (numout,9430) ( t2(jptra_xad) + t2(jptra_yad) + t2(jptra_zad) + t2(jptra_ldf) + t2(jptra_zdf) & + & + t2(jptra_npc) + t2(jptra_dmp) + t2(jptra_qsr) + t2(jptra_nsr) ) / tvolt, & + & ( s2(jptra_xad) + s2(jptra_yad) + s2(jptra_zad) + s2(jptra_ldf) + s2(jptra_zdf) & + & + s2(jptra_npc) + s2(jptra_dmp) + s2(jptra_nsr) ) / tvolt + ENDIF + +9420 FORMAT(' tracer**2 trend at it= ', i6, ' : temperature', & + ' salinity', /, ' ===============================') +9421 FORMAT(' zonal advection * t ', e20.13, ' ', e20.13) +9431 FORMAT(' meridional advection * t ', e20.13, ' ', e20.13) +9422 FORMAT(' vertical advection * t ', e20.13, ' ', e20.13) +9423 FORMAT(' horizontal diffusion * t ', e20.13, ' ', e20.13) +9424 FORMAT(' vertical diffusion * t ', e20.13, ' ', e20.13) +9425 FORMAT(' static instability mixing * t ', e20.13, ' ', e20.13) +9426 FORMAT(' damping term * t ', e20.13, ' ', e20.13) +9427 FORMAT(' penetrative qsr * t ', e20.13) +9428 FORMAT(' non solar radiation * t ', e20.13, ' ', e20.13) +9429 FORMAT(' -----------------------------------------------------------------------------') +9430 FORMAT(' total trend *t = ', e20.13, ' *s = ', e20.13) + + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9440) kt + WRITE (numout,9441) ( tmo(jptra_xad)+tmo(jptra_yad)+tmo(jptra_zad) )/tvolt, & + & ( smo(jptra_xad)+smo(jptra_yad)+smo(jptra_zad) )/tvolt + WRITE (numout,9442) tmo(jptra_sad)/tvolt, smo(jptra_sad)/tvolt + WRITE (numout,9443) tmo(jptra_ldf)/tvolt, smo(jptra_ldf)/tvolt + WRITE (numout,9444) tmo(jptra_zdf)/tvolt, smo(jptra_zdf)/tvolt + WRITE (numout,9445) tmo(jptra_npc)/tvolt, smo(jptra_npc)/tvolt + WRITE (numout,9446) ( t2(jptra_xad)+t2(jptra_yad)+t2(jptra_zad) )/tvolt, & + & ( s2(jptra_xad)+s2(jptra_yad)+s2(jptra_zad) )/tvolt + WRITE (numout,9447) t2(jptra_ldf)/tvolt, s2(jptra_ldf)/tvolt + WRITE (numout,9448) t2(jptra_zdf)/tvolt, s2(jptra_zdf)/tvolt + WRITE (numout,9449) t2(jptra_npc)/tvolt, s2(jptra_npc)/tvolt + ENDIF + +9440 FORMAT(' tracer consistency at it= ',i6, & + ' : temperature',' salinity',/, & + ' ==================================') +9441 FORMAT(' 0 = horizontal+vertical advection + ',e20.13,' ',e20.13) +9442 FORMAT(' 1st lev vertical advection ',e20.13,' ',e20.13) +9443 FORMAT(' 0 = horizontal diffusion ',e20.13,' ',e20.13) +9444 FORMAT(' 0 = vertical diffusion ',e20.13,' ',e20.13) +9445 FORMAT(' 0 = static instability mixing ',e20.13,' ',e20.13) +9446 FORMAT(' 0 = horizontal+vertical advection * t ',e20.13,' ',e20.13) +9447 FORMAT(' 0 > horizontal diffusion * t ',e20.13,' ',e20.13) +9448 FORMAT(' 0 > vertical diffusion * t ',e20.13,' ',e20.13) +9449 FORMAT(' 0 > static instability mixing * t ',e20.13,' ',e20.13) + ! + ENDIF + ! + END SUBROUTINE glo_tra_wri + + + SUBROUTINE trd_glo_init( Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_glo_init *** + !! + !! ** Purpose : Read the namtrd namelist + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! time level index + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'trd_glo_init : integral constraints properties trends' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + + ! Total volume at t-points: + tvolt = 0._wp + DO jk = 1, jpkm1 + tvolt = tvolt + SUM( e1e2t(:,:) * (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) * tmask(:,:,jk) * tmask_i(:,:) ) + END DO + CALL mpp_sum( 'trdglo', tvolt ) ! sum over the global domain + + IF(lwp) WRITE(numout,*) ' total ocean volume at T-point tvolt = ',tvolt + + ! Initialization of potential to kinetic energy conversion + rpktrd = 0._wp + + ! Total volume at u-, v- points: +!!gm : bug? je suis quasi sur que le produit des tmask_i ne correspond pas exactement au umask_i et vmask_i ! + tvolu = 0._wp + tvolv = 0._wp + + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + tvolu = tvolu + e1u(ji,jj) * e2u(ji,jj) * (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) & + & * tmask_i(ji+1,jj ) * tmask_i(ji,jj) * umask(ji,jj,jk) + tvolv = tvolv + e1v(ji,jj) * e2v(ji,jj) * (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) & + & * tmask_i(ji ,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) + END DO ; END DO ; END DO + CALL mpp_sum( 'trdglo', tvolu ) ! sums over the global domain + CALL mpp_sum( 'trdglo', tvolv ) + + IF(lwp) THEN + WRITE(numout,*) ' total ocean volume at U-point tvolu = ',tvolu + WRITE(numout,*) ' total ocean volume at V-point tvolv = ',tvolv + ENDIF + ! + END SUBROUTINE trd_glo_init + + !!====================================================================== +END MODULE trdglo diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdini.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdini.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ff3bdf6bc39f27b79d628cff9163085107327fb9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdini.f90 @@ -0,0 +1,124 @@ + + + + + + + + + + + + + +MODULE trdini + !!====================================================================== + !! *** MODULE trdini *** + !! Ocean diagnostics: ocean tracers and dynamic trends + !!===================================================================== + !! History : 3.5 ! 2012-02 (G. Madec) add 3D trends output for T, S, U, V, PE and KE + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_init : initialization step + !!---------------------------------------------------------------------- + USE dom_oce ! ocean domain + USE domtile + USE trd_oce ! trends: ocean variables + USE trdken ! trends: 3D kinetic energy + USE trdpen ! trends: 3D potential energy + USE trdglo ! trends: global domain averaged tracers and dynamics + USE trdmxl ! trends: mixed layer averaged trends (tracer only) + USE trdvor ! trends: vertical averaged vorticity + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_init ! called by nemogcm.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdini.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_init *** + !! + !! ** Purpose : Initialization of trend diagnostics + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! time level index + INTEGER :: ios ! local integer + !! + NAMELIST/namtrd/ ln_dyn_trd, ln_KE_trd, ln_vor_trd, ln_dyn_mxl, & + & ln_tra_trd, ln_PE_trd, ln_glo_trd, ln_tra_mxl, nn_trd + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namtrd, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd in reference namelist' ) + ! + READ ( numnam_cfg, namtrd, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd in configuration namelist' ) + IF(lwm) WRITE( numond, namtrd ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'trd_init : Momentum/Tracers trends' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist namtrd : set trends parameters' + WRITE(numout,*) ' global domain averaged dyn & tra trends ln_glo_trd = ', ln_glo_trd + WRITE(numout,*) ' U & V trends: 3D output ln_dyn_trd = ', ln_dyn_trd + WRITE(numout,*) ' U & V trends: Mixed Layer averaged ln_dyn_mxl = ', ln_dyn_mxl + WRITE(numout,*) ' T & S trends: 3D output ln_tra_trd = ', ln_tra_trd + WRITE(numout,*) ' T & S trends: Mixed Layer averaged ln_tra_mxl = ', ln_tra_mxl + WRITE(numout,*) ' Kinetic Energy trends ln_KE_trd = ', ln_KE_trd + WRITE(numout,*) ' Potential Energy trends ln_PE_trd = ', ln_PE_trd + WRITE(numout,*) ' Barotropic vorticity trends ln_vor_trd = ', ln_vor_trd + ! + WRITE(numout,*) ' frequency of trends diagnostics (glo) nn_trd = ', nn_trd + ENDIF + ! + ! ! trend extraction flags + l_trdtra = .FALSE. ! tracers + IF ( ln_tra_trd .OR. ln_PE_trd .OR. ln_tra_mxl .OR. & + & ln_glo_trd ) l_trdtra = .TRUE. + ! + l_trddyn = .FALSE. ! momentum + IF ( ln_dyn_trd .OR. ln_KE_trd .OR. ln_dyn_mxl .OR. & + & ln_vor_trd .OR. ln_glo_trd ) l_trddyn = .TRUE. + ! + +!!gm check the stop below + IF( ln_dyn_mxl ) CALL ctl_stop( 'ML diag on momentum are not yet coded we stop' ) + ! + +!!gm end + IF( ln_tra_mxl .OR. ln_vor_trd ) CALL ctl_stop( 'ML tracer and Barotropic vorticity diags are still using old IOIPSL' ) +!!gm end + ! +! IF( .NOT.ln_linssh .AND. ( l_trdtra .OR. l_trddyn ) ) CALL ctl_stop( 'trend diagnostics with variable volume not validated' ) + + IF( ln_tile .AND. ( l_trdtra .OR. l_trddyn ) ) THEN + CALL ctl_warn('Tiling is not yet implemented for the trends diagnostics; ln_tile is forced to FALSE') + ln_tile = .FALSE. + CALL dom_tile_init + ENDIF + +!!gm : Potential BUG : 3D output only for vector invariant form! add a ctl_stop or code the flux form case +!!gm : bug/pb for vertical advection of tracer in vvl case: add T.dt[eta] in the output... + + ! ! diagnostic initialization + IF( ln_glo_trd ) CALL trd_glo_init( Kmm ) ! global domain averaged trends + IF( ln_tra_mxl ) CALL trd_mxl_init ! mixed-layer trends + IF( ln_vor_trd ) CALL trd_vor_init ! barotropic vorticity trends + IF( ln_KE_trd ) CALL trd_ken_init ! 3D Kinetic energy trends + IF( ln_PE_trd ) CALL trd_pen_init ! 3D Potential energy trends + ! + END SUBROUTINE trd_init + + !!====================================================================== +END MODULE trdini diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdken.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdken.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d8290743569f5c0dbc79c018bf31a9b2f35a9229 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdken.f90 @@ -0,0 +1,277 @@ + + + + + + + + + + + + + +MODULE trdken + !!====================================================================== + !! *** MODULE trdken *** + !! Ocean diagnostics: compute and output 3D kinetic energy trends + !!===================================================================== + !! History : 3.5 ! 2012-02 (G. Madec) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_ken : compute and output 3D Kinetic energy trends using IOM + !! trd_ken_init : initialisation + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE phycst ! physical constants + USE sbc_oce ! surface boundary condition: ocean + USE zdf_oce ! ocean vertical physics variables +!!gm USE zdfdrg ! ocean vertical physics: bottom friction + USE ldftra ! ocean active tracers lateral physics + USE trd_oce ! trends: ocean variables + USE trdvor ! ocean vorticity trends + USE trdglo ! trends:global domain averaged + USE trdmxl ! ocean active mixed layer tracers trends + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE ldfslp ! Isopycnal slopes + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_ken ! called by trddyn module + PUBLIC trd_ken_init ! called by trdini module + + INTEGER :: nkstp ! current time step + + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: bu, bv ! volume of u- and v-boxes + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: r1_bt ! inverse of t-box volume + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdken.F90 15104 2021-07-07 14:36:00Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_ken_alloc() + !!--------------------------------------------------------------------- + !! *** FUNCTION trd_ken_alloc *** + !!--------------------------------------------------------------------- + ALLOCATE( bu(jpi,jpj,jpk) , bv(jpi,jpj,jpk) , r1_bt(jpi,jpj,jpk) , STAT= trd_ken_alloc ) + ! + CALL mpp_sum ( 'trdken', trd_ken_alloc ) + IF( trd_ken_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_ken_alloc: failed to allocate arrays' ) + END FUNCTION trd_ken_alloc + + + SUBROUTINE trd_ken( putrd, pvtrd, ktrd, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_ken *** + !! + !! ** Purpose : output 3D Kinetic Energy trends using IOM + !! + !! ** Method : - apply lbc to the input masked velocity trends + !! - compute the associated KE trend: + !! zke = 0.5 * ( mi-1[ uu(Kmm) * putrd * bu ] + mj-1[ vv(Kmm) * pvtrd * bv] ) / bt + !! where bu, bv, bt are the volume of u-, v- and t-boxes. + !! - vertical diffusion case (jpdyn_zdf): + !! diagnose separately the KE trend associated with wind stress + !! - bottom friction case (jpdyn_bfr): + !! explicit case (ln_drgimp=F): bottom trend put in the 1st level + !! of putrd, pvtrd + ! + ! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V masked trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbu , ikbv ! local integers + INTEGER :: ikbum1, ikbvm1 ! - - + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: z2dx, z2dy, zke2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zke ! 3D workspace + !!---------------------------------------------------------------------- + ! + CALL lbc_lnk( 'trdken', putrd, 'U', -1.0_dp , pvtrd, 'V', -1.0_dp ) ! lateral boundary conditions + ! + nkstp = kt + DO jk = 1, jpkm1 + bu (:,:,jk) = e1e2u(:,:) * (e3u_0(:,:,jk)*(1._wp+r3u(:,:,Kmm)*umask(:,:,jk))) + bv (:,:,jk) = e1e2v(:,:) * (e3v_0(:,:,jk)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,jk))) + r1_bt(:,:,jk) = r1_e1e2t(:,:) / (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) * tmask(:,:,jk) + END DO + ! + zke(:,:,jpk) = 0._wp + zke(1:nn_hls,:, : ) = 0._wp + zke(:,1:nn_hls, : ) = 0._wp + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( nn_hls) ; DO ji = ntsi-( 0), ntei+( nn_hls) + zke(ji,jj,jk) = 0.5_wp * rho0 *( uu(ji ,jj,jk,Kmm) * putrd(ji ,jj,jk) * bu(ji ,jj,jk) & + & + uu(ji-1,jj,jk,Kmm) * putrd(ji-1,jj,jk) * bu(ji-1,jj,jk) & + & + vv(ji,jj ,jk,Kmm) * pvtrd(ji,jj ,jk) * bv(ji,jj ,jk) & + & + vv(ji,jj-1,jk,Kmm) * pvtrd(ji,jj-1,jk) * bv(ji,jj-1,jk) ) * r1_bt(ji,jj,jk) + END DO ; END DO ; END DO + ! + SELECT CASE( ktrd ) + CASE( jpdyn_hpg ) ; CALL iom_put( "ketrd_hpg" , zke ) ! hydrostatic pressure gradient + CASE( jpdyn_spg ) ; CALL iom_put( "ketrd_spg" , zke ) ! surface pressure gradient + CASE( jpdyn_pvo ) ; CALL iom_put( "ketrd_pvo" , zke ) ! planetary vorticity + CASE( jpdyn_rvo ) ; CALL iom_put( "ketrd_rvo" , zke ) ! relative vorticity (or metric term) + CASE( jpdyn_keg ) ; CALL iom_put( "ketrd_keg" , zke ) ! Kinetic Energy gradient (or had) + CASE( jpdyn_zad ) ; CALL iom_put( "ketrd_zad" , zke ) ! vertical advection + CASE( jpdyn_ldf ) ; CALL iom_put( "ketrd_ldf" , zke ) ! lateral diffusion + CASE( jpdyn_zdf ) ; CALL iom_put( "ketrd_zdf" , zke ) ! vertical diffusion + ! ! ! wind stress trends + ALLOCATE( z2dx(jpi,jpj) , z2dy(jpi,jpj) , zke2d(jpi,jpj) ) + z2dx(:,:) = uu(:,:,1,Kmm) * ( utau_b(:,:) + utau(:,:) ) * e1e2u(:,:) * umask(:,:,1) + z2dy(:,:) = vv(:,:,1,Kmm) * ( vtau_b(:,:) + vtau(:,:) ) * e1e2v(:,:) * vmask(:,:,1) + zke2d(1:nn_hls,:) = 0._wp ; zke2d(:,1:nn_hls) = 0._wp + DO jj = ntsj-( 0), ntej+( nn_hls ) ; DO ji = ntsi-( 0), ntei+( nn_hls) + zke2d(ji,jj) = r1_rho0 * 0.5_wp * ( z2dx(ji,jj) + z2dx(ji-1,jj) & + & + z2dy(ji,jj) + z2dy(ji,jj-1) ) * r1_bt(ji,jj,1) + END DO ; END DO + CALL iom_put( "ketrd_tau" , zke2d ) ! + DEALLOCATE( z2dx , z2dy , zke2d ) + CASE( jpdyn_bfr ) ; CALL iom_put( "ketrd_bfr" , zke ) ! bottom friction (explicit case) +!!gm TO BE DONE properly +!!gm only valid if ln_drgimp=F otherwise the bottom stress as to be recomputed at the end of the computation.... +! IF(.NOT. ln_drgimp) THEN +! DO jj = 1, jpj ! +! DO ji = 1, jpi +! ikbu = mbku(ji,jj) ! deepest ocean u- & v-levels +! ikbv = mbkv(ji,jj) +! z2dx(ji,jj) = uu(ji,jj,ikbu,Kmm) * bfrua(ji,jj) * uu(ji,jj,ikbu,Kmm) +! z2dy(ji,jj) = vv(ji,jj,ikbu,Kmm) * bfrva(ji,jj) * vv(ji,jj,ikbv,Kmm) +! END DO +! END DO +! zke2d(1,:) = 0._wp ; zke2d(:,1) = 0._wp +! DO jj = 2, jpj +! DO ji = 2, jpi +! zke2d(ji,jj) = 0.5_wp * ( z2dx(ji,jj) + z2dx(ji-1,jj) & +! & + z2dy(ji,jj) + z2dy(ji,jj-1) ) * r1_bt(ji,jj, BEURK!!! +! END DO +! END DO +! CALL iom_put( "ketrd_bfr" , zke2d ) ! bottom friction (explicit case) +! ENDIF +!!gm end + CASE( jpdyn_atf ) ; CALL iom_put( "ketrd_atf" , zke ) ! asselin filter trends +!! a faire !!!! idee changer dynnxt pour avoir un appel a jpdyn_bfr avant le swap !!! +!! reflechir a une possible sauvegarde du "vrai" uu(Kmm),vv(Kmm) pour le calcul de atf.... +! +! IF( ln_drgimp ) THEN ! bottom friction (implicit case) +! DO jj = 1, jpj ! after velocity known (now filed at this stage) +! DO ji = 1, jpi +! ikbu = mbku(ji,jj) ! deepest ocean u- & v-levels +! ikbv = mbkv(ji,jj) +! z2dx(ji,jj) = uu(ji,jj,ikbu,Kmm) * bfrua(ji,jj) * uu(ji,jj,ikbu,Kmm) / (e3u_0(ji,jj,ikbu)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,ikbu))) +! z2dy(ji,jj) = uu(ji,jj,ikbu,Kmm) * bfrva(ji,jj) * vv(ji,jj,ikbv,Kmm) / (e3v_0(ji,jj,ikbv)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,ikbv))) +! END DO +! END DO +! zke2d(1,:) = 0._wp ; zke2d(:,1) = 0._wp +! DO jj = 2, jpj +! DO ji = 2, jpi +! zke2d(ji,jj) = 0.5_wp * ( z2dx(ji,jj) + z2dx(ji-1,jj) & +! & + z2dy(ji,jj) + z2dy(ji,jj-1) ) +! END DO +! END DO +! CALL iom_put( "ketrd_bfri", zke2d ) +! ENDIF + CASE( jpdyn_ken ) ; ! kinetic energy + ! called in dynnxt.F90 before asselin time filter + ! with putrd=uu(Krhs) and pvtrd=vv(Krhs) + zke(:,:,:) = 0.5_wp * zke(:,:,:) + CALL iom_put( "KE", zke ) + ! + CALL ken_p2k( kt , zke, Kmm ) + CALL iom_put( "ketrd_convP2K", zke ) ! conversion -rau*g*w + ! + END SELECT + ! + END SUBROUTINE trd_ken + + + SUBROUTINE ken_p2k( kt , pconv, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE ken_p2k *** + !! + !! ** Purpose : compute rate of conversion from potential to kinetic energy + !! + !! ** Method : - compute conv defined as -rau*g*w on T-grid points + !! + !! ** Work only for full steps and partial steps (ln_hpg_zco or ln_hpg_zps) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pconv ! + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iku, ikv ! local integers + REAL(wp) :: zcoef ! local scalars + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zconv ! 3D workspace + !!---------------------------------------------------------------------- + ! + ! Local constant initialization + zcoef = - rho0 * grav * 0.5_wp + + ! Surface value (also valid in partial step case) + zconv(:,:,1) = zcoef * ( 2._wp * rhd(:,:,1) ) * ww(:,:,1) * (e3w_0(:,:,1)*(1._wp+r3t(:,:,Kmm))) + + ! interior value (2=> use previous timestep ztn_mla = tb_mln + ! " " " tn_mln = tb_mlb (unfiltered tb!) + ! NB: tn_mln itself comes from the 2 time step before (ta_mla) + ! + ! atf trend : ztbf_mln - tb_mln ==>> use previous timestep tn_mla = tb_mln + ! need to compute tbf_mln, using the current tb + ! which is the before fitered tracer + ! + ! entrainement ent_2 : zta_mla - zta_mln ==>> need to compute zta_mla and zta_mln + ! + ! time averaging : mean: CALL trd_mean( kt, ptrd, ptrdm ) + ! and out put the starting mean value and the total trends + ! (i.e. difference between starting and ending values) + ! hat : CALL trd_hat ( kt, ptrd, ptrdm ) + ! and output the starting hat value and the total hat trends + ! + ! swaps : hmlb <== hmln <== zhmla + ! tb_mlb <== tn_mln <== zta_mla + ! tb_mln <== ztn_mla ==>> now T over after h, need to be computed here + ! to be used at next time step (unfiltered before) + ! + END SELECT + ! + END SUBROUTINE trd_tra_mxl + + + SUBROUTINE trd_mean( kt, ptrd, ptrdm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mean *** + !! + !! ** Purpose : + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptrd ! trend at kt + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptrdm ! cumulative trends at kt + INTEGER , INTENT(in ) :: kt ! time step index + !!---------------------------------------------------------------------- + ! + IF ( kt == nn_it000 ) ptrdm(:,:,:) = 0._wp + ! + ptrdm(:,:,:) = ptrdm(:,:,:) + ptrd(:,:,:) + ! + IF ( MOD( kt - nn_it000 + 1, nn_trd ) == 0 ) THEN + ! + ! call iom put???? avec en argument le tableau de nom des trends? + ! + ENDIF + ! + END SUBROUTINE trd_mean + + + SUBROUTINE trd_mxl_zint( pttrdmxl, pstrdmxl, ktrd, ctype ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl_zint *** + !! + !! ** Purpose : Compute the vertical average of the 3D fields given as arguments + !! to the subroutine. This vertical average is performed from ocean + !! surface down to a chosen control surface. + !! + !! ** Method/usage : + !! The control surface can be either a mixed layer depth (time varying) + !! or a fixed surface (jk level or bowl). + !! Choose control surface with nn_ctls in namelist NAMTRD : + !! nn_ctls = 0 : use mixed layer with density criterion + !! nn_ctls = 1 : read index from file 'ctlsurf_idx' + !! nn_ctls > 1 : use fixed level surface jk = nn_ctls + !! Note: in the remainder of the routine, the volume between the + !! surface and the control surface is called "mixed-layer" + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: ktrd ! ocean trend index + CHARACTER(len=2) , INTENT( in ) :: ctype ! 2D surface/bottom or 3D interior physics + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pttrdmxl ! temperature trend + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pstrdmxl ! salinity trend + ! + INTEGER :: ji, jj, jk, isum + REAL(wp), DIMENSION(jpi,jpj) :: zvlmsk + !!---------------------------------------------------------------------- + + ! I. Definition of control surface and associated fields + ! ------------------------------------------------------ + ! ==> only once per time step <== + + IF( icount == 1 ) THEN + ! + +!!gm BUG? +!!gm CAUTION: double check the definition of nmln it is the nb of w-level, not t-level I guess + + + ! ... Set nmxl(ji,jj) = index of first T point below control surf. or outside mixed-layer + IF( nn_ctls == 0 ) THEN ! * control surface = mixed-layer with density criterion + nmxl(:,:) = nmln(:,:) ! array nmln computed in zdfmxl.F90 + ELSEIF( nn_ctls == 1 ) THEN ! * control surface = read index from file + nmxl(:,:) = nbol(:,:) + ELSEIF( nn_ctls >= 2 ) THEN ! * control surface = model level + nn_ctls = MIN( nn_ctls, jpktrd - 1 ) + nmxl(:,:) = nn_ctls + 1 + ENDIF + + END IF + ! + END SUBROUTINE trd_mxl_zint + + + SUBROUTINE trd_mxl( kt, p2dt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl *** + !! + !! ** Purpose : Compute and cumulate the mixed layer trends over an analysis + !! period, and write NetCDF outputs. + !! + !! ** Method/usage : + !! The stored trends can be chosen twofold (according to the ln_trdmxl_instant + !! logical namelist variable) : + !! 1) to explain the difference between initial and final + !! mixed-layer T & S (where initial and final relate to the + !! current analysis window, defined by nn_trd in the namelist) + !! 2) to explain the difference between the current and previous + !! TIME-AVERAGED mixed-layer T & S (where time-averaging is + !! performed over each analysis window). + !! + !! ** Consistency check : + !! If the control surface is fixed ( nn_ctls > 1 ), the residual term (dh/dt + !! entrainment) should be zero, at machine accuracy. Note that in the case + !! of time-averaged mixed-layer fields, this residual WILL NOT BE ZERO + !! over the first two analysis windows (except if restart). + !! N.B. For ORCA2_ICE, use e.g. nn_trd=5, rn_ucf=1., nn_ctls=8 + !! for checking residuals. + !! On a NEC-SX5 computer, this typically leads to: + !! O(1.e-20) temp. residuals (tml_res) when ln_trdmxl_instant=.false. + !! O(1.e-21) temp. residuals (tml_res) when ln_trdmxl_instant=.true. + !! + !! ** Action : + !! At each time step, mixed-layer averaged trends are stored in the + !! tmltrd(:,:,jpmxl_xxx) array (see trdmxl_oce.F90 for definitions of jpmxl_xxx). + !! This array is known when trd_mxl is called, at the end of the stp subroutine, + !! except for the purely vertical K_z diffusion term, which is embedded in the + !! lateral diffusion trend. + !! + !! In I), this K_z term is diagnosed and stored, thus its contribution is removed + !! from the lateral diffusion trend. + !! In II), the instantaneous mixed-layer T & S are computed, and misc. cumulative + !! arrays are updated. + !! In III), called only once per analysis window, we compute the total trends, + !! along with the residuals and the Asselin correction terms. + !! In IV), the appropriate trends are written in the trends NetCDF file. + !! + !! References : Vialard et al.,2001, JPO. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + REAL(wp), INTENT(in ) :: p2dt ! time step [s] + ! + INTEGER :: ji, jj, jk, jl, ik, it, itmod + LOGICAL :: lldebug = .TRUE. + REAL(wp) :: zavt, zfn, zfn2 + ! ! z(ts)mltot : dT/dt over the anlysis window (including Asselin) + ! ! z(ts)mlres : residual = dh/dt entrainment term + REAL(wp), DIMENSION(jpi,jpj ) :: ztmltot , zsmltot , ztmlres , zsmlres , ztmlatf , zsmlatf + REAL(wp), DIMENSION(jpi,jpj ) :: ztmltot2, zsmltot2, ztmlres2, zsmlres2, ztmlatf2, zsmlatf2, ztmltrdm2, zsmltrdm2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmltrd2, zsmltrd2 ! only needed for mean diagnostics + !!---------------------------------------------------------------------- + + ! ====================================================================== + ! II. Cumulate the trends over the analysis window + ! ====================================================================== + + ztmltrd2(:,:,:) = 0.e0 ; zsmltrd2(:,:,:) = 0.e0 ! <<< reset arrays to zero + ztmltot2(:,:) = 0.e0 ; zsmltot2(:,:) = 0.e0 + ztmlres2(:,:) = 0.e0 ; zsmlres2(:,:) = 0.e0 + ztmlatf2(:,:) = 0.e0 ; zsmlatf2(:,:) = 0.e0 + + ! II.1 Set before values of vertically average T and S + ! ---------------------------------------------------- + IF( kt > nit000 ) THEN + ! ... temperature ... ... salinity ... + tmlb (:,:) = tml (:,:) ; smlb (:,:) = sml (:,:) + tmlatfn(:,:) = tmltrd(:,:,jpmxl_atf) ; smlatfn(:,:) = smltrd(:,:,jpmxl_atf) + END IF + + + ! II.3 Initialize mixed-layer "before" arrays for the 1rst analysis window + ! ------------------------------------------------------------------------ + IF( kt == 2 ) THEN ! i.e. ( .NOT. ln_rstart ).AND.( kt == nit000 + 1) + ! + ! ... temperature ... ... salinity ... + tmlbb (:,:) = tmlb (:,:) ; smlbb (:,:) = smlb (:,:) + tmlbn (:,:) = tml (:,:) ; smlbn (:,:) = sml (:,:) + tmlatfb(:,:) = tmlatfn(:,:) ; smlatfb(:,:) = smlatfn(:,:) + + tmltrd_csum_ub (:,:,:) = 0.e0 ; smltrd_csum_ub (:,:,:) = 0.e0 + tmltrd_atf_sumb(:,:) = 0.e0 ; smltrd_atf_sumb(:,:) = 0.e0 + + hmxlbn(:,:) = hmxl(:,:) + + IF( sn_cfctl%l_prtctl ) THEN + WRITE(numout,*) ' we reach kt == nit000 + 1 = ', nit000+1 + !CALL prt_ctl(tab2d_1=tmlbb , clinfo1=' tmlbb - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=tmlbn , clinfo1=' tmlbn - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=tmlatfb , clinfo1=' tmlatfb - : ', mask1=tmask) + END IF + ! + END IF + + IF( ( ln_rstart ) .AND. ( kt == nit000 ) .AND. sn_cfctl%l_prtctl ) THEN + IF( ln_trdmxl_instant ) THEN + WRITE(numout,*) ' restart from kt == nit000 = ', nit000 + !CALL prt_ctl(tab2d_1=tmlbb , clinfo1=' tmlbb - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=tmlbn , clinfo1=' tmlbn - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=tmlatfb , clinfo1=' tmlatfb - : ', mask1=tmask) + ELSE + WRITE(numout,*) ' restart from kt == nit000 = ', nit000 + !CALL prt_ctl(tab2d_1=tmlbn , clinfo1=' tmlbn - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=hmxlbn , clinfo1=' hmxlbn - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=tml_sumb , clinfo1=' tml_sumb - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=tmltrd_atf_sumb, clinfo1=' tmltrd_atf_sumb - : ', mask1=tmask) + !CALL prt_ctl(tab3d_1=tmltrd_csum_ub , clinfo1=' tmltrd_csum_ub - : ', mask1=tmask, kdim=1) + END IF + END IF + + ! II.4 Cumulated trends over the analysis period + ! ---------------------------------------------- + ! + ! [ 1rst analysis window ] [ 2nd analysis window ] + ! + ! o---[--o-----o-----o-----o--]-[--o-----o-----o-----o-----o--]---o-----o--> time steps + ! nn_trd 2*nn_trd etc. + ! 1 2 3 4 =5 e.g. =10 + ! + IF( ( kt >= 2 ).OR.( ln_rstart ) ) THEN + ! + nmoymltrd = nmoymltrd + 1 + + ! ... Cumulate over BOTH physical contributions AND over time steps + DO jl = 1, jpltrd + tmltrdm(:,:) = tmltrdm(:,:) + tmltrd(:,:,jl) + smltrdm(:,:) = smltrdm(:,:) + smltrd(:,:,jl) + END DO + + ! ... Special handling of the Asselin trend + tmlatfm(:,:) = tmlatfm(:,:) + tmlatfn(:,:) + smlatfm(:,:) = smlatfm(:,:) + smlatfn(:,:) + + ! ... Trends associated with the time mean of the ML T/S + tmltrd_sum (:,:,:) = tmltrd_sum (:,:,:) + tmltrd (:,:,:) ! tem + tmltrd_csum_ln(:,:,:) = tmltrd_csum_ln(:,:,:) + tmltrd_sum(:,:,:) + tml_sum (:,:) = tml_sum (:,:) + tml (:,:) + smltrd_sum (:,:,:) = smltrd_sum (:,:,:) + smltrd (:,:,:) ! sal + smltrd_csum_ln(:,:,:) = smltrd_csum_ln(:,:,:) + smltrd_sum(:,:,:) + sml_sum (:,:) = sml_sum (:,:) + sml (:,:) + hmxl_sum (:,:) = hmxl_sum (:,:) + hmxl (:,:) ! rmxl + ! + END IF + + ! ====================================================================== + ! III. Prepare fields for output (get here ONCE PER ANALYSIS PERIOD) + ! ====================================================================== + + ! Convert to appropriate physical units + ! N.B. It may be useful to check IOIPSL time averaging with : + ! tmltrd (:,:,:) = 1. ; smltrd (:,:,:) = 1. + tmltrd(:,:,:) = tmltrd(:,:,:) * rn_ucf ! (actually needed for 1:jpltrd-1, but trdmxl(:,:,jpltrd) + smltrd(:,:,:) = smltrd(:,:,:) * rn_ucf ! is no longer used, and is reset to 0. at next time step) + + ! define time axis + it = kt + itmod = kt - nit000 + 1 + + MODULO_NTRD : IF( MOD( itmod, nn_trd ) == 0 ) THEN ! nitend MUST be multiple of nn_trd + ! + ztmltot (:,:) = 0.e0 ; zsmltot (:,:) = 0.e0 ! reset arrays to zero + ztmlres (:,:) = 0.e0 ; zsmlres (:,:) = 0.e0 + ztmltot2(:,:) = 0.e0 ; zsmltot2(:,:) = 0.e0 + ztmlres2(:,:) = 0.e0 ; zsmlres2(:,:) = 0.e0 + + zfn = REAL( nmoymltrd, wp ) ; zfn2 = zfn * zfn + + ! III.1 Prepare fields for output ("instantaneous" diagnostics) + ! ------------------------------------------------------------- + + !-- Compute total trends + ztmltot(:,:) = ( tml(:,:) - tmlbn(:,:) + tmlb(:,:) - tmlbb(:,:) ) / p2dt + zsmltot(:,:) = ( sml(:,:) - smlbn(:,:) + smlb(:,:) - smlbb(:,:) ) / p2dt + + !-- Compute residuals + ztmlres(:,:) = ztmltot(:,:) - ( tmltrdm(:,:) - tmlatfn(:,:) + tmlatfb(:,:) ) + zsmlres(:,:) = zsmltot(:,:) - ( smltrdm(:,:) - smlatfn(:,:) + smlatfb(:,:) ) + + !-- Diagnose Asselin trend over the analysis window + ztmlatf(:,:) = tmlatfm(:,:) - tmlatfn(:,:) + tmlatfb(:,:) + zsmlatf(:,:) = smlatfm(:,:) - smlatfn(:,:) + smlatfb(:,:) + + !-- Lateral boundary conditions + ! ... temperature ... ... salinity ... + CALL lbc_lnk( 'trdmxl', ztmltot , 'T', 1.0_wp, zsmltot , 'T', 1.0_wp, & + & ztmlres , 'T', 1.0_wp, zsmlres , 'T', 1.0_wp, & + & ztmlatf , 'T', 1.0_wp, zsmlatf , 'T', 1.0_wp ) + + + ! III.2 Prepare fields for output ("mean" diagnostics) + ! ---------------------------------------------------- + + !-- Update the ML depth time sum (to build the Leap-Frog time mean) + hmxl_sum(:,:) = hmxlbn(:,:) + 2 * ( hmxl_sum(:,:) - hmxl(:,:) ) + hmxl(:,:) + + !-- Compute temperature total trends + tml_sum (:,:) = tmlbn(:,:) + 2 * ( tml_sum(:,:) - tml(:,:) ) + tml(:,:) + ztmltot2(:,:) = ( tml_sum(:,:) - tml_sumb(:,:) ) / p2dt ! now in degC/s + + !-- Compute salinity total trends + sml_sum (:,:) = smlbn(:,:) + 2 * ( sml_sum(:,:) - sml(:,:) ) + sml(:,:) + zsmltot2(:,:) = ( sml_sum(:,:) - sml_sumb(:,:) ) / p2dt ! now in psu/s + + !-- Compute temperature residuals + DO jl = 1, jpltrd + ztmltrd2(:,:,jl) = tmltrd_csum_ub(:,:,jl) + tmltrd_csum_ln(:,:,jl) + END DO + + ztmltrdm2(:,:) = 0.e0 + DO jl = 1, jpltrd + ztmltrdm2(:,:) = ztmltrdm2(:,:) + ztmltrd2(:,:,jl) + END DO + + ztmlres2(:,:) = ztmltot2(:,:) - & + ( ztmltrdm2(:,:) - tmltrd_sum(:,:,jpmxl_atf) + tmltrd_atf_sumb(:,:) ) + + !-- Compute salinity residuals + DO jl = 1, jpltrd + zsmltrd2(:,:,jl) = smltrd_csum_ub(:,:,jl) + smltrd_csum_ln(:,:,jl) + END DO + + zsmltrdm2(:,:) = 0. + DO jl = 1, jpltrd + zsmltrdm2(:,:) = zsmltrdm2(:,:) + zsmltrd2(:,:,jl) + END DO + + zsmlres2(:,:) = zsmltot2(:,:) - & + ( zsmltrdm2(:,:) - smltrd_sum(:,:,jpmxl_atf) + smltrd_atf_sumb(:,:) ) + + !-- Diagnose Asselin trend over the analysis window + ztmlatf2(:,:) = ztmltrd2(:,:,jpmxl_atf) - tmltrd_sum(:,:,jpmxl_atf) + tmltrd_atf_sumb(:,:) + zsmlatf2(:,:) = zsmltrd2(:,:,jpmxl_atf) - smltrd_sum(:,:,jpmxl_atf) + smltrd_atf_sumb(:,:) + + !-- Lateral boundary conditions + ! ... temperature ... ... salinity ... + CALL lbc_lnk( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, & + & ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp ) + ! + CALL lbc_lnk( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! / in the NetCDF trends file + + ! III.3 Time evolution array swap + ! ------------------------------- + + ! For T/S instantaneous diagnostics + ! ... temperature ... ... salinity ... + tmlbb (:,:) = tmlb (:,:) ; smlbb (:,:) = smlb (:,:) + tmlbn (:,:) = tml (:,:) ; smlbn (:,:) = sml (:,:) + tmlatfb(:,:) = tmlatfn(:,:) ; smlatfb(:,:) = smlatfn(:,:) + + ! For T mean diagnostics + tmltrd_csum_ub (:,:,:) = zfn * tmltrd_sum(:,:,:) - tmltrd_csum_ln(:,:,:) + tml_sumb (:,:) = tml_sum(:,:) + tmltrd_atf_sumb(:,:) = tmltrd_sum(:,:,jpmxl_atf) + + ! For S mean diagnostics + smltrd_csum_ub (:,:,:) = zfn * smltrd_sum(:,:,:) - smltrd_csum_ln(:,:,:) + sml_sumb (:,:) = sml_sum(:,:) + smltrd_atf_sumb(:,:) = smltrd_sum(:,:,jpmxl_atf) + + ! ML depth + hmxlbn (:,:) = hmxl (:,:) + + ! IF( sn_cfctl%l_prtctl ) THEN + ! IF( ln_trdmxl_instant ) THEN + !CALL prt_ctl(tab2d_1=tmlbb , clinfo1=' tmlbb - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=tmlbn , clinfo1=' tmlbn - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=tmlatfb , clinfo1=' tmlatfb - : ', mask1=tmask) + ! ELSE + !CALL prt_ctl(tab2d_1=tmlbn , clinfo1=' tmlbn - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=hmxlbn , clinfo1=' hmxlbn - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=tml_sumb , clinfo1=' tml_sumb - : ', mask1=tmask) + !CALL prt_ctl(tab2d_1=tmltrd_atf_sumb, clinfo1=' tmltrd_atf_sumb - : ', mask1=tmask) + !CALL prt_ctl(tab3d_1=tmltrd_csum_ub , clinfo1=' tmltrd_csum_ub - : ', mask1=tmask, kdim=1) + ! END IF + ! END IF + + ! III.4 Convert to appropriate physical units + ! ------------------------------------------- + + ! ... temperature ... ... salinity ... + ztmltot (:,:) = ztmltot(:,:) * rn_ucf/zfn ; zsmltot (:,:) = zsmltot(:,:) * rn_ucf/zfn + ztmlres (:,:) = ztmlres(:,:) * rn_ucf/zfn ; zsmlres (:,:) = zsmlres(:,:) * rn_ucf/zfn + ztmlatf (:,:) = ztmlatf(:,:) * rn_ucf/zfn ; zsmlatf (:,:) = zsmlatf(:,:) * rn_ucf/zfn + + tml_sum (:,:) = tml_sum (:,:) / (2*zfn) ; sml_sum (:,:) = sml_sum (:,:) / (2*zfn) + ztmltot2(:,:) = ztmltot2(:,:) * rn_ucf/zfn2 ; zsmltot2(:,:) = zsmltot2(:,:) * rn_ucf/zfn2 + ztmltrd2(:,:,:) = ztmltrd2(:,:,:)* rn_ucf/zfn2 ; zsmltrd2(:,:,:) = zsmltrd2(:,:,:)* rn_ucf/zfn2 + ztmlatf2(:,:) = ztmlatf2(:,:) * rn_ucf/zfn2 ; zsmlatf2(:,:) = zsmlatf2(:,:) * rn_ucf/zfn2 + ztmlres2(:,:) = ztmlres2(:,:) * rn_ucf/zfn2 ; zsmlres2(:,:) = zsmlres2(:,:) * rn_ucf/zfn2 + + hmxl_sum(:,:) = hmxl_sum(:,:) / (2*zfn) ! similar to tml_sum and sml_sum + + ! * Debugging information * + IF( lldebug ) THEN + ! + WRITE(numout,*) + WRITE(numout,*) 'trd_mxl : write trends in the Mixed Layer for debugging process:' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' TRA kt = ', kt, 'nmoymltrd = ', nmoymltrd + WRITE(numout,*) + WRITE(numout,*) ' >>>>>>>>>>>>>>>>>> TRA TEMPERATURE <<<<<<<<<<<<<<<<<<' + WRITE(numout,*) ' TRA ztmlres : ', SUM(ztmlres(:,:)) + WRITE(numout,*) ' TRA ztmltot : ', SUM(ztmltot(:,:)) + WRITE(numout,*) ' TRA tmltrdm : ', SUM(tmltrdm(:,:)) + WRITE(numout,*) ' TRA tmlatfb : ', SUM(tmlatfb(:,:)) + WRITE(numout,*) ' TRA tmlatfn : ', SUM(tmlatfn(:,:)) + DO jl = 1, jpltrd + WRITE(numout,*) ' * TRA TREND INDEX jpmxl_xxx = jl = ', jl, & + & ' tmltrd : ', SUM(tmltrd(:,:,jl)) + END DO + WRITE(numout,*) ' TRA ztmlres (jpi/2,jpj/2) : ', ztmlres (jpi/2,jpj/2) + WRITE(numout,*) ' TRA ztmlres2(jpi/2,jpj/2) : ', ztmlres2(jpi/2,jpj/2) + WRITE(numout,*) + WRITE(numout,*) ' >>>>>>>>>>>>>>>>>> TRA SALINITY <<<<<<<<<<<<<<<<<<' + WRITE(numout,*) ' TRA zsmlres : ', SUM(zsmlres(:,:)) + WRITE(numout,*) ' TRA zsmltot : ', SUM(zsmltot(:,:)) + WRITE(numout,*) ' TRA smltrdm : ', SUM(smltrdm(:,:)) + WRITE(numout,*) ' TRA smlatfb : ', SUM(smlatfb(:,:)) + WRITE(numout,*) ' TRA smlatfn : ', SUM(smlatfn(:,:)) + DO jl = 1, jpltrd + WRITE(numout,*) ' * TRA TREND INDEX jpmxl_xxx = jl = ', jl, & + & ' smltrd : ', SUM(smltrd(:,:,jl)) + END DO + WRITE(numout,*) ' TRA zsmlres (jpi/2,jpj/2) : ', zsmlres (jpi/2,jpj/2) + WRITE(numout,*) ' TRA zsmlres2(jpi/2,jpj/2) : ', zsmlres2(jpi/2,jpj/2) + ! + END IF + ! + END IF MODULO_NTRD + + ! ====================================================================== + ! IV. Write trends in the NetCDF file + ! ====================================================================== + + !-- Write the trends for T/S instantaneous diagnostics + + IF( ln_trdmxl_instant ) THEN + + CALL iom_put( "mxl_depth", hmxl(:,:) ) + + !................................. ( ML temperature ) ................................... + + !-- Output the fields + CALL iom_put( "tml" , tml (:,:) ) + CALL iom_put( "tml_tot" , ztmltot(:,:) ) + CALL iom_put( "tml_res" , ztmlres(:,:) ) + + DO jl = 1, jpltrd - 1 + CALL iom_put( trim("tml"//ctrd(jl,2)), tmltrd (:,:,jl) ) + END DO + + CALL iom_put( trim("tml"//ctrd(jpmxl_atf,2)), ztmlatf(:,:) ) + + !.................................. ( ML salinity ) ..................................... + + !-- Output the fields + CALL iom_put( "sml" , sml (:,:) ) + CALL iom_put( "sml_tot", zsmltot(:,:) ) + CALL iom_put( "sml_res", zsmlres(:,:) ) + + DO jl = 1, jpltrd - 1 + CALL iom_put( trim("sml"//ctrd(jl,2)), smltrd(:,:,jl) ) + END DO + + CALL iom_put( trim("sml"//ctrd(jpmxl_atf,2)), zsmlatf(:,:) ) + + + + ELSE !-- Write the trends for T/S mean diagnostics + + CALL iom_put( "mxl_depth", hmxl_sum(:,:) ) + + !................................. ( ML temperature ) ................................... + + !-- Output the fields + CALL iom_put( "tml" , tml_sum (:,:) ) + CALL iom_put( "tml_tot" , ztmltot2(:,:) ) + CALL iom_put( "tml_res" , ztmlres2(:,:) ) + + DO jl = 1, jpltrd - 1 + CALL iom_put( trim("tml"//ctrd(jl,2)), ztmltrd2(:,:,jl) ) + END DO + + CALL iom_put( trim("tml"//ctrd(jpmxl_atf,2)), ztmlatf2(:,:) ) + + !.................................. ( ML salinity ) ..................................... + + !-- Output the fields + CALL iom_put( "sml" , sml_sum (:,:) ) + CALL iom_put( "sml_tot", zsmltot2(:,:) ) + CALL iom_put( "sml_res", zsmlres2(:,:) ) + + DO jl = 1, jpltrd - 1 + CALL iom_put( trim("sml"//ctrd(jl,2)), zsmltrd2(:,:,jl) ) + END DO + + CALL iom_put( trim("sml"//ctrd(jpmxl_atf,2)), zsmlatf2(:,:) ) + ! + END IF + ! + + IF( MOD( itmod, nn_trd ) == 0 ) THEN + ! + ! III.5 Reset cumulative arrays to zero + ! ------------------------------------- + nmoymltrd = 0 + + ! ... temperature ... ... salinity ... + tmltrdm (:,:) = 0.e0 ; smltrdm (:,:) = 0.e0 + tmlatfm (:,:) = 0.e0 ; smlatfm (:,:) = 0.e0 + tml_sum (:,:) = 0.e0 ; sml_sum (:,:) = 0.e0 + tmltrd_csum_ln (:,:,:) = 0.e0 ; smltrd_csum_ln (:,:,:) = 0.e0 + tmltrd_sum (:,:,:) = 0.e0 ; smltrd_sum (:,:,:) = 0.e0 + + hmxl_sum (:,:) = 0.e0 + ! + END IF + + ! ====================================================================== + ! V. Write restart file + ! ====================================================================== + + IF( lrst_oce ) CALL trd_mxl_rst_write( kt ) + + ! + END SUBROUTINE trd_mxl + + + SUBROUTINE trd_mxl_init + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl_init *** + !! + !! ** Purpose : computation of vertically integrated T and S budgets + !! from ocean surface down to control surface (NetCDF output) + !!---------------------------------------------------------------------- + INTEGER :: jl ! dummy loop indices + INTEGER :: inum ! logical unit + INTEGER :: ios ! local integer + REAL(dp) :: zjulian, zsto, zout + CHARACTER (LEN=40) :: clop + CHARACTER (LEN=12) :: clmxl, cltu, clsu + !! + NAMELIST/namtrd_mxl/ nn_trd , cn_trdrst_in , ln_trdmxl_restart, & + & nn_ctls, cn_trdrst_out, ln_trdmxl_instant, rn_ucf, rn_rho_c + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namtrd_mxl, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in reference namelist' ) + + READ ( numnam_cfg, namtrd_mxl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in configuration namelist' ) + IF(lwm) WRITE( numond, namtrd_mxl ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' trd_mxl_init : Mixed-layer trends' + WRITE(numout,*) ' ~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtrd : set trends parameters' + WRITE(numout,*) ' frequency of trends diagnostics (glo) nn_trd = ', nn_trd + WRITE(numout,*) ' density criteria used to defined the MLD rn_rho_c = ', rn_rho_c + WRITE(numout,*) ' control surface type (mld) nn_ctls = ', nn_ctls + WRITE(numout,*) ' restart for ML diagnostics ln_trdmxl_restart = ', ln_trdmxl_restart + WRITE(numout,*) ' instantaneous or mean ML T/S ln_trdmxl_instant = ', ln_trdmxl_instant + WRITE(numout,*) ' unit conversion factor rn_ucf = ', rn_ucf + WRITE(numout,*) ' criteria to compute the MLD rn_rho_c = ', rn_rho_c + ENDIF + + + + ! I.1 Check consistency of user defined preferences + ! ------------------------------------------------- + + IF ( rn_rho_c /= rho_c ) CALL ctl_warn( 'Unless you have good reason to do so, you should use the value ', & + & 'defined in zdfmxl.F90 module to calculate the mixed layer depth' ) + + IF( MOD( nitend, nn_trd ) /= 0 ) THEN + WRITE(ctmp1,*) ' Your nitend parameter, nitend = ', nitend + WRITE(ctmp2,*) ' is no multiple of the trends diagnostics frequency ' + WRITE(ctmp3,*) ' you defined, nn_trd = ', nn_trd + WRITE(ctmp4,*) ' This will not allow you to restart from this simulation. ' + WRITE(ctmp5,*) ' You should reconsider this choice. ' + WRITE(ctmp6,*) + WRITE(ctmp7,*) ' N.B. the nitend parameter is also constrained to be a ' + WRITE(ctmp8,*) ' multiple of the nn_fsbc parameter ' + CALL ctl_stop( ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) + END IF + + ! ! allocate trdmxl arrays + IF( trd_mxl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_mxl_init : unable to allocate trdmxl arrays' ) + IF( trdmxl_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_mxl_init : unable to allocate trdmxl_oce arrays' ) + + + + nkstp = nit000 - 1 ! current time step indicator initialization + + + + + ! I.2 Initialize arrays to zero or read a restart file + ! ---------------------------------------------------- + + nmoymltrd = 0 + + ! ... temperature ... ... salinity ... + tml (:,:) = 0.e0 ; sml (:,:) = 0.e0 ! inst. + tmltrdm (:,:) = 0.e0 ; smltrdm (:,:) = 0.e0 + tmlatfm (:,:) = 0.e0 ; smlatfm (:,:) = 0.e0 + tml_sum (:,:) = 0.e0 ; sml_sum (:,:) = 0.e0 ! mean + tmltrd_sum (:,:,:) = 0.e0 ; smltrd_sum (:,:,:) = 0.e0 + tmltrd_csum_ln (:,:,:) = 0.e0 ; smltrd_csum_ln (:,:,:) = 0.e0 + + hmxl (:,:) = 0.e0 + hmxl_sum (:,:) = 0.e0 + + IF( ln_rstart .AND. ln_trdmxl_restart ) THEN + CALL trd_mxl_rst_read + ELSE + ! ... temperature ... ... salinity ... + tmlb (:,:) = 0.e0 ; smlb (:,:) = 0.e0 ! inst. + tmlbb (:,:) = 0.e0 ; smlbb (:,:) = 0.e0 + tmlbn (:,:) = 0.e0 ; smlbn (:,:) = 0.e0 + tml_sumb (:,:) = 0.e0 ; sml_sumb (:,:) = 0.e0 ! mean + tmltrd_csum_ub (:,:,:) = 0.e0 ; smltrd_csum_ub (:,:,:) = 0.e0 + tmltrd_atf_sumb(:,:) = 0.e0 ; smltrd_atf_sumb(:,:) = 0.e0 + END IF + + icount = 1 ; ionce = 1 ! open specifier + + ! I.3 Read control surface from file ctlsurf_idx + ! ---------------------------------------------- + + IF( nn_ctls == 1 ) THEN + CALL ctl_opn( inum, 'ctlsurf_idx', 'OLD', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + READ ( inum, * ) nbol + CLOSE( inum ) + END IF + + ! ====================================================================== + ! II. netCDF output initialization + ! ====================================================================== + + ! clmxl = legend root for netCDF output + IF( nn_ctls == 0 ) THEN ! control surface = mixed-layer with density criterion + clmxl = 'Mixed Layer ' ! (array nmln computed in zdfmxl.F90) + ELSE IF( nn_ctls == 1 ) THEN ! control surface = read index from file + clmxl = ' Bowl ' + ELSE IF( nn_ctls >= 2 ) THEN ! control surface = model level + WRITE(clmxl,'(A10,I2,1X)') 'Levels 1 -', nn_ctls + END IF + + + + ! II.3 Define the T grid trend file (nidtrd) + ! ------------------------------------------ + !-- Define long and short names for the NetCDF output variables + ! ==> choose them according to trdmxl_oce.F90 <== + + ctrd(jpmxl_xad,1) = " Zonal advection" ; ctrd(jpmxl_xad,2) = "_xad" + ctrd(jpmxl_yad,1) = " Meridional advection" ; ctrd(jpmxl_yad,2) = "_yad" + ctrd(jpmxl_zad,1) = " Vertical advection" ; ctrd(jpmxl_zad,2) = "_zad" + ctrd(jpmxl_ldf,1) = " Lateral diffusion" ; ctrd(jpmxl_ldf,2) = "_ldf" + ctrd(jpmxl_for,1) = " Forcing" ; ctrd(jpmxl_for,2) = "_for" + ctrd(jpmxl_zdf,1) = " Vertical diff. (Kz)" ; ctrd(jpmxl_zdf,2) = "_zdf" + ctrd(jpmxl_bbc,1) = " Geothermal flux" ; ctrd(jpmxl_bbc,2) = "_bbc" + ctrd(jpmxl_bbl,1) = " Adv/diff. Bottom boundary layer" ; ctrd(jpmxl_bbl,2) = "_bbl" + ctrd(jpmxl_dmp,1) = " Tracer damping" ; ctrd(jpmxl_dmp,2) = "_dmp" + ctrd(jpmxl_npc,1) = " Non penetrative convec. adjust." ; ctrd(jpmxl_npc,2) = "_npc" + ctrd(jpmxl_atf,1) = " Asselin time filter" ; ctrd(jpmxl_atf,2) = "_atf" + + + !-- Define physical units + IF ( rn_ucf == 1. ) THEN ; cltu = "degC/s" ; clsu = "p.s.u./s" + ELSEIF ( rn_ucf == 3600.*24.) THEN ; cltu = "degC/day" ; clsu = "p.s.u./day" + ELSE ; cltu = "unknown?" ; clsu = "unknown?" + END IF + ! + END SUBROUTINE trd_mxl_init + + !!====================================================================== +END MODULE trdmxl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdmxl_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdmxl_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e7ae8df46af6868b21bb0c6879f9929647c0a89c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdmxl_oce.f90 @@ -0,0 +1,148 @@ + + + + + + + + + + + + + +MODULE trdmxl_oce + !!====================================================================== + !! *** MODULE trdmxl_oce *** + !! Ocean trends : set tracer and momentum trend variables + !!====================================================================== + !! History : 1.0 ! 2004-08 (C. Talandier) New trends organization + !! 3.5 ! 2012-02 (G. Madec) suppress the trend keys + new trdmxl formulation + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + + IMPLICIT NONE + PRIVATE + + PUBLIC trdmxl_oce_alloc ! Called in trdmxl.F90 + + ! !* mixed layer trend indices + INTEGER, PUBLIC, PARAMETER :: jpltrd = 12 !: number of mixed-layer trends arrays + INTEGER, PUBLIC :: jpktrd !: max level for mixed-layer trends diag. + ! + INTEGER, PUBLIC, PARAMETER :: jpmxl_xad = 1 !: i-componant of advection + INTEGER, PUBLIC, PARAMETER :: jpmxl_yad = 2 !: j-componant of advection + INTEGER, PUBLIC, PARAMETER :: jpmxl_zad = 3 !: k-component of advection + INTEGER, PUBLIC, PARAMETER :: jpmxl_ldf = 4 !: lateral diffusion (geopot. or iso-neutral) + INTEGER, PUBLIC, PARAMETER :: jpmxl_zdf = 5 !: vertical diffusion + INTEGER, PUBLIC, PARAMETER :: jpmxl_npc = 6 !: non penetrative convective adjustment + INTEGER, PUBLIC, PARAMETER :: jpmxl_bbc = 7 !: geothermal flux + INTEGER, PUBLIC, PARAMETER :: jpmxl_bbl = 8 !: bottom boundary layer (advective/diffusive) + INTEGER, PUBLIC, PARAMETER :: jpmxl_for = 9 !: forcing + INTEGER, PUBLIC, PARAMETER :: jpmxl_dmp = 10 !: internal restoring trend + INTEGER, PUBLIC, PARAMETER :: jpmxl_zdfp = 11 !: ! iso-neutral diffusion:"pure" vertical diffusion + INTEGER, PUBLIC, PARAMETER :: jpmxl_atf = 12 !: asselin trend (**MUST BE THE LAST ONE**) + ! !!* Namelist namtrd_mxl: trend diagnostics in the mixed layer * + INTEGER , PUBLIC :: nn_ctls = 0 !: control surface type for trends vertical integration + REAL(wp) , PUBLIC :: rn_rho_c = 0.01 !: density criteria for MLD definition + REAL(wp) , PUBLIC :: rn_ucf = 1. !: unit conversion factor (for netCDF trends outputs) + ! =1. (=86400.) for degC/s (degC/day) and psu/s (psu/day) + CHARACTER(len=32), PUBLIC :: cn_trdrst_in = "restart_mxl" !: suffix of ocean restart name (input) + CHARACTER(len=32), PUBLIC :: cn_trdrst_out = "restart_mxl" !: suffix of ocean restart name (output) + LOGICAL , PUBLIC :: ln_trdmxl_instant = .FALSE. !: flag to diagnose inst./mean ML T/S trends + LOGICAL , PUBLIC :: ln_trdmxl_restart = .FALSE. !: flag to restart mixed-layer diagnostics + + + !! Arrays used for diagnosing mixed-layer trends + !!--------------------------------------------------------------------- + CHARACTER(LEN=80) , PUBLIC :: clname, ctrd(jpltrd+1,2) + + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmxl !: mixed layer depth indexes + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nbol !: mixed-layer depth indexes when read from file + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wkx !: + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: & + hmxl , & !: mixed layer depth (m) corresponding to nmld + tml , sml , & !: \ "now" mixed layer temperature/salinity + tmlb , smlb , & !: / and associated "before" fields + tmlbb , smlbb, & !: \ idem, but valid at the 1rst time step of the + tmlbn , smlbn, & !: / current analysis window + tmltrdm, smltrdm, & !: total cumulative trends over the analysis window + tml_sum, & !: mixed layer T, summed over the current analysis period + tml_sumb, & !: idem, but from the previous analysis period + tmltrd_atf_sumb, & !: Asselin trends, summed over the previous analysis period + sml_sum, & !: + sml_sumb, & !: ( idem for salinity ) + smltrd_atf_sumb, & !: + hmxl_sum, hmxlbn !: needed to compute the leap-frog time mean of the ML depth + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: & + tmlatfb, tmlatfn , & !: "before" Asselin contribution at begining of the averaging + smlatfb, smlatfn, & !: period (i.e. last contrib. from previous such period) and + !: "now" Asselin contribution to the ML temp. & salinity trends + tmlatfm, smlatfm !: accumulator for Asselin trends (needed for storage only) + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: & + tmltrd, & !: \ physical contributions to the total trend (for T/S), + smltrd, & !: / cumulated over the current analysis window + tmltrd_sum, & !: sum of these trends over the analysis period + tmltrd_csum_ln, & !: now cumulated sum of the trends over the "lower triangle" + tmltrd_csum_ub, & !: before (prev. analysis period) cumulated sum over the upper triangle + smltrd_sum, & !: + smltrd_csum_ln, & !: ( idem for salinity ) + smltrd_csum_ub !: + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdmxl_oce.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trdmxl_oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION trdmxl_oce_alloc *** + !!---------------------------------------------------------------------- + USE lib_mpp + INTEGER :: ierr(5) + !!---------------------------------------------------------------------- + + ! Initialise jpktrd here as can no longer do it in MODULE body since + ! jpk is now a variable. + jpktrd = jpk !: max level for mixed-layer trends diag. + + ierr(:) = 0 + + ALLOCATE( nmxl (jpi,jpj) , nbol (jpi,jpj), & + & wkx (jpi,jpj,jpk), hmxl (jpi,jpj), & + & tml (jpi,jpj) , sml (jpi,jpj), & + & tmlb (jpi,jpj) , smlb (jpi,jpj), & + & tmlbb(jpi,jpj) , smlbb(jpi,jpj), STAT = ierr(1) ) + + ALLOCATE( tmlbn(jpi,jpj) , smlbn(jpi,jpj), & + & tmltrdm(jpi,jpj), smltrdm(jpi,jpj), & + & tml_sum(jpi,jpj), tml_sumb(jpi,jpj),& + & tmltrd_atf_sumb(jpi,jpj) , STAT=ierr(2) ) + + ALLOCATE( sml_sum(jpi,jpj), sml_sumb(jpi,jpj), & + & smltrd_atf_sumb(jpi,jpj), & + & hmxl_sum(jpi,jpj), hmxlbn(jpi,jpj), & + & tmlatfb(jpi,jpj), tmlatfn(jpi,jpj), STAT = ierr(3) ) + + ALLOCATE( smlatfb(jpi,jpj), smlatfn(jpi,jpj), & + & tmlatfm(jpi,jpj), smlatfm(jpi,jpj), & + & tmltrd(jpi,jpj,jpltrd), smltrd(jpi,jpj,jpltrd), STAT=ierr(4)) + + ALLOCATE( tmltrd_sum(jpi,jpj,jpltrd),tmltrd_csum_ln(jpi,jpj,jpltrd), & + & tmltrd_csum_ub(jpi,jpj,jpltrd), smltrd_sum(jpi,jpj,jpltrd), & + & smltrd_csum_ln(jpi,jpj,jpltrd), smltrd_csum_ub(jpi,jpj,jpltrd), STAT=ierr(5) ) + ! + trdmxl_oce_alloc = MAXVAL( ierr ) + CALL mpp_sum ( 'trdmxl_oce', trdmxl_oce_alloc ) + IF( trdmxl_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trdmxl_oce_alloc: failed to allocate arrays' ) + ! + END FUNCTION trdmxl_oce_alloc + + !!====================================================================== +END MODULE trdmxl_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdmxl_rst.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdmxl_rst.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9fc28e20951c93eaa7a8d2bc6150033acc044ddd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdmxl_rst.f90 @@ -0,0 +1,203 @@ + + + + + + + + + + + + + +MODULE trdmxl_rst + !!================================================================================= + !! *** MODULE trdmxl_rst *** + !! Ocean dynamic : Input/Output files for restart on mixed-layer diagnostics + !!================================================================================= + !! History : 1.0 ! 2005-05 (C. Deltel) Original code + !!--------------------------------------------------------------------------------- + + !!--------------------------------------------------------------------------------- + !! trd_mxl_rst_write : write mixed layer trend restart + !! trd_mxl_rst_read : read mixed layer trend restart + !!--------------------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE trd_oce ! trends: ocean variables + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE restart ! only for lrst_oce + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_mxl_rst_read ! routine called by trd_mxl_init + PUBLIC trd_mxl_rst_write ! routine called by step.F90 + + INTEGER :: nummxlw ! logical unit for mxl restart + + !!--------------------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdmxl_rst.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!--------------------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_mxl_rst_write( kt ) + !!-------------------------------------------------------------------------------- + !! *** SUBROUTINE trd_mxl_rst_wri *** + !! + !! ** Purpose : Write mixed-layer diagnostics restart fields. + !!-------------------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + CHARACTER (len=35) :: charout + INTEGER :: jk ! loop indice + CHARACTER(LEN=20) :: clkt ! ocean time-step deine as a character + CHARACTER(LEN=50) :: clname ! output restart file name + CHARACTER(LEN=256) :: clpath ! full path to restart file + !!-------------------------------------------------------------------------------- + + IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart + + ! to get better performances with NetCDF format: + ! we open and define the ocean restart_mxl file one time step before writing the data (-> at nitrst - 1) + ! except if we write ocean restart_mxl files every time step or if an ocean restart_mxl file was writen at nitend - 1 + IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. ( kt == nitend .AND. MOD( nitend - 1, nn_stock ) == 0 ) ) THEN + ! beware of the format used to write kt (default is i8.8, that should be large enough...) + IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst + ELSE ; WRITE(clkt, '(i8.8)') nitrst + ENDIF + ! create the file + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_trdrst_out) + clpath = TRIM(cn_ocerst_outdir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' open ocean restart_mxl NetCDF file: '//clname + IF( kt == nitrst - 1 ) THEN ; WRITE(numout,*) ' kt = nitrst - 1 = ', kt,' date= ', ndastp + ELSE ; WRITE(numout,*) ' kt = ' , kt,' date= ', ndastp + ENDIF + ENDIF + + CALL iom_open( TRIM(clpath)//TRIM(clname), nummxlw, ldwrt = .TRUE. ) + ENDIF + + IF( kt == nitrst .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'trdmxl_rst: output for ML diags. restart, with trd_mxl_rst_write routine kt =', kt + WRITE(numout,*) '~~~~~~~~~~' + WRITE(numout,*) + ENDIF + + IF( ln_trdmxl_instant ) THEN + !-- Temperature + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbb' , tmlbb ) + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbn' , tmlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlatfb' , tmlatfb ) + + !-- Salinity + CALL iom_rstput( kt, nitrst, nummxlw, 'smlbb' , smlbb ) + CALL iom_rstput( kt, nitrst, nummxlw, 'smlbn' , smlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'smlatfb' , smlatfb ) + ELSE + CALL iom_rstput( kt, nitrst, nummxlw, 'hmxlbn' , hmxlbn ) + + !-- Temperature + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbn' , tmlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'tml_sumb' , tml_sumb ) + DO jk = 1, jpltrd + IF( jk < 10 ) THEN ; WRITE(charout,FMT="('tmltrd_csum_ub_', I1)") jk + ELSE ; WRITE(charout,FMT="('tmltrd_csum_ub_', I2)") jk + ENDIF + CALL iom_rstput( kt, nitrst, nummxlw, charout, tmltrd_csum_ub(:,:,jk) ) + ENDDO + CALL iom_rstput( kt, nitrst, nummxlw, 'tmltrd_atf_sumb' , tmltrd_atf_sumb ) + + !-- Salinity + CALL iom_rstput( kt, nitrst, nummxlw, 'smlbn' , smlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'sml_sumb' , sml_sumb ) + DO jk = 1, jpltrd + IF( jk < 10 ) THEN ; WRITE(charout,FMT="('smltrd_csum_ub_', I1)") jk + ELSE ; WRITE(charout,FMT="('smltrd_csum_ub_', I2)") jk + ENDIF + CALL iom_rstput( kt, nitrst, nummxlw, charout , smltrd_csum_ub(:,:,jk) ) + ENDDO + CALL iom_rstput( kt, nitrst, nummxlw, 'smltrd_atf_sumb' , smltrd_atf_sumb ) + ENDIF + ! + IF( kt == nitrst ) THEN + CALL iom_close( nummxlw ) ! close the restart file (only at last time step) + lrst_oce = .FALSE. + ENDIF + ! + END SUBROUTINE trd_mxl_rst_write + + + SUBROUTINE trd_mxl_rst_read + !!---------------------------------------------------------------------------- + !! *** SUBROUTINE trd_mxl_rst_lec *** + !! + !! ** Purpose : Read file for mixed-layer diagnostics restart. + !!---------------------------------------------------------------------------- + INTEGER :: inum ! temporary logical unit + ! + CHARACTER (len=35) :: charout + INTEGER :: jk ! loop indice + LOGICAL :: llok + CHARACTER(LEN=256) :: clpath ! full path to restart file + !!----------------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' trd_mxl_rst_read : read the NetCDF mixed layer trend restart file' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~' + ENDIF + + clpath = TRIM(cn_ocerst_indir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + CALL iom_open( TRIM(clpath)//TRIM(cn_trdrst_in), inum ) + + IF( ln_trdmxl_instant ) THEN + !-- Temperature + CALL iom_get( inum, jpdom_auto, 'tmlbb' , tmlbb ) + CALL iom_get( inum, jpdom_auto, 'tmlbn' , tmlbn ) + CALL iom_get( inum, jpdom_auto, 'tmlatfb' , tmlatfb ) + ! + !-- Salinity + CALL iom_get( inum, jpdom_auto, 'smlbb' , smlbb ) + CALL iom_get( inum, jpdom_auto, 'smlbn' , smlbn ) + CALL iom_get( inum, jpdom_auto, 'smlatfb' , smlatfb ) + ELSE + CALL iom_get( inum, jpdom_auto, 'hmxlbn' , hmxlbn ) ! needed for hmxl_sum + ! + !-- Temperature + CALL iom_get( inum, jpdom_auto, 'tmlbn' , tmlbn ) ! needed for tml_sum + CALL iom_get( inum, jpdom_auto, 'tml_sumb' , tml_sumb ) + DO jk = 1, jpltrd + IF( jk < 10 ) THEN ; WRITE(charout,FMT="('tmltrd_csum_ub_', I1)") jk + ELSE ; WRITE(charout,FMT="('tmltrd_csum_ub_', I2)") jk + ENDIF + CALL iom_get( inum, jpdom_auto, charout, tmltrd_csum_ub(:,:,jk) ) + END DO + CALL iom_get( inum, jpdom_auto, 'tmltrd_atf_sumb' , tmltrd_atf_sumb) + ! + !-- Salinity + CALL iom_get( inum, jpdom_auto, 'smlbn' , smlbn ) ! needed for sml_sum + CALL iom_get( inum, jpdom_auto, 'sml_sumb' , sml_sumb ) + DO jk = 1, jpltrd + IF( jk < 10 ) THEN ; WRITE(charout,FMT="('smltrd_csum_ub_', I1)") jk + ELSE ; WRITE(charout,FMT="('smltrd_csum_ub_', I2)") jk + ENDIF + CALL iom_get( inum, jpdom_auto, charout, smltrd_csum_ub(:,:,jk) ) + END DO + CALL iom_get( inum, jpdom_auto, 'smltrd_atf_sumb' , smltrd_atf_sumb) + ! + CALL iom_close( inum ) + ENDIF + ! + END SUBROUTINE trd_mxl_rst_read + + !!================================================================================= +END MODULE trdmxl_rst diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdpen.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdpen.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b03a98b7e496e2d617b50b2759686d34405acbf0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdpen.f90 @@ -0,0 +1,174 @@ + + + + + + + + + + + + + +MODULE trdpen + !!====================================================================== + !! *** MODULE trdpen *** + !! Ocean diagnostics: Potential Energy trends + !!===================================================================== + !! History : 3.5 ! 2012-02 (G. Madec) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_pen : compute and output Potential Energy trends from T & S trends + !! trd_pen_init : initialisation of PE trends + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean domain + USE sbc_oce ! surface boundary condition: ocean + USE zdf_oce ! ocean vertical physics + USE trd_oce ! trends: ocean variables + USE eosbn2 ! equation of state and related derivatives + USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. + USE zdfddm ! vertical physics: double diffusion + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_pen ! called by all trdtra module + PUBLIC trd_pen_init ! called by all nemogcm module + + INTEGER :: nkstp ! current time step + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_pe ! partial derivatives of PE anomaly with respect to T and S + + !! * Substitutions +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdpen.F90 13237 2020-07-03 09:12:53Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + INTEGER FUNCTION trd_pen_alloc() + !!--------------------------------------------------------------------- + !! *** FUNCTION trd_tra_alloc *** + !!--------------------------------------------------------------------- + ALLOCATE( rab_pe(jpi,jpj,jpk,jpts) , STAT= trd_pen_alloc ) + ! + CALL mpp_sum ( 'trdpen', trd_pen_alloc ) + IF( trd_pen_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_pen_alloc: failed to allocate arrays' ) + END FUNCTION trd_pen_alloc + + + SUBROUTINE trd_pen( ptrdx, ptrdy, ktrd, kt, pdt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra_mng *** + !! + !! ** Purpose : Dispatch all trends computation, e.g. 3D output, integral + !! constraints, barotropic vorticity, kinetic enrgy, + !! potential energy, and/or mixed layer budget. + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: ptrdx, ptrdy ! Temperature & Salinity trends + INTEGER , INTENT(in) :: ktrd ! tracer trend index + INTEGER , INTENT(in) :: kt ! time step index + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(wp) , INTENT(in) :: pdt ! time step [s] + ! + INTEGER :: jk ! dummy loop indices + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpe ! 3D workspace + !!---------------------------------------------------------------------- + ! + zpe(:,:,:) = 0._wp + ! + IF( kt /= nkstp ) THEN ! full eos: set partial derivatives at the 1st call of kt time step + nkstp = kt + CALL eos_pen( ts(:,:,:,:,Kmm), rab_pe, zpe, Kmm ) + CALL iom_put( "alphaPE", rab_pe(:,:,:,jp_tem) ) + CALL iom_put( "betaPE" , rab_pe(:,:,:,jp_sal) ) + CALL iom_put( "PEanom" , zpe ) + ENDIF + ! + zpe(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + zpe(:,:,jk) = ( - ( rab_n(:,:,jk,jp_tem) + rab_pe(:,:,jk,jp_tem) ) * ptrdx(:,:,jk) & + & + ( rab_n(:,:,jk,jp_sal) + rab_pe(:,:,jk,jp_sal) ) * ptrdy(:,:,jk) ) + END DO + + SELECT CASE ( ktrd ) + CASE ( jptra_xad ) ; CALL iom_put( "petrd_xad", zpe ) ! zonal advection + CASE ( jptra_yad ) ; CALL iom_put( "petrd_yad", zpe ) ! merid. advection + CASE ( jptra_zad ) ; CALL iom_put( "petrd_zad", zpe ) ! vertical advection + IF( ln_linssh ) THEN ! cst volume : adv flux through z=0 surface + ALLOCATE( z2d(jpi,jpj) ) + z2d(:,:) = ww(:,:,1) * ( & + & - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * ts(:,:,1,jp_tem,Kmm) & + & + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * ts(:,:,1,jp_sal,Kmm) & + & ) / (e3t_0(:,:,1)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,1))) + CALL iom_put( "petrd_sad" , z2d ) + DEALLOCATE( z2d ) + ENDIF + CASE ( jptra_ldf ) ; CALL iom_put( "petrd_ldf" , zpe ) ! lateral diffusion + CASE ( jptra_zdf ) ; CALL iom_put( "petrd_zdf" , zpe ) ! lateral diffusion (K_z) + CASE ( jptra_zdfp ) ; CALL iom_put( "petrd_zdfp", zpe ) ! vertical diffusion (K_z) + CASE ( jptra_dmp ) ; CALL iom_put( "petrd_dmp" , zpe ) ! internal 3D restoring (tradmp) + CASE ( jptra_bbl ) ; CALL iom_put( "petrd_bbl" , zpe ) ! bottom boundary layer + CASE ( jptra_npc ) ; CALL iom_put( "petrd_npc" , zpe ) ! non penetr convect adjustment + CASE ( jptra_nsr ) ; CALL iom_put( "petrd_nsr" , zpe ) ! surface forcing + runoff (ln_rnf=T) + CASE ( jptra_qsr ) ; CALL iom_put( "petrd_qsr" , zpe ) ! air-sea : penetrative sol radiat + CASE ( jptra_bbc ) ; CALL iom_put( "petrd_bbc" , zpe ) ! bottom bound cond (geoth flux) + CASE ( jptra_atf ) ; CALL iom_put( "petrd_atf" , zpe ) ! asselin time filter (last trend) + ! + END SELECT + ! + ! + END SUBROUTINE trd_pen + + + SUBROUTINE trd_pen_init + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_pen_init *** + !! + !! ** Purpose : initialisation of 3D Kinetic Energy trend diagnostic + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'trd_pen_init : 3D Potential ENergy trends' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! ! allocate box volume arrays + IF ( trd_pen_alloc() /= 0 ) CALL ctl_stop('trd_pen_alloc: failed to allocate arrays') + ! + rab_pe(:,:,:,:) = 0._wp + ! + IF( .NOT.ln_linssh ) CALL ctl_stop('trd_pen_init : PE trends not coded for variable volume') + ! + nkstp = nit000 - 1 + ! + END SUBROUTINE trd_pen_init + + !!====================================================================== +END MODULE trdpen diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdtra.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdtra.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e24f30da0d357b69628df21664f6efd2b9812dbb --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdtra.f90 @@ -0,0 +1,401 @@ + + + + + + + + + + + + + +MODULE trdtra + !!====================================================================== + !! *** MODULE trdtra *** + !! Ocean diagnostics: ocean tracers trends pre-processing + !!===================================================================== + !! History : 3.3 ! 2010-06 (C. Ethe) creation for the TRA/TRC merge + !! 3.5 ! 2012-02 (G. Madec) update the comments + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_tra : pre-process the tracer trends + !! trd_tra_adv : transform a div(U.T) trend into a U.grad(T) trend + !! trd_tra_mng : tracer trend manager: dispatch to the diagnostic modules + !! trd_tra_iom : output 3D tracer trends using IOM + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean domain + USE sbc_oce ! surface boundary condition: ocean + USE zdf_oce ! ocean vertical physics + USE trd_oce ! trends: ocean variables + USE trdtrc ! ocean passive mixed layer tracers trends + USE trdglo ! trends: global domain averaged + USE trdpen ! trends: Potential ENergy + USE trdmxl ! ocean active mixed layer tracers trends + USE ldftra ! ocean active tracers lateral physics + USE ldfslp + USE zdfddm ! vertical physics: double diffusion + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_tra ! called by all tra_... modules + + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: trdtx, trdty, trdt ! use to store the temperature trends + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_evd ! store avt_evd to calculate EVD trend + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdtra.F90 14174 2020-12-15 18:25:18Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_tra_alloc() + !!--------------------------------------------------------------------- + !! *** FUNCTION trd_tra_alloc *** + !!--------------------------------------------------------------------- + ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , avt_evd(jpi,jpj,jpk), STAT= trd_tra_alloc ) + ! + CALL mpp_sum ( 'trdtra', trd_tra_alloc ) + IF( trd_tra_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_tra_alloc: failed to allocate arrays' ) + END FUNCTION trd_tra_alloc + + + SUBROUTINE trd_tra( kt, Kmm, Krhs, ctype, ktra, ktrd, ptrd, pu, ptra ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra *** + !! + !! ** Purpose : pre-process tracer trends + !! + !! ** Method : - mask the trend + !! - advection (ptra present) converte the incoming flux (U.T) + !! into trend (U.T => -U.grat(T)=div(U.T)-T.div(U)) through a + !! call to trd_tra_adv + !! - 'TRA' case : regroup T & S trends + !! - send the trends to trd_tra_mng (trdtrc) for further processing + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step + CHARACTER(len=3) , INTENT(in) :: ctype ! tracers trends type 'TRA'/'TRC' + INTEGER , INTENT(in) :: ktra ! tracer index + INTEGER , INTENT(in) :: ktrd ! tracer trend index + INTEGER , INTENT(in) :: Kmm, Krhs ! time level indices + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptrd ! tracer trend or flux + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pu ! now velocity + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: ptra ! now tracer variable + ! + INTEGER :: jk ! loop indices + INTEGER :: i01 ! 0 or 1 + REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztrds ! 3D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwt, zws! 3D workspace + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( .NOT. ALLOCATED( trdtx ) ) THEN ! allocate trdtra arrays + IF( trd_tra_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_tra : unable to allocate arrays' ) + avt_evd(:,:,:) = 0._wp + ENDIF + ! + i01 = COUNT( (/ PRESENT(pu) .OR. ( ktrd /= jptra_xad .AND. ktrd /= jptra_yad .AND. ktrd /= jptra_zad ) /) ) + ! + IF( ctype == 'TRA' .AND. ktra == jp_tem ) THEN !== Temperature trend ==! + ! + SELECT CASE( ktrd*i01 ) + ! ! advection: transform the advective flux into a trend + CASE( jptra_xad ) ; CALL trd_tra_adv( ptrd, pu, ptra, 'X', trdtx, Kmm ) + CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd, pu, ptra, 'Y', trdty, Kmm ) + CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd, pu, ptra, 'Z', trdt, Kmm ) + CASE( jptra_bbc, & ! qsr, bbc: on temperature only, send to trd_tra_mng + & jptra_qsr ) ; trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) + ztrds(:,:,:) = 0._wp + CALL trd_tra_mng( trdt, ztrds, ktrd, kt, Kmm ) + !!gm Gurvan, verify the jptra_evd trend please ! + CASE( jptra_evd ) ; avt_evd(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) + CASE DEFAULT ! other trends: masked trends + trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) ! mask & store + END SELECT + ! + ENDIF + + IF( ctype == 'TRA' .AND. ktra == jp_sal ) THEN !== Salinity trends ==! + ! + SELECT CASE( ktrd*i01 ) + ! ! advection: transform the advective flux into a trend + ! ! and send T & S trends to trd_tra_mng + CASE( jptra_xad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'X' , ztrds, Kmm ) + CALL trd_tra_mng( trdtx, ztrds, ktrd, kt, Kmm ) + CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'Y' , ztrds, Kmm ) + CALL trd_tra_mng( trdty, ztrds, ktrd, kt, Kmm ) + CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'Z' , ztrds, Kmm ) + CALL trd_tra_mng( trdt , ztrds, ktrd, kt, Kmm ) + CASE( jptra_zdfp ) ! diagnose the "PURE" Kz trend (here: just before the swap) + ! ! iso-neutral diffusion case otherwise jptra_zdf is "PURE" + ALLOCATE( zwt(jpi,jpj,jpk), zws(jpi,jpj,jpk), ztrdt(jpi,jpj,jpk) ) + ! + zwt(:,:, 1 ) = 0._wp ; zws(:,:, 1 ) = 0._wp ! vertical diffusive fluxes + zwt(:,:,jpk) = 0._wp ; zws(:,:,jpk) = 0._wp + DO jk = 2, jpk + zwt(:,:,jk) = avt(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) & + & / (e3w_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) * tmask(:,:,jk) + zws(:,:,jk) = avs(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) & + & / (e3w_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) * tmask(:,:,jk) + END DO + ! + ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + END DO + CALL trd_tra_mng( ztrdt, ztrds, jptra_zdfp, kt, Kmm ) + ! + ! ! Also calculate EVD trend at this point. + zwt(:,:,:) = 0._wp ; zws(:,:,:) = 0._wp ! vertical diffusive fluxes + DO jk = 2, jpk + zwt(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) & + & / (e3w_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) * tmask(:,:,jk) + zws(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) & + & / (e3w_0(:,:,jk)*(1._wp+r3t(:,:,Kmm))) * tmask(:,:,jk) + END DO + ! + ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / (e3t_0(:,:,jk)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,jk))) + END DO + CALL trd_tra_mng( ztrdt, ztrds, jptra_evd, kt, Kmm ) + ! + DEALLOCATE( zwt, zws, ztrdt ) + ! + CASE DEFAULT ! other trends: mask and send T & S trends to trd_tra_mng + ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) + CALL trd_tra_mng( trdt, ztrds, ktrd, kt, Kmm ) + END SELECT + ENDIF + + IF( ctype == 'TRC' ) THEN !== passive tracer trend ==! + ! + SELECT CASE( ktrd*i01 ) + ! ! advection: transform the advective flux into a masked trend + CASE( jptra_xad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'X', ztrds, Kmm ) + CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'Y', ztrds, Kmm ) + CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'Z', ztrds, Kmm ) + CASE DEFAULT ! other trends: just masked + ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) + END SELECT + ! ! send trend to trd_trc + CALL trd_trc( ztrds, ktra, ktrd, kt, Kmm ) + ! + ENDIF + ! + END SUBROUTINE trd_tra + + + SUBROUTINE trd_tra_adv( pf, pu, pt, cdir, ptrd, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra_adv *** + !! + !! ** Purpose : transformed a advective flux into a masked advective trends + !! + !! ** Method : use the following transformation: -div(U.T) = - U grad(T) + T.div(U) + !! i-advective trends = -un. di-1[T] = -( di-1[fi] - tn di-1[un] ) + !! j-advective trends = -un. di-1[T] = -( dj-1[fi] - tn dj-1[un] ) + !! k-advective trends = -un. di+1[T] = -( dk+1[fi] - tn dk+1[un] ) + !! where fi is the incoming advective flux. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pf ! advective flux in one direction + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu ! now velocity in one direction + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt ! now or before tracer + CHARACTER(len=1) , INTENT(in ) :: cdir ! X/Y/Z direction + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT( out) :: ptrd ! advective trend in one direction + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ii, ij, ik ! index shift as function of the direction + !!---------------------------------------------------------------------- + ! + SELECT CASE( cdir ) ! shift depending on the direction + CASE( 'X' ) ; ii = 1 ; ij = 0 ; ik = 0 ! i-trend + CASE( 'Y' ) ; ii = 0 ; ij = 1 ; ik = 0 ! j-trend + CASE( 'Z' ) ; ii = 0 ; ij = 0 ; ik =-1 ! k-trend + END SELECT + ! + ! ! set to zero uncomputed values + ptrd(jpi,:,:) = 0._wp ; ptrd(1,:,:) = 0._wp + ptrd(:,jpj,:) = 0._wp ; ptrd(:,1,:) = 0._wp + ptrd(:,:,jpk) = 0._wp + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! advective trend + ptrd(ji,jj,jk) = - ( pf (ji,jj,jk) - pf (ji-ii,jj-ij,jk-ik) & + & - ( pu(ji,jj,jk) - pu(ji-ii,jj-ij,jk-ik) ) * pt(ji,jj,jk) ) & + & * r1_e1e2t(ji,jj) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + END SUBROUTINE trd_tra_adv + + + SUBROUTINE trd_tra_mng( ptrdx, ptrdy, ktrd, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra_mng *** + !! + !! ** Purpose : Dispatch all tracer trends computation, e.g. 3D output, + !! integral constraints, potential energy, and/or + !! mixed layer budget. + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend + INTEGER , INTENT(in ) :: ktrd ! tracer trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + !!---------------------------------------------------------------------- + + ! ! 3D output of tracers trends using IOM interface + IF( ln_tra_trd ) CALL trd_tra_iom ( ptrdx, ptrdy, ktrd, kt, Kmm ) + + ! ! Integral Constraints Properties for tracers trends !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_glo_trd ) CALL trd_glo( ptrdx, ptrdy, ktrd, 'TRA', kt, Kmm ) + + ! ! Potential ENergy trends + IF( ln_PE_trd ) CALL trd_pen( ptrdx, ptrdy, ktrd, kt, rDt, Kmm ) + + ! ! Mixed layer trends for active tracers + IF( ln_tra_mxl ) THEN + !----------------------------------------------------------------------------------------------- + ! W.A.R.N.I.N.G : + ! jptra_ldf : called by traldf.F90 + ! at this stage we store: + ! - the lateral geopotential diffusion (here, lateral = horizontal) + ! - and the iso-neutral diffusion if activated + ! jptra_zdf : called by trazdf.F90 + ! * in case of iso-neutral diffusion we store the vertical diffusion component in the + ! lateral trend including the K_z contrib, which will be removed later (see trd_mxl) + !----------------------------------------------------------------------------------------------- + + SELECT CASE ( ktrd ) + CASE ( jptra_xad ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_xad, '3D' ) ! zonal advection + CASE ( jptra_yad ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_yad, '3D' ) ! merid. advection + CASE ( jptra_zad ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_zad, '3D' ) ! vertical advection + CASE ( jptra_ldf ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_ldf, '3D' ) ! lateral diffusion + CASE ( jptra_bbl ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_bbl, '3D' ) ! bottom boundary layer + CASE ( jptra_zdf ) + IF( ln_traldf_iso ) THEN ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_ldf, '3D' ) ! lateral diffusion (K_z) + ELSE ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_zdf, '3D' ) ! vertical diffusion (K_z) + ENDIF + CASE ( jptra_dmp ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_dmp, '3D' ) ! internal 3D restoring (tradmp) + CASE ( jptra_qsr ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_for, '3D' ) ! air-sea : penetrative sol radiat + CASE ( jptra_nsr ) ; ptrdx(:,:,2:jpk) = 0._wp ; ptrdy(:,:,2:jpk) = 0._wp + CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_for, '2D' ) ! air-sea : non penetr sol radiation + CASE ( jptra_bbc ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_bbc, '3D' ) ! bottom bound cond (geoth flux) + CASE ( jptra_npc ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_npc, '3D' ) ! non penetr convect adjustment + CASE ( jptra_atf ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_atf, '3D' ) ! asselin time filter (last trend) + ! + CALL trd_mxl( kt, rDt ) ! trends: Mixed-layer (output) + END SELECT + ! + ENDIF + ! + END SUBROUTINE trd_tra_mng + + + SUBROUTINE trd_tra_iom( ptrdx, ptrdy, ktrd, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra_iom *** + !! + !! ** Purpose : output 3D tracer trends using IOM + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend + INTEGER , INTENT(in ) :: ktrd ! tracer trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbu, ikbv ! local integers + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2dx, z2dy ! 2D workspace + !!---------------------------------------------------------------------- + ! +!!gm Rq: mask the trends already masked in trd_tra, but lbc_lnk should probably be added + ! + ! Trends evaluated every time step that could go to the standard T file and can be output every ts into a 1ts file if 1ts output is selected + SELECT CASE( ktrd ) + ! This total trend is done every time step + CASE( jptra_tot ) ; CALL iom_put( "ttrd_tot" , ptrdx ) ! model total trend + CALL iom_put( "strd_tot" , ptrdy ) + END SELECT + ! + ! These trends are done every second time step. When 1ts output is selected must go different (2ts) file from standard T-file + IF( MOD( kt, 2 ) == 0 ) THEN + SELECT CASE( ktrd ) + CASE( jptra_xad ) ; CALL iom_put( "ttrd_xad" , ptrdx ) ! x- horizontal advection + CALL iom_put( "strd_xad" , ptrdy ) + CASE( jptra_yad ) ; CALL iom_put( "ttrd_yad" , ptrdx ) ! y- horizontal advection + CALL iom_put( "strd_yad" , ptrdy ) + CASE( jptra_zad ) ; CALL iom_put( "ttrd_zad" , ptrdx ) ! z- vertical advection + CALL iom_put( "strd_zad" , ptrdy ) + IF( ln_linssh ) THEN ! cst volume : adv flux through z=0 surface + ALLOCATE( z2dx(jpi,jpj), z2dy(jpi,jpj) ) + z2dx(:,:) = ww(:,:,1) * ts(:,:,1,jp_tem,Kmm) / (e3t_0(:,:,1)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,1))) + z2dy(:,:) = ww(:,:,1) * ts(:,:,1,jp_sal,Kmm) / (e3t_0(:,:,1)*(1._wp+r3t(:,:,Kmm)*tmask(:,:,1))) + CALL iom_put( "ttrd_sad", z2dx ) + CALL iom_put( "strd_sad", z2dy ) + DEALLOCATE( z2dx, z2dy ) + ENDIF + CASE( jptra_totad ) ; CALL iom_put( "ttrd_totad", ptrdx ) ! total advection + CALL iom_put( "strd_totad", ptrdy ) + CASE( jptra_ldf ) ; CALL iom_put( "ttrd_ldf" , ptrdx ) ! lateral diffusion + CALL iom_put( "strd_ldf" , ptrdy ) + CASE( jptra_zdf ) ; CALL iom_put( "ttrd_zdf" , ptrdx ) ! vertical diffusion (including Kz contribution) + CALL iom_put( "strd_zdf" , ptrdy ) + CASE( jptra_zdfp ) ; CALL iom_put( "ttrd_zdfp" , ptrdx ) ! PURE vertical diffusion (no isoneutral contribution) + CALL iom_put( "strd_zdfp" , ptrdy ) + CASE( jptra_evd ) ; CALL iom_put( "ttrd_evd" , ptrdx ) ! EVD trend (convection) + CALL iom_put( "strd_evd" , ptrdy ) + CASE( jptra_dmp ) ; CALL iom_put( "ttrd_dmp" , ptrdx ) ! internal restoring (damping) + CALL iom_put( "strd_dmp" , ptrdy ) + CASE( jptra_bbl ) ; CALL iom_put( "ttrd_bbl" , ptrdx ) ! bottom boundary layer + CALL iom_put( "strd_bbl" , ptrdy ) + CASE( jptra_npc ) ; CALL iom_put( "ttrd_npc" , ptrdx ) ! static instability mixing + CALL iom_put( "strd_npc" , ptrdy ) + CASE( jptra_bbc ) ; CALL iom_put( "ttrd_bbc" , ptrdx ) ! geothermal heating (only on temperature) + CASE( jptra_nsr ) ; CALL iom_put( "ttrd_qns" , ptrdx(:,:,1) ) ! surface forcing + runoff (ln_rnf=T) + CALL iom_put( "strd_cdt" , ptrdy(:,:,1) ) ! output as 2D surface fields + CASE( jptra_qsr ) ; CALL iom_put( "ttrd_qsr" , ptrdx ) ! penetrative solar radiat. (only on temperature) + END SELECT + ! the Asselin filter trend is also every other time step but needs to be lagged one time step + ! Even when 1ts output is selected can go to the same (2ts) file as the trends plotted every even time step. + ELSE IF( MOD( kt, 2 ) == 1 ) THEN + SELECT CASE( ktrd ) + CASE( jptra_atf ) ; CALL iom_put( "ttrd_atf" , ptrdx ) ! asselin time Filter + CALL iom_put( "strd_atf" , ptrdy ) + END SELECT + END IF + ! + END SUBROUTINE trd_tra_iom + + !!====================================================================== +END MODULE trdtra diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdtrc.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdtrc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e8545dfc15d63405b15c4f051fd9298f926489bb --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdtrc.f90 @@ -0,0 +1,38 @@ + + + + + + + + + + + + + +MODULE trdtrc + USE par_kind + !!====================================================================== + !! *** MODULE trdtrc *** + !! Dummy module + !!====================================================================== + !!---------------------------------------------------------------------- + !! Dummy module NO TOP use + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_trc( ptrtrd, kjn, ktrd, kt, Kmm ) + INTEGER :: kt, kjn, ktrd + INTEGER :: Kmm ! time level index + REAL(dp), DIMENSION(:,:,:) :: ptrtrd + WRITE(*,*) 'trd_trc : You should not have seen this print! error?', ptrtrd(1,1,1) + WRITE(*,*) ' " " : You should not have seen this print! error?', kjn, ktrd, kt + END SUBROUTINE trd_trc + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdtrc.F90 13226 2020-07-02 14:24:31Z orioltp $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trdtrc diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdvor.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdvor.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9945ce9dd9f4a5ef111de86d80075a9259e0f421 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdvor.f90 @@ -0,0 +1,568 @@ + + + + + + + + + + + + + +MODULE trdvor + !!====================================================================== + !! *** MODULE trdvor *** + !! Ocean diagnostics: momentum trends + !!===================================================================== + !! History : 1.0 ! 2006-01 (L. Brunier, A-M. Treguier) Original code + !! 2.0 ! 2008-04 (C. Talandier) New trends organization + !! 3.5 ! 2012-02 (G. Madec) regroup beta.V computation with pvo trend + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_vor : momentum trends averaged over the depth + !! trd_vor_zint : vorticity vertical integration + !! trd_vor_init : initialization step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE trd_oce ! trends: ocean variables + USE zdf_oce ! ocean vertical physics + USE sbc_oce ! surface boundary condition: ocean + USE phycst ! Define parameters for the routines + USE ldfdyn ! ocean active tracers: lateral physics + USE dianam ! build the name of file (routine) + USE zdfmxl ! mixed layer depth + ! + USE in_out_manager ! I/O manager + USE ioipsl ! NetCDF library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + INTERFACE trd_vor_zint + MODULE PROCEDURE trd_vor_zint_2d, trd_vor_zint_3d + END INTERFACE + + PUBLIC trd_vor ! routine called by trddyn.F90 + PUBLIC trd_vor_init ! routine called by opa.F90 + PUBLIC trd_vor_alloc ! routine called by nemogcm.F90 + + INTEGER :: nh_t, nmoydpvor, nidvor, nhoridvor, ndimvor1, icount ! needs for IOIPSL output + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndexvor1 ! needed for IOIPSL output + INTEGER :: ndebug ! (0/1) set it to 1 in case of problem to have more print + + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avr ! average + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrb ! before vorticity (kt-1) + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbb ! vorticity at begining of the nn_write-1 timestep averaging period + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbn ! after vorticity at time step after the + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: rotot ! begining of the NN_WRITE-1 timesteps + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrtot ! + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrres ! + REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: vortrd ! curl of trends + + CHARACTER(len=12) :: cvort + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdvor.F90 15033 2021-06-21 10:24:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_vor_alloc() + !!---------------------------------------------------------------------------- + !! *** ROUTINE trd_vor_alloc *** + !!---------------------------------------------------------------------------- + ALLOCATE( vor_avr (jpi,jpj) , vor_avrb(jpi,jpj) , vor_avrbb (jpi,jpj) , & + & vor_avrbn (jpi,jpj) , rotot (jpi,jpj) , vor_avrtot(jpi,jpj) , & + & vor_avrres(jpi,jpj) , vortrd (jpi,jpj,jpltot_vor) , & + & ndexvor1 (jpi*jpj) , STAT= trd_vor_alloc ) + ! + CALL mpp_sum ( 'trdvor', trd_vor_alloc ) + IF( trd_vor_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_vor_alloc: failed to allocate arrays' ) + END FUNCTION trd_vor_alloc + + + SUBROUTINE trd_vor( putrd, pvtrd, ktrd, kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_vor *** + !! + !! ** Purpose : computation of cumulated trends over analysis period + !! and make outputs (NetCDF format) + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: ztswu, ztswv ! 2D workspace + !!---------------------------------------------------------------------- + + CALL lbc_lnk( 'trdvor', putrd, 'U', -1.0_dp , pvtrd, 'V', -1.0_dp ) ! lateral boundary condition + + SELECT CASE( ktrd ) + CASE( jpdyn_hpg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_prg, Kmm ) ! Hydrostatique Pressure Gradient + CASE( jpdyn_keg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_keg, Kmm ) ! KE Gradient + CASE( jpdyn_rvo ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_rvo, Kmm ) ! Relative Vorticity + CASE( jpdyn_pvo ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_pvo, Kmm ) ! Planetary Vorticity Term + CASE( jpdyn_ldf ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_ldf, Kmm ) ! Horizontal Diffusion + CASE( jpdyn_zad ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_zad, Kmm ) ! Vertical Advection + CASE( jpdyn_spg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_spg, Kmm ) ! Surface Pressure Grad. + CASE( jpdyn_zdf ) ! Vertical Diffusion + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! wind stress trends + ztswu(ji,jj) = 0.5 * ( utau_b(ji,jj) + utau(ji,jj) ) / ( (e3u_0(ji,jj,1)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,1))) * rho0 ) + ztswv(ji,jj) = 0.5 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / ( (e3v_0(ji,jj,1)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,1))) * rho0 ) + END DO ; END DO + CALL trd_vor_zint( putrd, pvtrd, jpvor_zdf, Kmm ) ! zdf trend including surf./bot. stresses + CALL trd_vor_zint( ztswu, ztswv, jpvor_swf, Kmm ) ! surface wind stress + CASE( jpdyn_bfr ) + CALL trd_vor_zint( putrd, pvtrd, jpvor_bfr, Kmm ) ! Bottom stress + ! + CASE( jpdyn_atf ) ! last trends: perform the output of 2D vorticity trends + CALL trd_vor_iom( kt, Kmm ) + END SELECT + ! + END SUBROUTINE trd_vor + + + SUBROUTINE trd_vor_zint_2d( putrdvor, pvtrdvor, ktrd, Kmm ) + !!---------------------------------------------------------------------------- + !! *** ROUTINE trd_vor_zint *** + !! + !! ** Purpose : computation of vertically integrated vorticity budgets + !! from ocean surface down to control surface (NetCDF output) + !! + !! ** Method/usage : integration done over nn_write-1 time steps + !! + !! ** Action : trends : + !! vortrd (,, 1) = Pressure Gradient Trend + !! vortrd (,, 2) = KE Gradient Trend + !! vortrd (,, 3) = Relative Vorticity Trend + !! vortrd (,, 4) = Coriolis Term Trend + !! vortrd (,, 5) = Horizontal Diffusion Trend + !! vortrd (,, 6) = Vertical Advection Trend + !! vortrd (,, 7) = Vertical Diffusion Trend + !! vortrd (,, 8) = Surface Pressure Grad. Trend + !! vortrd (,, 9) = Beta V + !! vortrd (,,10) = forcing term + !! vortrd (,,11) = bottom friction term + !! rotot(,) : total cumulative trends over nn_write-1 time steps + !! vor_avrtot(,) : first membre of vrticity equation + !! vor_avrres(,) : residual = dh/dt entrainment + !! + !! trends output in netCDF format using ioipsl + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ktrd ! ocean trend index + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: putrdvor ! u vorticity trend + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pvtrdvor ! v vorticity trend + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ikbu, ikbv ! local integers + REAL(wp), DIMENSION(jpi,jpj) :: zudpvor, zvdpvor ! total cmulative trends + !!---------------------------------------------------------------------- + + ! ===================================== + ! I vertical integration of 2D trends + ! ===================================== + + SELECT CASE( ktrd ) + ! + CASE( jpvor_bfr ) ! bottom friction + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ikbu = mbkv(ji,jj) + ikbv = mbkv(ji,jj) + zudpvor(ji,jj) = putrdvor(ji,jj) * (e3u_0(ji,jj,ikbu)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,ikbu))) * e1u(ji,jj) * umask(ji,jj,ikbu) + zvdpvor(ji,jj) = pvtrdvor(ji,jj) * (e3v_0(ji,jj,ikbv)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,ikbv))) * e2v(ji,jj) * vmask(ji,jj,ikbv) + END DO ; END DO + ! + CASE( jpvor_swf ) ! wind stress + zudpvor(:,:) = putrdvor(:,:) * (e3u_0(:,:,1)*(1._wp+r3u(:,:,Kmm)*umask(:,:,1))) * e1u(:,:) * umask(:,:,1) + zvdpvor(:,:) = pvtrdvor(:,:) * (e3v_0(:,:,1)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,1))) * e2v(:,:) * vmask(:,:,1) + ! + END SELECT + + ! Average except for Beta.V + zudpvor(:,:) = zudpvor(:,:) * (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm))) + zvdpvor(:,:) = zvdpvor(:,:) * (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm))) + + ! Curl + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + vortrd(ji,jj,ktrd) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) & + & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) & + & / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1) + END DO ; END DO + + IF( ndebug /= 0 ) THEN + IF(lwp) WRITE(numout,*) ' debuging trd_vor_zint: I done' + CALL FLUSH(numout) + ENDIF + ! + END SUBROUTINE trd_vor_zint_2d + + + SUBROUTINE trd_vor_zint_3d( putrdvor, pvtrdvor, ktrd , Kmm ) + !!---------------------------------------------------------------------------- + !! *** ROUTINE trd_vor_zint *** + !! + !! ** Purpose : computation of vertically integrated vorticity budgets + !! from ocean surface down to control surface (NetCDF output) + !! + !! ** Method/usage : integration done over nn_write-1 time steps + !! + !! ** Action : trends : + !! vortrd (,,1) = Pressure Gradient Trend + !! vortrd (,,2) = KE Gradient Trend + !! vortrd (,,3) = Relative Vorticity Trend + !! vortrd (,,4) = Coriolis Term Trend + !! vortrd (,,5) = Horizontal Diffusion Trend + !! vortrd (,,6) = Vertical Advection Trend + !! vortrd (,,7) = Vertical Diffusion Trend + !! vortrd (,,8) = Surface Pressure Grad. Trend + !! vortrd (,,9) = Beta V + !! vortrd (,,10) = forcing term + !! vortrd (,,11) = bottom friction term + !! rotot(,) : total cumulative trends over nn_write-1 time steps + !! vor_avrtot(,) : first membre of vrticity equation + !! vor_avrres(,) : residual = dh/dt entrainment + !! + !! trends output in netCDF format using ioipsl + !!---------------------------------------------------------------------- + ! + INTEGER , INTENT(in) :: ktrd ! ocean trend index + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: putrdvor ! u vorticity trend + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pvtrdvor ! v vorticity trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zudpvor, zvdpvor ! total cmulative trends + !!---------------------------------------------------------------------- + + ! ===================================== + ! I vertical integration of 3D trends + ! ===================================== + ! putrdvor and pvtrdvor terms + DO jk = 1,jpk + zudpvor(:,:) = zudpvor(:,:) + putrdvor(:,:,jk) * (e3u_0(:,:,jk)*(1._wp+r3u(:,:,Kmm)*umask(:,:,jk))) * e1u(:,:) * umask(:,:,jk) + zvdpvor(:,:) = zvdpvor(:,:) + pvtrdvor(:,:,jk) * (e3v_0(:,:,jk)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,jk))) * e2v(:,:) * vmask(:,:,jk) + END DO + + ! Planetary vorticity: 2nd computation (Beta.V term) store the vertical sum + ! as Beta.V term need intergration, not average + IF( ktrd == jpvor_pvo ) THEN + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + vortrd(ji,jj,jpvor_bev) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) & + & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) & + & / ( e1f(ji,jj) * e2f(ji,jj) ) * (r1_hu_0(ji,jj)/(1._wp+r3u(ji,jj,Kmm))) * fmask(ji,jj,1) + END DO ; END DO + ENDIF + ! + ! Average + zudpvor(:,:) = zudpvor(:,:) * (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm))) + zvdpvor(:,:) = zvdpvor(:,:) * (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm))) + ! + ! Curl + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + vortrd(ji,jj,ktrd) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) & + & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) & + & / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1) + END DO ; END DO + + IF( ndebug /= 0 ) THEN + IF(lwp) WRITE(numout,*) ' debuging trd_vor_zint: I done' + CALL FLUSH(numout) + ENDIF + ! + END SUBROUTINE trd_vor_zint_3d + + + SUBROUTINE trd_vor_iom( kt , Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_vor *** + !! + !! ** Purpose : computation of cumulated trends over analysis period + !! and make outputs (NetCDF format) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + INTEGER :: it, itmod ! local integers + REAL(wp) :: zmean ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zuu, zvv + !!---------------------------------------------------------------------- + + ! ================= + ! I. Initialization + ! ================= + + + ! I.1 set before values of vertically average u and v + ! --------------------------------------------------- + + IF( kt > nit000 ) vor_avrb(:,:) = vor_avr(:,:) + + ! I.2 vertically integrated vorticity + ! ---------------------------------- + + vor_avr (:,:) = 0._wp + zuu (:,:) = 0._wp + zvv (:,:) = 0._wp + vor_avrtot(:,:) = 0._wp + vor_avrres(:,:) = 0._wp + + ! Vertically averaged velocity + DO jk = 1, jpk - 1 + zuu(:,:) = zuu(:,:) + e1u(:,:) * uu(:,:,jk,Kmm) * (e3u_0(:,:,jk)*(1._wp+r3u(:,:,Kmm)*umask(:,:,jk))) + zvv(:,:) = zvv(:,:) + e2v(:,:) * vv(:,:,jk,Kmm) * (e3v_0(:,:,jk)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,jk))) + END DO + + zuu(:,:) = zuu(:,:) * (r1_hu_0(:,:)/(1._wp+r3u(:,:,Kmm))) + zvv(:,:) = zvv(:,:) * (r1_hv_0(:,:)/(1._wp+r3v(:,:,Kmm))) + + ! Curl + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + vor_avr(ji,jj) = ( ( zvv(ji+1,jj) - zvv(ji,jj) ) & + & - ( zuu(ji,jj+1) - zuu(ji,jj) ) ) & + & / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1) + END DO ; END DO + + ! ================================= + ! II. Cumulated trends + ! ================================= + + ! II.1 set `before' mixed layer values for kt = nit000+1 + ! ------------------------------------------------------ + IF( kt == nit000+1 ) THEN + vor_avrbb(:,:) = vor_avrb(:,:) + vor_avrbn(:,:) = vor_avr (:,:) + ENDIF + + ! II.2 cumulated trends over analysis period (kt=2 to nn_write) + ! ---------------------- + ! trends cumulated over nn_write-2 time steps + + IF( kt >= nit000+2 ) THEN + nmoydpvor = nmoydpvor + 1 + DO jl = 1, jpltot_vor + IF( jl /= 9 ) THEN + rotot(:,:) = rotot(:,:) + vortrd(:,:,jl) + ENDIF + END DO + ENDIF + + ! ============================================= + ! III. Output in netCDF + residual computation + ! ============================================= + + ! define time axis + it = kt + itmod = kt - nit000 + 1 + + IF( MOD( it, nn_trd ) == 0 ) THEN + + ! III.1 compute total trend + ! ------------------------ + zmean = 1._wp / ( REAL( nmoydpvor, wp ) * 2._wp * rn_Dt ) + vor_avrtot(:,:) = ( vor_avr(:,:) - vor_avrbn(:,:) + vor_avrb(:,:) - vor_avrbb(:,:) ) * zmean + + + ! III.2 compute residual + ! --------------------- + zmean = 1._wp / REAL( nmoydpvor, wp ) + vor_avrres(:,:) = vor_avrtot(:,:) - rotot(:,:) / zmean + + ! Boundary conditions + CALL lbc_lnk( 'trdvor', vor_avrtot, 'F', 1.0_wp , vor_avrres, 'F', 1.0_wp ) + + + ! III.3 time evolution array swap + ! ------------------------------ + vor_avrbb(:,:) = vor_avrb(:,:) + vor_avrbn(:,:) = vor_avr (:,:) + ! + nmoydpvor = 0 + ! + ENDIF + + ! III.4 write trends to output + ! --------------------------- + + IF( kt >= nit000+1 ) THEN + + IF( lwp .AND. MOD( itmod, nn_trd ) == 0 ) THEN + WRITE(numout,*) '' + WRITE(numout,*) 'trd_vor : write trends in the NetCDF file at kt = ', kt + WRITE(numout,*) '~~~~~~~ ' + ENDIF + + CALL histwrite( nidvor,"sovortPh",it,vortrd(:,:,jpvor_prg),ndimvor1,ndexvor1) ! grad Ph + CALL histwrite( nidvor,"sovortEk",it,vortrd(:,:,jpvor_keg),ndimvor1,ndexvor1) ! Energy + CALL histwrite( nidvor,"sovozeta",it,vortrd(:,:,jpvor_rvo),ndimvor1,ndexvor1) ! rel vorticity + CALL histwrite( nidvor,"sovortif",it,vortrd(:,:,jpvor_pvo),ndimvor1,ndexvor1) ! coriolis + CALL histwrite( nidvor,"sovodifl",it,vortrd(:,:,jpvor_ldf),ndimvor1,ndexvor1) ! lat diff + CALL histwrite( nidvor,"sovoadvv",it,vortrd(:,:,jpvor_zad),ndimvor1,ndexvor1) ! vert adv + CALL histwrite( nidvor,"sovodifv",it,vortrd(:,:,jpvor_zdf),ndimvor1,ndexvor1) ! vert diff + CALL histwrite( nidvor,"sovortPs",it,vortrd(:,:,jpvor_spg),ndimvor1,ndexvor1) ! grad Ps + CALL histwrite( nidvor,"sovortbv",it,vortrd(:,:,jpvor_bev),ndimvor1,ndexvor1) ! beta.V + CALL histwrite( nidvor,"sovowind",it,vortrd(:,:,jpvor_swf),ndimvor1,ndexvor1) ! wind stress + CALL histwrite( nidvor,"sovobfri",it,vortrd(:,:,jpvor_bfr),ndimvor1,ndexvor1) ! bottom friction + CALL histwrite( nidvor,"1st_mbre",it,REAL(vor_avrtot,dp) ,ndimvor1,ndexvor1) ! First membre + CALL histwrite( nidvor,"sovorgap",it,REAL(vor_avrres,dp) ,ndimvor1,ndexvor1) ! gap between 1st and 2 nd mbre + ! + IF( ndebug /= 0 ) THEN + WRITE(numout,*) ' debuging trd_vor: III.4 done' + CALL FLUSH(numout) + ENDIF + ! + ENDIF + ! + IF( MOD( it, nn_trd ) == 0 ) rotot(:,:)=0 + ! + IF( kt == nitend ) CALL histclo( nidvor ) + ! + END SUBROUTINE trd_vor_iom + + + SUBROUTINE trd_vor_init + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_vor_init *** + !! + !! ** Purpose : computation of vertically integrated T and S budgets + !! from ocean surface down to control surface (NetCDF output) + !!---------------------------------------------------------------------- + REAL(dp) :: zjulian, zsto, zout + CHARACTER (len=40) :: clhstnam + CHARACTER (len=40) :: clop + !!---------------------------------------------------------------------- + + ! =================== + ! I. initialization + ! =================== + + cvort='averaged-vor' + + ! Open specifier + ndebug = 0 ! set it to 1 in case of problem to have more Print + + IF(lwp) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) ' trd_vor_init: vorticity trends' + WRITE(numout,*) ' ~~~~~~~~~~~~' + WRITE(numout,*) ' ' + WRITE(numout,*) ' ##########################################################################' + WRITE(numout,*) ' CAUTION: The interpretation of the vorticity trends is' + WRITE(numout,*) ' not obvious, please contact Anne-Marie TREGUIER at: treguier@ifremer.fr ' + WRITE(numout,*) ' ##########################################################################' + WRITE(numout,*) ' ' + ENDIF + + IF( trd_vor_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_vor_init : unable to allocate trdvor arrays' ) + + + ! cumulated trends array init + nmoydpvor = 0 + rotot(:,:)=0 + vor_avrtot(:,:)=0 + vor_avrres(:,:)=0 + + IF( ndebug /= 0 ) THEN + WRITE(numout,*) ' debuging trd_vor_init: I. done' + CALL FLUSH(numout) + ENDIF + + ! ================================= + ! II. netCDF output initialization + ! ================================= + + !----------------------------------------- + ! II.1 Define frequency of output and means + ! ----------------------------------------- + IF( ln_mskland ) THEN ; clop = "only(x)" ! put 1.e+20 on land (very expensive!!) + ELSE ; clop = "x" ! no use of the mask value (require less cpu time) + ENDIF + zsto = rn_Dt + clop = "ave("//TRIM(clop)//")" + zout = nn_trd*rn_Dt + + IF(lwp) WRITE(numout,*) ' netCDF initialization' + + ! II.2 Compute julian date from starting date of the run + ! ------------------------ + CALL ymds2ju( nyear, nmonth, nday, REAL(rn_Dt,dp), 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 + + ! II.3 Define the T grid trend file (nidvor) + ! --------------------------------- + CALL dia_nam( clhstnam, nn_trd, 'vort' ) ! filename + IF(lwp) WRITE(numout,*) ' Name of NETCDF file ', clhstnam + CALL histbeg( clhstnam, jpi, REAL(glamf,dp), jpj, REAL(gphif,dp),1, jpi, & ! Horizontal grid : glamt and gphit + & 1, jpj, nit000-1, zjulian, REAL(rn_Dt,dp), nh_t, nidvor, domain_id=nidom, snc4chunks=snc4set ) + CALL wheneq( jpi*jpj, fmask, 1, 1., ndexvor1, ndimvor1 ) ! surface + + ! Declare output fields as netCDF variables + CALL histdef( nidvor, "sovortPh", cvort//"grad Ph" , "s-2", & ! grad Ph + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovortEk", cvort//"Energy", "s-2", & ! Energy + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovozeta", cvort//"rel vorticity", "s-2", & ! rel vorticity + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovortif", cvort//"coriolis", "s-2", & ! coriolis + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovodifl", cvort//"lat diff ", "s-2", & ! lat diff + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovoadvv", cvort//"vert adv", "s-2", & ! vert adv + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovodifv", cvort//"vert diff" , "s-2", & ! vert diff + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovortPs", cvort//"grad Ps", "s-2", & ! grad Ps + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovortbv", cvort//"Beta V", "s-2", & ! beta.V + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovowind", cvort//"wind stress", "s-2", & ! wind stress + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovobfri", cvort//"bottom friction", "s-2", & ! bottom friction + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "1st_mbre", cvort//"1st mbre", "s-2", & ! First membre + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovorgap", cvort//"gap", "s-2", & ! gap between 1st and 2 nd mbre + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histend( nidvor, snc4set ) + + IF( ndebug /= 0 ) THEN + WRITE(numout,*) ' debuging trd_vor_init: II. done' + CALL FLUSH(numout) + ENDIF + ! + END SUBROUTINE trd_vor_init + + !!====================================================================== +END MODULE trdvor diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdvor_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdvor_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fb258f99108f3898daff096ff69a259b119051dc --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/trdvor_oce.f90 @@ -0,0 +1,47 @@ + + + + + + + + + + + + + +MODULE trdvor_oce + !!====================================================================== + !! *** MODULE trdvor_oce *** + !! Ocean trends : set vorticity trend variables + !!====================================================================== + !! History : 1.0 ! 04-2006 (L. Brunier, A-M. Treguier) Original code + !!---------------------------------------------------------------------- + + USE par_oce ! ocean parameters + + IMPLICIT NONE + PRIVATE + + ! !!* vorticity trends index + INTEGER, PUBLIC, PARAMETER :: jpltot_vor = 11 !: Number of vorticity trend terms + ! + INTEGER, PUBLIC, PARAMETER :: jpvor_prg = 1 !: Pressure Gradient Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_keg = 2 !: KE Gradient Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_rvo = 3 !: Relative Vorticity Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_pvo = 4 !: Planetary Vorticity Term Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_ldf = 5 !: Horizontal Diffusion Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_zad = 6 !: Vertical Advection Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_zdf = 7 !: Vertical Diffusion Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_spg = 8 !: Surface Pressure Grad. Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_bev = 9 !: Beta V + INTEGER, PUBLIC, PARAMETER :: jpvor_swf = 10 !: wind stress forcing term + INTEGER, PUBLIC, PARAMETER :: jpvor_bfr = 11 !: bottom friction term + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdvor_oce.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trdvor_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_fmask.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_fmask.f90 new file mode 100644 index 0000000000000000000000000000000000000000..68be778d02eb15b5765330d75d23a6e8a9db81dd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_fmask.f90 @@ -0,0 +1,173 @@ + + + + + + + + + + + + + +MODULE usrdef_fmask + !!====================================================================== + !! *** MODULE usrdef_fmask *** + !! + !! === ORCA configuration === + !! (2 and 1 degrees) + !! + !! User defined : alteration of land/sea f-point mask in some straits + !!====================================================================== + !! History : 4.0 ! 2016-06 (G. Madec, S. Flavoni) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_fmask : alteration of f-point land/ocean mask in some straits + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! Massively Parallel Processing library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_fmask ! routine called by dommsk.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_fmask.F90 13435 2020-08-25 14:48:42Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_fmask( cd_cfg, kcfg, pfmsk ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_msk *** + !! + !! ** Purpose : User defined alteration of the lateral boundary + !! condition on velocity. + !! + !! ** Method : Local change of the value of fmask at lateral ocean/land + !! boundary in straits in order to increase the viscous + !! boundary layer and thus reduce the transport through the + !! corresponding straits. + !! Here only alterations in ORCA R2 and R1 cases + !! + !! ** Action : fmask : land/ocean mask at f-point with increased value + !! in some user defined straits + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cd_cfg ! configuration name + INTEGER , INTENT(in ) :: kcfg ! configuration identifier + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pfmsk ! Ocean/Land f-point mask including lateral boundary cond. + ! + INTEGER :: iif, iil, ii0, ii1, ii ! local integers + INTEGER :: ijf, ijl, ij0, ij1 ! - - + INTEGER :: isrow ! index for ORCA1 starting row + !!---------------------------------------------------------------------- + ! + IF( TRIM( cd_cfg ) == "orca" .OR. TRIM( cd_cfg ) == "ORCA" ) THEN !== ORCA Configurations ==! + ! + SELECT CASE ( kcfg ) + ! + CASE( 2 ) ! R2 case + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_fmask : ORCA_R2: increase lateral friction near the following straits:' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' + ! + IF(lwp) WRITE(numout,*) ' Gibraltar ' + ij0 = 101 + nn_hls ; ij1 = 101 + nn_hls ! Gibraltar strait : partial slip (pfmsk=0.5) + ii0 = 139 + nn_hls - 1 ; ii1 = 140 + nn_hls - 1 + pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp + ij0 = 102 + nn_hls ; ij1 = 102 + nn_hls + ii0 = 139 + nn_hls - 1 ; ii1 = 140 + nn_hls - 1 + pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp + ! + IF(lwp) WRITE(numout,*) ' Bab el Mandeb ' + ij0 = 87 + nn_hls ; ij1 = 88 + nn_hls ! Bab el Mandeb : partial slip (pfmsk=1) + ii0 = 160 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 + pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp + ij0 = 88 + nn_hls ; ij1 = 88 + nn_hls + ii0 = 159 + nn_hls - 1 ; ii1 = 159 + nn_hls - 1 + pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp + ! + ! We keep this as an example but it is instable in this case + !IF(lwp) WRITE(numout,*) ' Danish straits ' + ! ij0 = 115 ; ij1 = 115 ! Danish straits : strong slip (pfmsk > 2) + ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp + ! ij0 = 116 ; ij1 = 116 + ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp + ! + CASE( 1 ) ! R1 case + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_fmask : ORCA_R1: increase lateral friction near the following straits:' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' +!!gm ! This dirty section will be suppressed by simplification process: +!!gm ! all this will come back in input files +!!gm ! Currently these hard-wired indices relate to configuration with extend grid (jpjglo=332) + ! + isrow = 332 - (Nj0glo + 1) ! was 332 - jpjglo -> jpjglo_old_version = Nj0glo + 1 + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' orca_r1: increase friction near the following straits : ' + IF(lwp) WRITE(numout,*) ' Gibraltar ' + ii0 = 282 + nn_hls - 1 ; ii1 = 283 + nn_hls - 1 ! Gibraltar Strait + ij0 = 241 + nn_hls - isrow ; ij1 = 241 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Bhosporus ' + ii0 = 314 + nn_hls - 1 ; ii1 = 315 + nn_hls - 1 ! Bhosporus Strait + ij0 = 248 + nn_hls - isrow ; ij1 = 248 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Makassar (Top) ' + ii0 = 48 + nn_hls - 1 ; ii1 = 48 + nn_hls - 1 ! Makassar Strait (Top) + ij0 = 189 + nn_hls - isrow ; ij1 = 190 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp + ! + IF(lwp) WRITE(numout,*) ' Lombok ' + ii0 = 44 + nn_hls - 1 ; ii1 = 44 + nn_hls - 1 ! Lombok Strait + ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Ombai ' + ii0 = 53 + nn_hls - 1 ; ii1 = 53 + nn_hls - 1 ! Ombai Strait + ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Timor Passage ' + ii0 = 56 + nn_hls - 1 ; ii1 = 56 + nn_hls - 1 ! Timor Passage + ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' West Halmahera ' + ii0 = 58 + nn_hls - 1 ; ii1 = 58 + nn_hls - 1 ! West Halmahera Strait + ij0 = 181 + nn_hls - isrow ; ij1 = 182 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp + ! + IF(lwp) WRITE(numout,*) ' East Halmahera ' + ii0 = 55 + nn_hls - 1 ; ii1 = 55 + nn_hls - 1 ! East Halmahera Strait + ij0 = 181 + nn_hls - isrow ; ij1 = 182 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp + ! + CASE DEFAULT + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_fmask : ORCA_R', kcfg,' : NO alteration of fmask in specific straits ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' + END SELECT + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_fmask : NO alteration of fmask in specific straits ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! + CALL lbc_lnk( 'usrdef_fmask', pfmsk, 'F', 1._wp ) ! Lateral boundary conditions on fmask + ! + END SUBROUTINE usr_def_fmask + + !!====================================================================== +END MODULE usrdef_fmask diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_hgr.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_hgr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4ff144c51b1ff17c02254bb44abfdf659092998d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_hgr.f90 @@ -0,0 +1,179 @@ + + + + + + + + + + + + + +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === GYRE configuration === + !! + !! User defined : mesh and Coriolis parameter of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_hgr : initialize the horizontal mesh + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + USE usrdef_nam ! + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_hgr ! called in domhgr.F90 + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_hgr.F90 14223 2020-12-19 10:22:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_hgr( plamt , plamu , plamv , plamf , & ! geographic position (required) + & pphit , pphiu , pphiv , pphif , & ! + & kff , pff_f , pff_t , & ! Coriolis parameter (if domain not on the sphere) + & pe1t , pe1u , pe1v , pe1f , & ! scale factors (required) + & pe2t , pe2u , pe2v , pe2f , & ! + & ke1e2u_v , pe1e2u , pe1e2v ) ! u- & v-surfaces (if gridsize reduction is used in strait(s)) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_hgr *** + !! + !! ** Purpose : user defined mesh and Coriolis parameter + !! + !! ** Method : set all intent(out) argument to a proper value + !! + !! Here GYRE configuration : + !! Rectangular mid-latitude domain + !! - with axes rotated by 45 degrees + !! - a constant horizontal resolution of 106 km + !! - on a beta-plane + !! + !! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in degrees) + !! - define coriolis parameter at f-point if the domain in not on the sphere (on beta-plane) + !! - define i- & j-scale factors at t-, u-, v- and f-points (in meters) + !! - define u- & v-surfaces (if gridsize reduction is used in some straits) (in m2) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(out) :: plamt, plamu, plamv, plamf ! longitude outputs [degrees] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pphit, pphiu, pphiv, pphif ! latitude outputs [degrees] + INTEGER , INTENT(out) :: kff ! =1 Coriolis parameter computed here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point [1/s] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1v! i-scale factors [m] + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1f! i-scale factors [m] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2u! j-scale factors [m] + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2v, pe2f! j-scale factors [m] + INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces computed here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zlam1, zlam0, zcos_alpha, zim1 , zjm1 , ze1 , ze1deg, zf0 ! local scalars + REAL(wp) :: zphi1, zphi0, zsin_alpha, zim05, zjm05, zbeta, znorme ! - - + !!------------------------------------------------------------------------------- + ! + ! !== beta-plane with regular grid-spacing and rotated domain ==! (GYRE configuration) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : GYRE configuration (beta-plane with rotated regular grid-spacing)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! !== grid point position ==! + ! + zlam1 = -85._wp ! position of gridpoint (i,j) = (1,jpjglo) + zphi1 = 29._wp + ! + ze1 = 106000._wp / REAL( nn_GYRE , wp ) ! gridspacing in meters + ! + zsin_alpha = - SQRT( 2._wp ) * 0.5_wp ! angle: 45 degrees + zcos_alpha = SQRT( 2._wp ) * 0.5_wp + ze1deg = ze1 / (ra * rad) + zlam0 = zlam1 + zcos_alpha * ze1deg * REAL( Ni0glo - 2, wp ) + zphi0 = zphi1 + zsin_alpha * ze1deg * REAL( Nj0glo - 2, wp ) + + ! + IF( ln_bench ) THEN ! benchmark: forced the resolution to be 106 km + ze1 = 106000._wp ! but keep (lat,lon) at the right nn_GYRE resolution + CALL ctl_warn( ' GYRE used as Benchmark: e1=e2=106km, no need to adjust rn_Dt, ahm,aht ' ) + ENDIF + IF( lwp ) THEN + WRITE(numout,*) 'ze1', ze1, 'cosalpha', zcos_alpha, 'sinalpha', zsin_alpha + WRITE(numout,*) 'ze1deg', ze1deg, 'zlam0', zlam0, 'zphi0', zphi0 + ENDIF + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zim1 = REAL( mig0(ji), wp ) - 1. ; zim05 = REAL( mig0(ji), wp ) - 1.5 + zjm1 = REAL( mjg0(jj), wp ) - 1. ; zjm05 = REAL( mjg0(jj), wp ) - 1.5 + ! + !glamt(i,j) longitude at T-point + !gphit(i,j) latitude at T-point + plamt(ji,jj) = zlam0 + zim05 * ze1deg * zcos_alpha + zjm05 * ze1deg * zsin_alpha + pphit(ji,jj) = zphi0 - zim05 * ze1deg * zsin_alpha + zjm05 * ze1deg * zcos_alpha + ! + !glamu(i,j) longitude at U-point + !gphiu(i,j) latitude at U-point + plamu(ji,jj) = zlam0 + zim1 * ze1deg * zcos_alpha + zjm05 * ze1deg * zsin_alpha + pphiu(ji,jj) = zphi0 - zim1 * ze1deg * zsin_alpha + zjm05 * ze1deg * zcos_alpha + ! + !glamv(i,j) longitude at V-point + !gphiv(i,j) latitude at V-point + plamv(ji,jj) = zlam0 + zim05 * ze1deg * zcos_alpha + zjm1 * ze1deg * zsin_alpha + pphiv(ji,jj) = zphi0 - zim05 * ze1deg * zsin_alpha + zjm1 * ze1deg * zcos_alpha + ! + !glamf(i,j) longitude at F-point + !gphif(i,j) latitude at F-point + plamf(ji,jj) = zlam0 + zim1 * ze1deg * zcos_alpha + zjm1 * ze1deg * zsin_alpha + pphif(ji,jj) = zphi0 - zim1 * ze1deg * zsin_alpha + zjm1 * ze1deg * zcos_alpha + END DO ; END DO + ! + ! !== Horizontal scale factors ==! (in meters) + ! + ! ! constant grid spacing + pe1t(:,:) = ze1 ; pe2t(:,:) = ze1 + pe1u(:,:) = ze1 ; pe2u(:,:) = ze1 + pe1v(:,:) = ze1 ; pe2v(:,:) = ze1 + pe1f(:,:) = ze1 ; pe2f(:,:) = ze1 + ! + ! ! NO reduction of grid size in some straits + ke1e2u_v = 0 ! ==>> u_ & v_surfaces will be computed in dom_ghr routine + pe1e2u(:,:) = 0._wp ! CAUTION: set to zero to avoid error with some compilers that + pe1e2v(:,:) = 0._wp ! require an initialization of INTENT(out) arguments + ! + ! + ! !== Coriolis parameter ==! + kff = 1 ! indicate not to compute ff afterward + ! + zbeta = 2. * omega * COS( rad * zphi1 ) / ra ! beta at latitude zphi1 + !SF we overwrite zphi0 (south point in latitude) used just above to define pphif (value of zphi0=15.5190567531966) + !SF for computation of Coriolis we keep the parameter of Hazeleger, W., and S. S. Drijfhout, JPO 1998. + zphi0 = 15._wp ! latitude of the most southern grid point + zf0 = 2. * omega * SIN( rad * zphi0 ) ! compute f0 1st point south + ! + pff_f(:,:) = ( zf0 + zbeta * ABS( pphif(:,:) - zphi0 ) * rad * ra ) ! f = f0 +beta* y ( y=0 at south) + pff_t(:,:) = ( zf0 + zbeta * ABS( pphit(:,:) - zphi0 ) * rad * ra ) ! f = f0 +beta* y ( y=0 at south) + ! + IF(lwp) WRITE(numout,*) ' beta-plane used. beta = ', zbeta, ' 1/(s.m)' + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_istate.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_istate.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7f7448a0a3dfdae9fade2fea560b1d3e9353dc40 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_istate.f90 @@ -0,0 +1,121 @@ + + + + + + + + + + + + + +MODULE usrdef_istate + !!====================================================================== + !! *** MODULE usrdef_istate *** + !! + !! === GYRE configuration === + !! + !! User defined : set the initial state of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni) Original code + !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_istate : initial state in Temperature and salinity + !!---------------------------------------------------------------------- + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_istate ! called in istate.F90 + PUBLIC usr_def_istate_ssh ! called by domqco.F90 + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_istate.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate *** + !! + !! ** Purpose : Initialization of the dynamics and tracers + !! Here GYRE configuration example : (double gyre with rotated domain) + !! + !! ** Method : - set temprature field + !! - set salinity field + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] + REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] + REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : analytical definition of initial state ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with an horizontally uniform T and S profiles' + ! + pu (:,:,:) = 0._wp ! ocean at rest + pv (:,:,:) = 0._wp + ! + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! horizontally uniform T & S profiles + pts(ji,jj,jk,jp_tem) = ( ( 16. - 12. * TANH( (pdept(ji,jj,jk) - 400) / 700 ) ) & + & * (-TANH( (500. - pdept(ji,jj,jk)) / 150. ) + 1.) / 2. & + & + ( 15. * ( 1. - TANH( (pdept(ji,jj,jk)-50.) / 1500.) ) & + & - 1.4 * TANH((pdept(ji,jj,jk)-100.) / 100.) & + & + 7. * (1500. - pdept(ji,jj,jk) ) / 1500.) & + & * (-TANH( (pdept(ji,jj,jk) - 500.) / 150.) + 1.) / 2. ) * ptmask(ji,jj,jk) + + pts(ji,jj,jk,jp_sal) = ( ( 36.25 - 1.13 * TANH( (pdept(ji,jj,jk) - 305) / 460 ) ) & + & * (-TANH((500. - pdept(ji,jj,jk)) / 150.) + 1.) / 2 & + & + ( 35.55 + 1.25 * (5000. - pdept(ji,jj,jk)) / 5000. & + & - 1.62 * TANH( (pdept(ji,jj,jk) - 60. ) / 650. ) & + & + 0.2 * TANH( (pdept(ji,jj,jk) - 35. ) / 100. ) & + & + 0.2 * TANH( (pdept(ji,jj,jk) - 1000.) / 5000.) ) & + & * (-TANH( (pdept(ji,jj,jk) - 500.) / 150.) + 1.) / 2 ) * ptmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + END SUBROUTINE usr_def_istate + + + SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate_ssh *** + !! + !! ** Purpose : Initialization of ssh + !! + !! ** Method : Set ssh as null, ptmask is required for test cases + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(dp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : GYRE configuration, analytical definition of initial state' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~~ Ocean at rest, ssh is zero' + ! + ! Sea level: + pssh(:,:) = 0._wp + ! + END SUBROUTINE usr_def_istate_ssh + + !!====================================================================== +END MODULE usrdef_istate diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_nam.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_nam.f90 new file mode 100644 index 0000000000000000000000000000000000000000..469e30674c9d0255b4ebf7413c1918e996170e4c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_nam.f90 @@ -0,0 +1,108 @@ + + + + + + + + + + + + + +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === GYRE configuration === + !! + !! User defined : set the domain characteristics of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_nam : read user defined namelist and set global domain size + !! usr_def_hgr : initialize the horizontal mesh + !!---------------------------------------------------------------------- + USE dom_oce + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called in nemogcm.F90 module + + ! !!* namusr_def namelist *!! + LOGICAL, PUBLIC :: ln_bench ! =T benchmark test with gyre: the gridsize is constant (no need to adjust timestep or viscosity) + INTEGER, PUBLIC :: nn_GYRE ! 1/nn_GYRE = the resolution chosen in degrees and thus defining the horizontal domain size + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_nam.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_nam *** + !! + !! ** Purpose : read user defined namelist and define the domain size + !! + !! ** Method : read in namusr_def containing all the user specific namelist parameter + !! + !! Here GYRE configuration + !! + !! ** input : - namusr_def namelist found in namelist_cfg + !!---------------------------------------------------------------------- + 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 + ! + INTEGER :: ios ! Local integer + !! + NAMELIST/namusr_def/ nn_GYRE, ln_bench, jpkglo + !!---------------------------------------------------------------------- + ! + READ ( numnam_cfg, namusr_def, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namusr_def in configuration namelist' ) + ! + IF(lwm) WRITE( numond, namusr_def ) + ! + cd_cfg = 'GYRE' ! name & resolution (not used) + kk_cfg = nn_GYRE + ! + kpi = 30 * nn_GYRE + 2 ! + kpj = 20 * nn_GYRE + 2 + kpk = jpkglo + ! ! Set the lateral boundary condition of the global domain + ldIperio = .FALSE. ; ldJperio = .FALSE. ! GYRE configuration : closed domain + ldNFold = .FALSE. ; cdNFtype = '-' + ! + ! ! control print + IF(lwp) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) 'usr_def_nam : read the user defined namelist (namusr_def) in namelist_cfg' + WRITE(numout,*) '~~~~~~~~~~~ ' + WRITE(numout,*) ' Namelist namusr_def : GYRE case' + WRITE(numout,*) ' GYRE used as Benchmark (=T) ln_bench = ', ln_bench + WRITE(numout,*) ' inverse resolution & implied domain size nn_GYRE = ', nn_GYRE + WRITE(numout,*) ' Ni0glo = 30*nn_GYRE Ni0glo = ', kpi + WRITE(numout,*) ' Nj0glo = 20*nn_GYRE Nj0glo = ', kpj + WRITE(numout,*) ' number of model levels jpkglo = ', kpk + WRITE(numout,*) ' ' + ENDIF + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_sbc.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_sbc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6e50e89e94498690b2bf2cedf122cb50b97fec64 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_sbc.f90 @@ -0,0 +1,252 @@ + + + + + + + + + + + + + +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === GYRE configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usrdef_sbc : user defined surface bounday conditions in GYRE case + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_fortran ! + + IMPLICIT NONE + PRIVATE + + PUBLIC usrdef_sbc_oce ! routine called in sbcmod module + PUBLIC usrdef_sbc_ice_tau ! routine called by icestp.F90 for ice dynamics + PUBLIC usrdef_sbc_ice_flx ! routine called by icestp.F90 for ice thermo + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_sbc.F90 15145 2021-07-26 16:16:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usrdef_sbc_oce( kt, Kbb ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc *** + !! + !! ** Purpose : provide at each time-step the GYRE surface boundary + !! condition, i.e. the momentum, heat and freshwater fluxes. + !! + !! ** Method : analytical seasonal cycle for GYRE configuration. + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !! Reference : Hazeleger, W., and S. Drijfhout, JPO, 30, 677-695, 2000. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kbb ! ocean time index + !! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: zyear0 ! initial year + INTEGER :: zmonth0 ! initial month + INTEGER :: zday0 ! initial day + INTEGER :: zday_year0 ! initial day since january 1st + REAL(wp) :: ztau , ztau_sais ! wind intensity and of the seasonal cycle + REAL(wp) :: ztime ! time in hour + REAL(wp) :: ztimemax , ztimemin ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztimemax1, ztimemin1 ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztimemax2, ztimemin2 ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztaun ! intensity + REAL(wp) :: zemp_S, zemp_N, zemp_sais, zTstar + REAL(wp) :: zcos_sais1, zcos_sais2, ztrp, zconv, t_star + REAL(wp) :: zsumemp, zsurf + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: ztx, zty, zmod, zcoef ! temporary variables + REAL(wp) :: zyydd ! number of days in one year + !!--------------------------------------------------------------------- + zyydd = REAL(nyear_len(1),wp) + + ! ---------------------------- ! + ! heat and freshwater fluxes ! + ! ---------------------------- ! + !same temperature, E-P as in HAZELEGER 2000 + + zyear0 = ndate0 / 10000 ! initial year + zmonth0 = ( ndate0 - zyear0 * 10000 ) / 100 ! initial month + zday0 = ndate0 - zyear0 * 10000 - zmonth0 * 100 ! initial day betwen 1 and 30 + zday_year0 = ( zmonth0 - 1 ) * 30.+zday0 ! initial day betwen 1 and 360 + + ! current day (in hours) since january the 1st of the current year + ztime = REAL( kt ) * rn_Dt / (rmmss * rhhmm) & ! total incrementation (in hours) + & - (nyear - 1) * rjjhh * zyydd ! minus years since beginning of experiment (in hours) + + ztimemax1 = ((5.*30.)+21.)* 24. ! 21th june at 24h in hours + ztimemin1 = ztimemax1 + rjjhh * zyydd / 2 ! 21th december in hours + ztimemax2 = ((6.*30.)+21.)* 24. ! 21th july at 24h in hours + ztimemin2 = ztimemax2 - rjjhh * zyydd / 2 ! 21th january in hours + ! ! NB: rjjhh * zyydd / 4 = one seasonal cycle in hours + + ! amplitudes + zemp_S = 0.7 ! intensity of COS in the South + zemp_N = 0.8 ! intensity of COS in the North + zemp_sais = 0.1 + zTstar = 28.3 ! intemsity from 28.3 a -5 deg + + ! 1/2 period between 21th June and 21th December and between 21th July and 21th January + zcos_sais1 = COS( (ztime - ztimemax1) / (ztimemin1 - ztimemax1) * rpi ) + zcos_sais2 = COS( (ztime - ztimemax2) / (ztimemax2 - ztimemin2) * rpi ) + + ztrp= - 40.e0 ! retroaction term on heat fluxes (W/m2/K) + zconv = 3.16e-5 ! convertion factor: 1 m/yr => 3.16e-5 mm/s + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! emp and rnf used in sshwzv over the whole domain + ! domain from 15 deg to 50 deg between 27 and 28 degC at 15N, -3 + ! and 13 degC at 50N 53.5 + or - 11 = 1/4 period : + ! 64.5 in summer, 42.5 in winter + t_star = zTstar * ( 1. + 1. / 50. * zcos_sais2 ) & + & * COS( rpi * (gphit(ji,jj) - 5.) & + & / ( 53.5 * ( 1 + 11 / 53.5 * zcos_sais2 ) * 2.) ) + ! 23.5 deg : tropics + qsr (ji,jj) = 230 * COS( 3.1415 * ( gphit(ji,jj) - 23.5 * zcos_sais1 ) / ( 0.9 * 180 ) ) + qns (ji,jj) = ztrp * ( ts(ji,jj,1,jp_tem,Kbb) - t_star ) - qsr(ji,jj) + IF( gphit(ji,jj) >= 14.845 .AND. 37.2 >= gphit(ji,jj) ) THEN ! zero at 37.8 deg, max at 24.6 deg + emp (ji,jj) = zemp_S * zconv & + & * SIN( rpi / 2 * (gphit(ji,jj) - 37.2) / (24.6 - 37.2) ) & + & * ( 1 - zemp_sais / zemp_S * zcos_sais1) + ELSE + emp (ji,jj) = - zemp_N * zconv & + & * SIN( rpi / 2 * (gphit(ji,jj) - 37.2) / (46.8 - 37.2) ) & + & * ( 1 - zemp_sais / zemp_N * zcos_sais1 ) + ENDIF + END DO ; END DO + + zsumemp = GLOB_SUM( 'usrdef_sbc', REAL(emp (:,:),dp) ) + zsurf = GLOB_SUM( 'usrdef_sbc', REAL(tmask(:,:,1),dp) ) + zsumemp = zsumemp / zsurf ! Default GYRE configuration + + ! freshwater (mass flux) and update of qns with heat content of emp + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! emp used in sshwzv over the whole domain + emp (ji,jj) = emp(ji,jj) - zsumemp * tmask(ji,jj,1) ! freshwater flux (=0 in domain average) + sfx (ji,jj) = 0.0_wp ! no salt flux + qns (ji,jj) = qns(ji,jj) - emp(ji,jj) * sst_m(ji,jj) * rcp ! evap and precip are at SST + END DO ; END DO + + + ! ---------------------------- ! + ! momentum fluxes ! + ! ---------------------------- ! + ! same wind as in Wico + !test date0 : ndate0 = 010203 + zyear0 = ndate0 / 10000 + zmonth0 = ( ndate0 - zyear0 * 10000 ) / 100 + zday0 = ndate0 - zyear0 * 10000 - zmonth0 * 100 + !Calculates nday_year, day since january 1st + zday_year0 = (zmonth0-1)*30.+zday0 + + !accumulates days of previous months of this year + ! day (in hours) since january the 1st + ztime = FLOAT( kt ) * rn_Dt / (rmmss * rhhmm) & ! incrementation in hour + & - (nyear - 1) * rjjhh * zyydd ! - nber of hours the precedent years + ztimemax = ((5.*30.)+21.)* 24. ! 21th june in hours + ztimemin = ztimemax + rjjhh * zyydd / 2 ! 21th december in hours + ! ! NB: rjjhh * zyydd / 4 = 1 seasonal cycle in hours + + ! mean intensity at 0.105 ; srqt(2) because projected with 45deg angle + ztau = 0.105 / SQRT( 2. ) + ! seasonal oscillation intensity + ztau_sais = 0.015 + ztaun = ztau - ztau_sais * COS( (ztime - ztimemax) / (ztimemin - ztimemax) * rpi ) + DO jj = ntsj-( 1), ntej+( 1 ) ; DO ji = ntsi-( 1), ntei+( 1) + ! domain from 15deg to 50deg and 1/2 period along 14deg + ! so 5/4 of half period with seasonal cycle + utau(ji,jj) = - ztaun * SIN( rpi * (gphiu(ji,jj) - 15.) / (29.-15.) ) + vtau(ji,jj) = ztaun * SIN( rpi * (gphiv(ji,jj) - 15.) / (29.-15.) ) + END DO ; END DO + + ! module of wind stress and wind speed at T-point + zcoef = 1. / ( zrhoa * zcdrag ) + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ztx = utau(ji-1,jj ) + utau(ji,jj) + zty = vtau(ji ,jj-1) + vtau(ji,jj) + zmod = 0.5 * SQRT( ztx * ztx + zty * zty ) + taum(ji,jj) = zmod + wndm(ji,jj) = SQRT( zmod * zcoef ) + END DO ; END DO + + ! ---------------------------------- ! + ! control print at first time-step ! + ! ---------------------------------- ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'usrdef_sbc_oce : analytical surface fluxes for GYRE configuration' + WRITE(numout,*)'~~~~~~~~~~~ ' + WRITE(numout,*)' nyear = ', nyear + WRITE(numout,*)' nmonth = ', nmonth + WRITE(numout,*)' nday = ', nday + WRITE(numout,*)' nday_year = ', nday_year + WRITE(numout,*)' ztime = ', ztime + WRITE(numout,*)' ztimemax = ', ztimemax + WRITE(numout,*)' ztimemin = ', ztimemin + WRITE(numout,*)' ztimemax1 = ', ztimemax1 + WRITE(numout,*)' ztimemin1 = ', ztimemin1 + WRITE(numout,*)' ztimemax2 = ', ztimemax2 + WRITE(numout,*)' ztimemin2 = ', ztimemin2 + WRITE(numout,*)' zyear0 = ', zyear0 + WRITE(numout,*)' zmonth0 = ', zmonth0 + WRITE(numout,*)' zday0 = ', zday0 + WRITE(numout,*)' zday_year0 = ', zday_year0 + WRITE(numout,*)' zyydd = ', zyydd + WRITE(numout,*)' zemp_S = ', zemp_S + WRITE(numout,*)' zemp_N = ', zemp_N + WRITE(numout,*)' zemp_sais = ', zemp_sais + WRITE(numout,*)' zTstar = ', zTstar + WRITE(numout,*)' zsumemp = ', zsumemp + WRITE(numout,*)' zsurf = ', zsurf + WRITE(numout,*)' ztrp = ', ztrp + WRITE(numout,*)' zconv = ', zconv + WRITE(numout,*)' ndastp = ', ndastp + WRITE(numout,*)' adatrj = ', adatrj + ENDIF + ! + END SUBROUTINE usrdef_sbc_oce + + + SUBROUTINE usrdef_sbc_ice_tau( kt ) + INTEGER, INTENT(in) :: kt ! ocean time step + END SUBROUTINE usrdef_sbc_ice_tau + + + SUBROUTINE usrdef_sbc_ice_flx( kt, phs, phi ) + INTEGER, INTENT(in) :: kt ! ocean time step + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness + END SUBROUTINE usrdef_sbc_ice_flx + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_zgr.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_zgr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..10743eae72787c0c555243e71f995e8377f7de5f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/usrdef_zgr.f90 @@ -0,0 +1,259 @@ + + + + + + + + + + + + + +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === GYRE configuration === + !! + !! User defined : vertical coordinate system of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-06 (G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_zgr : user defined vertical coordinate system + !! zgr_z : reference 1D z-coordinate + !! zgr_top_bot: ocean top and bottom level indices + !! zgr_zco : 3D verticl coordinate in pure z-coordinate case + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! ocean domain + USE depth_e3 ! depth <=> e3 + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_zgr ! called by domzgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_zgr.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_zgr( 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 usr_def_zgr *** + !! + !! ** Purpose : User defined the vertical coordinates + !! + !!---------------------------------------------------------------------- + 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 grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [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 ! i-scale factors + INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level + ! + 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) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr : GYRE configuration (z-coordinate closed flat box ocean without cavities)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! type of vertical coordinate + ! --------------------------- + ld_zco = .TRUE. ! GYRE case: z-coordinate without ocean cavities + ld_zps = .FALSE. + ld_sco = .FALSE. + ld_isfcav = .FALSE. + ! + ! + ! Build the vertical coordinate system + ! ------------------------------------ + CALL zgr_z( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system + ! + CALL zgr_msk_top_bot( k_top , k_bot ) ! masked top and bottom ocean t-level indices + ! + ! ! z-coordinate (3D arrays) from the 1D z-coord. + CALL zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate + & pdept , pdepw , & ! out : 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw ) ! - - - + ! + END SUBROUTINE usr_def_zgr + + + SUBROUTINE zgr_z( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! 1D reference vertical coordinate + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_z *** + !! + !! ** Purpose : set the 1D depth of model levels and the resulting + !! vertical scale factors. + !! + !! ** Method : 1D z-coordinate system (use in all type of coordinate) + !! The depth of model levels is set from dep(k), an analytical function: + !! w-level: depw_1d = dep(k) + !! t-level: dept_1d = dep(k+0.5) + !! The scale factors are the discrete derivative of the depth: + !! e3w_1d(jk) = dk[ dept_1d ] + !! e3t_1d(jk) = dk[ depw_1d ] + !! with at top and bottom : + !! e3w_1d( 1 ) = 2 * ( dept_1d( 1 ) - depw_1d( 1 ) ) + !! e3t_1d(jpk) = 2 * ( dept_1d(jpk) - depw_1d(jpk) ) + !! The depth are then re-computed from the sum of e3. This ensures + !! that depths are identical when reading domain configuration file. + !! Indeed, only e3. are saved in this file, depth are compute by a call + !! to the e3_to_depth subroutine. + !! + !! Here the Madec & Imbard (1996) function is used. + !! + !! ** Action : - pdept_1d, pdepw_1d : depth of T- and W-point (m) + !! - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) + !! + !! Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766. + !! Madec and Imbard, 1996, Clim. Dyn. + !!---------------------------------------------------------------------- + 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] + ! + INTEGER :: jk ! dummy loop indices + REAL(wp) :: zt, zw ! local scalars + REAL(wp) :: zsur, za0, za1, zkth, zacr ! Values for the Madec & Imbard (1996) function + !!---------------------------------------------------------------------- + ! + ! Set parameters of z(k) function + ! ------------------------------- + zsur = -2033.194295283385_wp + za0 = 155.8325369664153_wp + za1 = 146.3615918601890_wp + zkth = 17.28520372419791_wp + zacr = 5.0_wp + ! + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) ' zgr_z : Reference vertical z-coordinates ' + WRITE(numout,*) ' ~~~~~~~' + WRITE(numout,*) ' GYRE case : MI96 function with the following coefficients :' + WRITE(numout,*) ' zsur = ', zsur + WRITE(numout,*) ' za0 = ', za0 + WRITE(numout,*) ' za1 = ', za1 + WRITE(numout,*) ' zkth = ', zkth + WRITE(numout,*) ' zacr = ', zacr + ENDIF + + ! + ! 1D Reference z-coordinate (using Madec & Imbard 1996 function) + ! ------------------------- + ! + DO jk = 1, jpk ! depth at T and W-points + zw = REAL( jk , wp ) + zt = REAL( jk , wp ) + 0.5_wp + pdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG( COSH( (zw-zkth) / zacr ) ) ) + pdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG( COSH( (zt-zkth) / zacr ) ) ) + END DO + ! + ! ! e3t and e3w from depth + CALL depth_to_e3( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d ) + ! + ! ! recompute depths from SUM(e3) <== needed + CALL e3_to_depth( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) + ! + IF(lwp) THEN ! control print + 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 + ! + END SUBROUTINE zgr_z + + + SUBROUTINE zgr_msk_top_bot( k_top , k_bot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_msk_top_bot *** + !! + !! ** Purpose : set the masked top and bottom ocean t-levels + !! + !! ** Method : GYRE case = closed flat box ocean without ocean cavities + !! k_top = 1 except along north, south, east and west boundaries + !! k_bot = jpk-1 except along north, south, east and west boundaries + !! + !! ** Action : - k_top : first wet ocean level index + !! - k_bot : last wet ocean level index + !!---------------------------------------------------------------------- + INTEGER , DIMENSION(:,:), INTENT(out) :: k_top , k_bot ! first & last wet ocean level + ! + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D local workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' zgr_top_bot : defines the top and bottom wet ocean levels.' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) ' GYRE case : closed flat box ocean without ocean cavities' + ! + z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom + ! + k_bot(:,:) = NINT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere + ! + k_top(:,:) = MIN( 1 , k_bot(:,:) ) ! = 1 over the ocean point, =0 elsewhere + ! + END SUBROUTINE zgr_msk_top_bot + + + SUBROUTINE zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate + & pdept , pdepw , & ! out: 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw ) ! - - - + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_zco *** + !! + !! ** Purpose : define the reference z-coordinate system + !! + !! ** Method : set 3D coord. arrays to reference 1D array + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:) , INTENT(in ) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(in ) :: 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) :: 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 :: jk + !!---------------------------------------------------------------------- + ! + DO jk = 1, jpk + pdept(:,:,jk) = pdept_1d(jk) + pdepw(:,:,jk) = pdepw_1d(jk) + pe3t (:,:,jk) = pe3t_1d (jk) + pe3u (:,:,jk) = pe3t_1d (jk) + pe3v (:,:,jk) = pe3t_1d (jk) + pe3f (:,:,jk) = pe3t_1d (jk) + pe3w (:,:,jk) = pe3w_1d (jk) + pe3uw(:,:,jk) = pe3w_1d (jk) + pe3vw(:,:,jk) = pe3w_1d (jk) + END DO + ! + END SUBROUTINE zgr_zco + + !!====================================================================== +END MODULE usrdef_zgr diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/wet_dry.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/wet_dry.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fcbd12579af0a806eaca628d6c1287fd4dba9d2d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/wet_dry.f90 @@ -0,0 +1,424 @@ + + + + + + + + + + + + + +MODULE wet_dry + + !! includes updates to namelist namwad for diagnostic outputs of ROMS wetting and drying + + !!============================================================================== + !! *** MODULE wet_dry *** + !! Wetting and drying includes initialisation routine and routines to + !! compute and apply flux limiters and preserve water depth positivity + !! only effects if wetting/drying is on (ln_wd_il == .true. or ln_wd_dl==.true. ) + !!============================================================================== + !! History : 3.6 ! 2014-09 ((H.Liu) Original code + !! ! will add the runoff and periodic BC case later + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! wad_init : initialisation of wetting and drying + !! wad_lmt : horizontal flux limiter and limited velocity when wetting and drying happens + !! wad_lmt_bt : same as wad_lmt for the barotropic stepping (dynspg_ts) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce , ONLY: ln_rnf ! surface boundary condition: ocean + USE sbcrnf ! river runoff + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + USE timing ! timing of the main modules + + IMPLICIT NONE + PRIVATE + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! critical depths,filters, limiters,and masks for Wetting and Drying + !! --------------------------------------------------------------------- + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdmask !: u- and v- limiter + ! ! (can include negative depths) + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdramp, wdrampu, wdrampv !: for hpg limiting + + LOGICAL, PUBLIC :: ln_wd_il !: Wetting/drying il activation switch (T:on,F:off) + LOGICAL, PUBLIC :: ln_wd_dl !: Wetting/drying dl activation switch (T:on,F:off) + REAL(wp), PUBLIC :: rn_wdmin0 !: depth at which wetting/drying starts + REAL(wp), PUBLIC :: rn_wdmin1 !: minimum water depth on dried cells + REAL(wp), PUBLIC :: r_rn_wdmin1 !: 1/minimum water depth on dried cells + REAL(wp), PUBLIC :: rn_wdmin2 !: tolerance of minimum water depth on dried cells + REAL(wp), PUBLIC :: rn_wd_sbcdep !: Depth at which to taper sbc fluxes + REAL(wp), PUBLIC :: rn_wd_sbcfra !: Fraction of SBC at taper depth + REAL(wp), PUBLIC :: rn_wdld !: land elevation below which wetting/drying will be considered + INTEGER , PUBLIC :: nn_wdit !: maximum number of iteration for W/D limiter + LOGICAL, PUBLIC :: ln_wd_dl_bc !: DL scheme: True implies 3D velocities are set to the barotropic values at points + !: where the flow is from wet points on less than half the barotropic sub-steps + LOGICAL, PUBLIC :: ln_wd_dl_rmp !: use a ramp for the dl flux limiter between 2 rn_wdmin1 and rn_wdmin1 (rather than a cut-off at rn_wdmin1) + REAL(wp), PUBLIC :: ssh_ref !: height of z=0 with respect to the geoid; + + LOGICAL, PUBLIC :: ll_wd = .FALSE. !: Wetting/drying activation switch (ln_wd_il or ln_wd_dl) <- default def if wad_init not called + + PUBLIC wad_init ! initialisation routine called by step.F90 + PUBLIC wad_lmt ! routine called by sshwzv.F90 + PUBLIC wad_lmt_bt ! routine called by dynspg_ts.F90 + + !! * Substitutions + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE wad_init + !!---------------------------------------------------------------------- + !! *** ROUTINE wad_init *** + !! + !! ** Purpose : read wetting and drying namelist and print the variables. + !! + !! ** input : - namwad namelist + !!---------------------------------------------------------------------- + INTEGER :: ios, ierr ! Local integer + !! + NAMELIST/namwad/ ln_wd_il, ln_wd_dl , rn_wdmin0, rn_wdmin1, rn_wdmin2, rn_wdld, & + & nn_wdit , ln_wd_dl_bc, ln_wd_dl_rmp, rn_wd_sbcdep,rn_wd_sbcfra + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namwad, IOSTAT = ios, ERR = 905) +905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namwad in reference namelist' ) + READ ( numnam_cfg, namwad, IOSTAT = ios, ERR = 906) +906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namwad in configuration namelist' ) + IF(lwm) WRITE ( numond, namwad ) + ! + IF( rn_wd_sbcfra>=1 ) CALL ctl_stop( 'STOP', 'rn_wd_sbcfra >=1 : must be < 1' ) + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'wad_init : Wetting and drying initialization through namelist read' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist namwad' + WRITE(numout,*) ' Logical for Iter Lim wd option ln_wd_il = ', ln_wd_il + WRITE(numout,*) ' Logical for Dir. Lim wd option ln_wd_dl = ', ln_wd_dl + WRITE(numout,*) ' Depth at which wet/drying starts rn_wdmin0 = ', rn_wdmin0 + WRITE(numout,*) ' Minimum wet depth on dried cells rn_wdmin1 = ', rn_wdmin1 + WRITE(numout,*) ' Tolerance of min wet depth rn_wdmin2 = ', rn_wdmin2 + WRITE(numout,*) ' land elevation threshold rn_wdld = ', rn_wdld + WRITE(numout,*) ' Max iteration for W/D limiter nn_wdit = ', nn_wdit + WRITE(numout,*) ' T => baroclinic u,v=0 at dry pts: ln_wd_dl_bc = ', ln_wd_dl_bc + WRITE(numout,*) ' use a ramp for rwd limiter: ln_wd_dl_rwd_rmp = ', ln_wd_dl_rmp + WRITE(numout,*) ' cut off depth sbc for wd rn_wd_sbcdep = ', rn_wd_sbcdep + WRITE(numout,*) ' fraction to start sbc wgt rn_wd_sbcfra = ', rn_wd_sbcfra + ENDIF + IF( .NOT. ln_read_cfg ) THEN + IF(lwp) WRITE(numout,*) ' No configuration file so seting ssh_ref to zero ' + ssh_ref=0._wp + ENDIF + + r_rn_wdmin1 = 1 / rn_wdmin1 + IF( ln_wd_il .OR. ln_wd_dl ) THEN + ll_wd = .TRUE. + ALLOCATE( wdmask(jpi,jpj), STAT=ierr ) + ALLOCATE( wdramp(jpi,jpj), wdrampu(jpi,jpj), wdrampv(jpi,jpj), STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop('STOP', 'wad_init : Array allocation error') + ENDIF + + IF( ln_tile .AND. ln_wd_il ) CALL ctl_warn('Tiling has not been tested with ln_wd_il = T') + ! + END SUBROUTINE wad_init + + + SUBROUTINE wad_lmt( psshb1, psshemp, z2dt, Kmm, puu, pvv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wad_lmt *** + !! + !! ** Purpose : generate flux limiters for wetting/drying + !! + !! ** Method : - Prevent negative depth occurring (Not ready for Agrif) + !! + !! ** Action : - calculate flux limiter and W/D flag + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: psshb1 + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: psshemp + REAL(wp) , INTENT(in ) :: z2dt + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocity arrays + ! + INTEGER :: ji, jj, jk, jk1 ! dummy loop indices + INTEGER :: jflag ! local scalar + REAL(wp) :: zcoef, zdep1, zdep2 ! local scalars + REAL(wp) :: zzflxp, zzflxn ! local scalars + REAL(wp) :: zdepwd ! local scalar, always wet cell depth + REAL(wp) :: ztmp ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv ! W/D flux limiters + REAL(wp), DIMENSION(jpi,jpj) :: zflxp , zflxn ! local 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zflxu , zflxv ! local 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zflxu1 , zflxv1 ! local 2D workspace + !!---------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('wad_lmt') ! + ! + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = puu(:,:,jk,Kmm) * zwdlmtu(:,:) + pvv(:,:,jk,Kmm) = pvv(:,:,jk,Kmm) * zwdlmtv(:,:) + END DO + jflag = 0 + zdepwd = 50._wp ! maximum depth on which that W/D could possibly happen + ! + zflxp(:,:) = 0._wp + zflxn(:,:) = 0._wp + zflxu(:,:) = 0._wp + zflxv(:,:) = 0._wp + ! + zwdlmtu(:,:) = 1._wp + zwdlmtv(:,:) = 1._wp + ! + DO jk = 1, jpkm1 ! Horizontal Flux in u and v direction + zflxu(:,:) = zflxu(:,:) + (e3u_0(:,:,jk)*(1._wp+r3u(:,:,Kmm)*umask(:,:,jk))) * puu(:,:,jk,Kmm) * umask(:,:,jk) + zflxv(:,:) = zflxv(:,:) + (e3v_0(:,:,jk)*(1._wp+r3v(:,:,Kmm)*vmask(:,:,jk))) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) + END DO + zflxu(:,:) = zflxu(:,:) * e2u(:,:) + zflxv(:,:) = zflxv(:,:) * e1v(:,:) + ! + wdmask(:,:) = 1._wp + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + ! + IF( tmask(ji,jj,1) < 0.5_wp ) CYCLE ! we don't care about land cells + IF( ht_0(ji,jj) - ssh_ref > zdepwd ) CYCLE ! and cells which are unlikely to dry + ! + zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj ) , 0._wp ) & + & + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji, jj-1) , 0._wp ) + zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj ) , 0._wp ) & + & + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji, jj-1) , 0._wp ) + ! + zdep2 = ht_0(ji,jj) + psshb1(ji,jj) - rn_wdmin1 + IF( zdep2 <= 0._wp ) THEN ! add more safty, but not necessary + psshb1(ji,jj) = rn_wdmin1 - ht_0(ji,jj) + IF(zflxu(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = 0._wp + IF(zflxu(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = 0._wp + IF(zflxv(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = 0._wp + IF(zflxv(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = 0._wp + wdmask(ji,jj) = 0._wp + END IF + END DO ; END DO + ! + ! ! HPG limiter from jholt + wdramp(:,:) = min((ht_0(:,:) + psshb1(:,:) - rn_wdmin1)/(rn_wdmin0 - rn_wdmin1),1.0_wp) + !jth assume don't need a lbc_lnk here + DO jj = ntsj-( 1), ntej+( 0 ) ; DO ji = ntsi-( 1), ntei+( 0) + wdrampu(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji+1,jj) ) + wdrampv(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji,jj+1) ) + END DO ; END DO + ! ! end HPG limiter + ! + ! + DO jk1 = 1, nn_wdit + 1 !== start limiter iterations ==! + ! + zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) + zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) + jflag = 0 ! flag indicating if any further iterations are needed + ! + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + IF( tmask(ji, jj, 1) < 0.5_wp ) CYCLE + IF( ht_0(ji,jj) > zdepwd ) CYCLE + ! + ztmp = e1e2t(ji,jj) + ! + zzflxp = MAX( zflxu1(ji,jj) , 0._wp ) - MIN( zflxu1(ji-1,jj ) , 0._wp) & + & + MAX( zflxv1(ji,jj) , 0._wp ) - MIN( zflxv1(ji, jj-1) , 0._wp) + zzflxn = MIN( zflxu1(ji,jj) , 0._wp ) - MAX( zflxu1(ji-1,jj ) , 0._wp) & + & + MIN( zflxv1(ji,jj) , 0._wp ) - MAX( zflxv1(ji, jj-1) , 0._wp) + ! + zdep1 = (zzflxp + zzflxn) * z2dt / ztmp + zdep2 = ht_0(ji,jj) + psshb1(ji,jj) - rn_wdmin1 - z2dt * psshemp(ji,jj) + ! + IF( zdep1 > zdep2 ) THEN + wdmask(ji, jj) = 0._wp + zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) + !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) + ! flag if the limiter has been used but stop flagging if the only + ! changes have zeroed the coefficient since further iterations will + ! not change anything + IF( zcoef > 0._wp ) THEN ; jflag = 1 + ELSE ; zcoef = 0._wp + ENDIF + IF( jk1 > nn_wdit ) zcoef = 0._wp + IF( zflxu1(ji ,jj ) > 0._wp ) zwdlmtu(ji ,jj ) = zcoef + IF( zflxu1(ji-1,jj ) < 0._wp ) zwdlmtu(ji-1,jj ) = zcoef + IF( zflxv1(ji ,jj ) > 0._wp ) zwdlmtv(ji ,jj ) = zcoef + IF( zflxv1(ji ,jj-1) < 0._wp ) zwdlmtv(ji ,jj-1) = zcoef + ENDIF + END DO ; END DO + CALL lbc_lnk( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) + ! + CALL mpp_max('wet_dry', jflag) !max over the global domain + ! + IF( jflag == 0 ) EXIT + ! + END DO ! jk1 loop + ! + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = puu(:,:,jk,Kmm) * zwdlmtu(:,:) + pvv(:,:,jk,Kmm) = pvv(:,:,jk,Kmm) * zwdlmtv(:,:) + END DO + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * zwdlmtu(:, :) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * zwdlmtv(:, :) + ! +!!gm TO BE SUPPRESSED ? these lbc_lnk are useless since zwdlmtu and zwdlmtv are defined everywhere ! + CALL lbc_lnk( 'wet_dry', puu(:,:,:,Kmm) , 'U', -1.0_dp, pvv(:,:,:,Kmm) , 'V', -1.0_dp ) + CALL lbc_lnk( 'wet_dry', uu_b(:,:,Kmm), 'U', -1.0_wp, vv_b(:,:,Kmm), 'V', -1.0_wp ) +!!gm + ! + IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt!!!' + ! + !IF( ln_rnf ) CALL sbc_rnf_div( hdiv ) ! runoffs (update hdiv field) + ! + IF( ln_timing ) CALL timing_stop('wad_lmt') ! + ! + END SUBROUTINE wad_lmt + + + SUBROUTINE wad_lmt_bt( zflxu, zflxv, sshn_e, zssh_frc, rDt_e ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wad_lmt *** + !! + !! ** Purpose : limiting flux in the barotropic stepping (dynspg_ts) + !! + !! ** Method : - Prevent negative depth occurring (Not ready for Agrif) + !! + !! ** Action : - calculate flux limiter and W/D flag + !!---------------------------------------------------------------------- + REAL(dp) , INTENT(in ) :: rDt_e ! ocean time-step index + REAL(wp), DIMENSION(:,:), INTENT(inout) :: zflxv + REAL(dp), DIMENSION(:,:), INTENT(inout) :: zflxu, sshn_e, zssh_frc + ! + INTEGER :: ji, jj, jk, jk1 ! dummy loop indices + INTEGER :: jflag ! local integer + REAL(wp) :: z2dt + REAL(wp) :: zcoef, zdep1, zdep2 ! local scalars + REAL(wp) :: zzflxp, zzflxn ! local scalars + REAL(wp) :: zdepwd ! local scalar, always wet cell depth + REAL(wp) :: ztmp ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv !: W/D flux limiters + REAL(wp), DIMENSION(jpi,jpj) :: zflxp, zflxn ! local 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zflxu1, zflxv1 ! local 2D workspace + !!---------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('wad_lmt_bt') ! + ! + jflag = 0 + zdepwd = 50._wp ! maximum depth that ocean cells can have W/D processes + ! + z2dt = rDt_e + ! + zflxp(:,:) = 0._wp + zflxn(:,:) = 0._wp + zwdlmtu(:,:) = 1._wp + zwdlmtv(:,:) = 1._wp + ! + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) ! Horizontal Flux in u and v direction + ! + IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE ! we don't care about land cells + IF( ht_0(ji,jj) > zdepwd ) CYCLE ! and cells which are unlikely to dry + ! + zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj ) , 0._wp ) & + & + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji, jj-1) , 0._wp ) + zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj ) , 0._wp ) & + & + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji, jj-1) , 0._wp ) + ! + zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 + IF( zdep2 <= 0._wp ) THEN !add more safety, but not necessary + sshn_e(ji,jj) = rn_wdmin1 - ht_0(ji,jj) + IF( zflxu(ji ,jj ) > 0._wp) zwdlmtu(ji ,jj ) = 0._wp + IF( zflxu(ji-1,jj ) < 0._wp) zwdlmtu(ji-1,jj ) = 0._wp + IF( zflxv(ji ,jj ) > 0._wp) zwdlmtv(ji ,jj ) = 0._wp + IF( zflxv(ji ,jj-1) < 0._wp) zwdlmtv(ji ,jj-1) = 0._wp + ENDIF + END DO ; END DO + ! + DO jk1 = 1, nn_wdit + 1 !! start limiter iterations + ! + zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) + zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) + jflag = 0 ! flag indicating if any further iterations are needed + ! + DO jj = ntsj-( 0), ntej+( 1 ) ; DO ji = ntsi-( 0), ntei+( 1) + ! + IF( tmask(ji, jj, 1 ) < 0.5_wp ) CYCLE + IF( ht_0(ji,jj) > zdepwd ) CYCLE + ! + ztmp = e1e2t(ji,jj) + ! + zzflxp = max(zflxu1(ji,jj), 0._wp) - min(zflxu1(ji-1,jj), 0._wp) & + & + max(zflxv1(ji,jj), 0._wp) - min(zflxv1(ji, jj-1), 0._wp) + zzflxn = min(zflxu1(ji,jj), 0._wp) - max(zflxu1(ji-1,jj), 0._wp) & + & + min(zflxv1(ji,jj), 0._wp) - max(zflxv1(ji, jj-1), 0._wp) + + zdep1 = (zzflxp + zzflxn) * z2dt / ztmp + zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 - z2dt * zssh_frc(ji,jj) + + IF(zdep1 > zdep2) THEN + zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) + !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) + ! flag if the limiter has been used but stop flagging if the only + ! changes have zeroed the coefficient since further iterations will + ! not change anything + IF( zcoef > 0._wp ) THEN + jflag = 1 + ELSE + zcoef = 0._wp + ENDIF + IF(jk1 > nn_wdit) zcoef = 0._wp + IF(zflxu1(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = zcoef + IF(zflxu1(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = zcoef + IF(zflxv1(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = zcoef + IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = zcoef + END IF + END DO ; END DO + ! + CALL lbc_lnk( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) + ! + CALL mpp_max('wet_dry', jflag) !max over the global domain + ! + IF(jflag == 0) EXIT + ! + END DO ! jk1 loop + ! + zflxu(:,:) = zflxu(:,:) * zwdlmtu(:, :) + zflxv(:,:) = zflxv(:,:) * zwdlmtv(:, :) + ! +!!gm THIS lbc_lnk is useless since it is already done at the end of the jk1-loop + CALL lbc_lnk( 'wet_dry', zflxu, 'U', -1.0_dp) + CALL lbc_lnk( 'wet_dry', zflxv, 'V', -1.0_wp) +!!gm end + ! + IF( jflag == 1 .AND. lwp ) WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!' + ! + !IF( ln_rnf ) CALL sbc_rnf_div( hdiv ) ! runoffs (update hdiv field) + ! + IF( ln_timing ) CALL timing_stop('wad_lmt_bt') ! + ! + END SUBROUTINE wad_lmt_bt + + !!============================================================================== +END MODULE wet_dry diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdf_oce.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdf_oce.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1c27c6e6b1ed9e5e23dca7861241a032ff9260d0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdf_oce.f90 @@ -0,0 +1,90 @@ + + + + + + + + + + + + + +MODULE zdf_oce + !!====================================================================== + !! *** MODULE zdf_oce *** + !! Ocean physics : define vertical mixing variables + !!===================================================================== + !! history : 1.0 ! 2002-06 (G. Madec) Original code + !! 3.2 ! 2009-07 (G. Madec) addition of avm + !! 4.0 ! 2017-05 (G. Madec) avm and drag coef. defined at t-point + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_oce_alloc ! Called in nemogcm.F90 + + ! !!* namelist namzdf: vertical physics * + ! ! Adaptive-implicit vertical advection flag + LOGICAL , PUBLIC :: ln_zad_Aimp !: adaptive (Courant number-based) implicit vertical advection + ! ! vertical closure scheme flags + LOGICAL , PUBLIC :: ln_zdfcst !: constant coefficients + LOGICAL , PUBLIC :: ln_zdfric !: Richardson depend coefficients + LOGICAL , PUBLIC :: ln_zdftke !: Turbulent Kinetic Energy closure + LOGICAL , PUBLIC :: ln_zdfgls !: Generic Length Scale closure + LOGICAL , PUBLIC :: ln_zdfosm !: OSMOSIS BL closure + ! ! convection + LOGICAL , PUBLIC :: ln_zdfevd !: convection: enhanced vertical diffusion flag + INTEGER , PUBLIC :: nn_evdm !: =0/1 flag to apply enhanced avm or not + REAL(wp), PUBLIC :: rn_evd !: vertical eddy coeff. for enhanced vert. diff. (m2/s) + LOGICAL , PUBLIC :: ln_zdfnpc !: convection: non-penetrative convection flag + INTEGER , PUBLIC :: nn_npc !: non penetrative convective scheme call frequency + INTEGER , PUBLIC :: nn_npcp !: non penetrative convective scheme print frequency + ! ! double diffusion + LOGICAL , PUBLIC :: ln_zdfddm !: double diffusive mixing flag + REAL(wp), PUBLIC :: rn_avts !: maximum value of avs for salt fingering + REAL(wp), PUBLIC :: rn_hsbfr !: heat/salt buoyancy flux ratio + ! ! gravity wave-induced vertical mixing + LOGICAL , PUBLIC :: ln_zdfswm !: surface wave-induced mixing flag + LOGICAL , PUBLIC :: ln_zdfiwm !: internal wave-induced mixing flag + LOGICAL , PUBLIC :: ln_zdfmfc !: convection: eddy diffusivity Mass Flux Convection + ! ! coefficients + REAL(wp), PUBLIC :: rn_avm0 !: vertical eddy viscosity (m2/s) + REAL(wp), PUBLIC :: rn_avt0 !: vertical eddy diffusivity (m2/s) + INTEGER , PUBLIC :: nn_avb !: constant or profile background on avt (=0/1) + INTEGER , PUBLIC :: nn_havtb !: horizontal shape or not for avtb (=0/1) ! ! convection + + + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm, avt, avs !: vertical mixing coefficients (w-point) [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm_k , avt_k !: Kz computed by turbulent closure alone [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: en !: now turbulent kinetic energy [m2/s2] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: avmb , avtb !: background profile of avm and avt [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: avtb_2d !: horizontal shape of background Kz profile [-] + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdf_oce.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_oce_alloc *** + !!---------------------------------------------------------------------- + ! + ALLOCATE( avm (jpi,jpj,jpk) , avm_k(jpi,jpj,jpk) , avs(jpi,jpj,jpk) , & + & avt (jpi,jpj,jpk) , avt_k(jpi,jpj,jpk) , en (jpi,jpj,jpk) , & + & avmb(jpk) , avtb(jpk) , avtb_2d(jpi,jpj) , STAT = zdf_oce_alloc ) + ! + IF( zdf_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_oce_alloc: failed to allocate arrays' ) + ! + END FUNCTION zdf_oce_alloc + + !!====================================================================== +END MODULE zdf_oce diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfddm.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfddm.f90 new file mode 100644 index 0000000000000000000000000000000000000000..84a55e74425a678fa7217b0f8339a0addd5823cf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfddm.f90 @@ -0,0 +1,195 @@ + + + + + + + + + + + + + +MODULE zdfddm + !!====================================================================== + !! *** MODULE zdfddm *** + !! Ocean physics : double diffusion mixing parameterization + !!====================================================================== + !! History : OPA ! 2000-08 (G. Madec) double diffusive mixing + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.6 ! 2013-04 (G. Madec, F. Roquet) zrau compute locally using interpolation of alpha & beta + !! 4.0 ! 2017-04 (G. Madec) remove CPP ddm key & avm at t-point only + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_ddm : compute the Kz for salinity + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE zdf_oce ! ocean vertical physics variables + USE eosbn2 ! equation of state + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_ddm ! called by step.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfddm.F90 14853 2021-05-12 13:07:30Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_ddm( kt, Kmm, p_avm, p_avt, p_avs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_ddm *** + !! + !! ** Purpose : Add to the vertical eddy diffusivity coefficient the + !! effect of salt fingering and diffusive convection. + !! + !! ** Method : Diapycnal mixing is increased in case of double + !! diffusive mixing (i.e. salt fingering and diffusive layering) + !! following Merryfield et al. (1999). The rate of double diffusive + !! mixing depend on the buoyancy ratio (R=alpha/beta dk[T]/dk[S]): + !! * salt fingering (Schmitt 1981): + !! for R > 1 and rn2 > 0 : zavfs = rn_avts / ( 1 + (R/rn_hsbfr)^6 ) + !! for R > 1 and rn2 > 0 : zavfs = O + !! otherwise : zavft = 0.7 zavs / R + !! * diffusive layering (Federov 1988): + !! for 0< R < 1 and N^2 > 0 : zavdt = 1.3635e-6 * exp( 4.6 exp(-0.54 (1/R-1) ) ) + !! otherwise : zavdt = 0 + !! for .5 < R < 1 and N^2 > 0 : zavds = zavdt (1.885 R -0.85) + !! for 0 < R <.5 and N^2 > 0 : zavds = zavdt 0.15 R + !! otherwise : zavds = 0 + !! * update the eddy diffusivity: + !! avt = avt + zavft + zavdt + !! avs = avs + zavfs + zavds + !! avm is required to remain at least above avt and avs. + !! + !! ** Action : avt, avs : updated vertical eddy diffusivity coef. for T & S + !! + !! References : Merryfield et al., JPO, 29, 1124-1142, 1999. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm ! Kz on momentum (w-points) + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avt ! Kz on temperature (w-points) + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_avs ! Kz on salinity (w-points) + ! + INTEGER :: ji, jj , jk ! dummy loop indices + REAL(wp) :: zaw, zbw, zrw ! local scalars + REAL(wp) :: zdt, zds + REAL(wp) :: zinr ! - - + REAL(wp) :: zrr ! - - + REAL(wp) :: zavft ! - - + REAL(wp) :: zavfs ! - - + REAL(wp) :: zavdt, zavds ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3 + !!---------------------------------------------------------------------- + ! + ! ! =============== + DO jk = 2, jpkm1 ! Horizontal slab + ! ! =============== + ! Define the mask + ! --------------- +!!gm WORK to be done: change the code from vector optimisation to scalar one. +!!gm ==>>> test in the loop instead of use of mask arrays +!!gm and many acces in memory + + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !== R=zrau = (alpha / beta) (dk[t] / dk[s]) ==! + zrw = ( (gdepw_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) & +!!gm please, use e3w at Kmm below + & / ( (gdept_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) + ! + zaw = ( rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem) * zrw ) & + & * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) + zbw = ( rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal) * zrw ) & + & * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) + ! + zdt = zaw * ( ts(ji,jj,jk-1,jp_tem,Kmm) - ts(ji,jj,jk,jp_tem,Kmm) ) + zds = zbw * ( ts(ji,jj,jk-1,jp_sal,Kmm) - ts(ji,jj,jk,jp_sal,Kmm) ) + IF( ABS( zds) <= 1.e-20_wp ) zds = 1.e-20_wp + zrau(ji,jj) = MAX( 1.e-20, zdt / zds ) ! only retains positive value of zrau + END DO ; END DO + + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !== indicators ==! + ! stability indicator: msks=1 if rn2>0; 0 elsewhere + IF( rn2(ji,jj,jk) + 1.e-12 <= 0. ) THEN ; zmsks(ji,jj) = 0._wp + ELSE ; zmsks(ji,jj) = 1._wp * wmask(ji,jj,jk) ! mask so avt and avs masked + ENDIF + ! salt fingering indicator: msksf=1 if R>1; 0 elsewhere + IF( zrau(ji,jj) <= 1. ) THEN ; zmskf(ji,jj) = 0._wp + ELSE ; zmskf(ji,jj) = 1._wp + ENDIF + ! diffusive layering indicators: + ! ! mskdl1=1 if 0< R <1; 0 elsewhere + IF( zrau(ji,jj) >= 1. ) THEN ; zmskd1(ji,jj) = 0._wp + ELSE ; zmskd1(ji,jj) = 1._wp + ENDIF + ! ! mskdl2=1 if 0< R <0.5; 0 elsewhere + IF( zrau(ji,jj) >= 0.5 ) THEN ; zmskd2(ji,jj) = 0._wp + ELSE ; zmskd2(ji,jj) = 1._wp + ENDIF + ! mskdl3=1 if 0.5< R <1; 0 elsewhere + IF( zrau(ji,jj) <= 0.5 .OR. zrau(ji,jj) >= 1. ) THEN ; zmskd3(ji,jj) = 0._wp + ELSE ; zmskd3(ji,jj) = 1._wp + ENDIF + END DO ; END DO + + ! Update avt and avs + ! ------------------ + ! Constant eddy coefficient: reset to the background value + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zinr = 1._wp / zrau(ji,jj) + ! salt fingering + zrr = zrau(ji,jj) / rn_hsbfr + zrr = zrr * zrr + zavfs = rn_avts / ( 1 + zrr*zrr*zrr ) * zmsks(ji,jj) * zmskf(ji,jj) + zavft = 0.7 * zavfs * zinr + ! diffusive layering + zavdt = 1.3635e-6 * EXP( 4.6 * EXP( -0.54*(zinr-1.) ) ) * zmsks(ji,jj) * zmskd1(ji,jj) + zavds = zavdt * zmsks(ji,jj) * ( ( 1.85 * zrau(ji,jj) - 0.85 ) * zmskd3(ji,jj) & + & + 0.15 * zrau(ji,jj) * zmskd2(ji,jj) ) + ! add to the eddy viscosity coef. previously computed + p_avs(ji,jj,jk) = p_avt(ji,jj,jk) + zavfs + zavds + p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zavft + zavdt + p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + MAX( zavft + zavdt, zavfs + zavds ) + END DO ; END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + ! + ! IF(sn_cfctl%l_prtctl) THEN + !CALL prt_ctl(tab3d_1=avt , clinfo1=' ddm - t: ', tab3d_2=avs , clinfo2=' s: ') + ! ENDIF + ! + END SUBROUTINE zdf_ddm + + !!====================================================================== +END MODULE zdfddm diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfdrg.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfdrg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..05acf624f7b47c22730036c9a69232e84d29f5e3 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfdrg.f90 @@ -0,0 +1,484 @@ + + + + + + + + + + + + + +MODULE zdfdrg + !!====================================================================== + !! *** MODULE zdfdrg *** + !! Ocean physics: top and/or Bottom friction + !!====================================================================== + !! History : OPA ! 1997-06 (G. Madec, A.-M. Treguier) Original code + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.2 ! 2009-09 (A.C.Coward) Correction to include barotropic contribution + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.4 ! 2011-11 (H. Liu) implementation of semi-implicit bottom friction option + !! ! 2012-06 (H. Liu) implementation of Log Layer bottom friction option + !! 4.0 ! 2017-05 (G. Madec) zdfbfr becomes zdfdrg + variable names change + !! + drag defined at t-point + new user interface + top drag (ocean cavities) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_drg : update bottom friction coefficient (non-linear bottom friction only) + !! zdf_drg_exp : compute the top & bottom friction in explicit case + !! zdf_drg_init : read in namdrg namelist and control the bottom friction parameters. + !! drg_init : + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE phycst , ONLY : vkarmn + USE dom_oce ! ocean space and time domain variables + USE zdf_oce ! ocean vertical physics variables + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing + USE prtctl ! Print control + USE sbc_oce , ONLY : nn_ice + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_drg ! called by zdf_phy + PUBLIC zdf_drg_exp ! called by dyn_zdf + PUBLIC zdf_drg_init ! called by zdf_phy_init + + ! !!* Namelist namdrg: nature of drag coefficient namelist * + LOGICAL , PUBLIC :: ln_drg_OFF ! free-slip : Cd = 0 + LOGICAL :: ln_lin ! linear drag: Cd = Cd0_lin + LOGICAL :: ln_non_lin ! non-linear drag: Cd = Cd0_nl |U| + LOGICAL :: ln_loglayer ! logarithmic drag: Cd = vkarmn/log(z/z0) + LOGICAL , PUBLIC :: ln_drgimp ! implicit top/bottom friction flag + LOGICAL , PUBLIC :: ln_drgice_imp ! implicit ice-ocean drag + ! !!* Namelist namdrg_top & _bot: TOP or BOTTOM coefficient namelist * + REAL(wp) :: rn_Cd0 !: drag coefficient [ - ] + REAL(wp) :: rn_Uc0 !: characteristic velocity (linear case: tau=rho*Cd0*Uc0*u) [m/s] + REAL(wp) :: rn_Cdmax !: drag value maximum (ln_loglayer=T) [ - ] + REAL(wp) :: rn_z0 !: roughness (ln_loglayer=T) [ m ] + REAL(wp) :: rn_ke0 !: background kinetic energy (non-linear case) [m2/s2] + LOGICAL :: ln_boost !: =T regional boost of Cd0 ; =F Cd0 horizontally uniform + REAL(wp) :: rn_boost !: local boost factor [ - ] + + REAL(wp), PUBLIC :: r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top ! set from namdrg_top namelist values + REAL(wp), PUBLIC :: r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot ! - - namdrg_bot - - + + INTEGER :: ndrg ! choice of the type of drag coefficient + ! ! associated indices: + INTEGER, PARAMETER :: np_OFF = 0 ! free-slip: drag set to zero + INTEGER, PARAMETER :: np_lin = 1 ! linear drag: Cd = Cd0_lin + INTEGER, PARAMETER :: np_non_lin = 2 ! non-linear drag: Cd = Cd0_nl |U| + INTEGER, PARAMETER :: np_loglayer = 3 ! non linear drag (logarithmic formulation): Cd = vkarmn/log(z/z0) + + LOGICAL , PUBLIC :: l_zdfdrg !: flag to update at each time step the top/bottom Cd + LOGICAL :: l_log_not_linssh !: flag to update at each time step the position ot the velocity point + ! + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rCd0_top, rCd0_bot !: precomputed top/bottom drag coeff. at t-point (>0) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rCdU_top, rCdU_bot !: top/bottom drag coeff. at t-point (<0) [m/s] + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfdrg.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_drg( kt, Kmm, k_mk, pCdmin, pCdmax, pz0, pke0, pCd0, & ! <<== in + & pCdU ) ! ==>> out : bottom drag [m/s] + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_drg *** + !! + !! ** Purpose : update the top/bottom drag coefficient (non-linear case only) + !! + !! ** Method : In non linear friction case, the drag coeficient is + !! a function of the velocity: + !! Cd = cd0 * |U+Ut| + !! where U is the top or bottom velocity and + !! Ut a tidal velocity (Ut^2 = Tidal kinetic energy + !! assumed here here to be constant) + !! Depending on the input variable, the top- or bottom drag is compted + !! + !! ** Action : p_Cd drag coefficient at t-point + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + ! ! !! !== top or bottom variables ==! + INTEGER , DIMENSION(:,:), INTENT(in ) :: k_mk ! wet level (1st or last) + REAL(wp) , INTENT(in ) :: pCdmin ! min drag value + REAL(wp) , INTENT(in ) :: pCdmax ! max drag value + REAL(wp) , INTENT(in ) :: pz0 ! roughness + REAL(wp) , INTENT(in ) :: pke0 ! background tidal KE + REAL(wp), DIMENSION(:,:), INTENT(in ) :: pCd0 ! masked precomputed part of Cd0 + REAL(wp), DIMENSION(:,:), INTENT( out) :: pCdU ! = - Cd*|U| (t-points) [m/s] + !! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: imk ! local integers + REAL(wp):: zzz, zut, zvt, zcd ! local scalars + !!---------------------------------------------------------------------- + ! + IF( l_log_not_linssh ) THEN !== "log layer" ==! compute Cd and -Cd*|U| + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + imk = k_mk(ji,jj) ! ocean bottom level at t-points + zut = uu(ji,jj,imk,Kmm) + uu(ji-1,jj,imk,Kmm) ! 2 x velocity at t-point + zvt = vv(ji,jj,imk,Kmm) + vv(ji,jj-1,imk,Kmm) + zzz = 0.5_wp * (e3t_0(ji,jj,imk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,imk))) ! altitude below/above (top/bottom) the boundary + ! +!!JC: possible WAD implementation should modify line below if layers vanish + zcd = ( vkarmn / LOG( zzz / pz0 ) )**2 + zcd = pCd0(ji,jj) * MIN( MAX( pCdmin , zcd ) , pCdmax ) ! here pCd0 = mask*boost + pCdU(ji,jj) = - zcd * SQRT( 0.25 * ( zut*zut + zvt*zvt ) + pke0 ) + END DO ; END DO + ELSE !== standard Cd ==! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + imk = k_mk(ji,jj) ! ocean bottom level at t-points + zut = uu(ji,jj,imk,Kmm) + uu(ji-1,jj,imk,Kmm) ! 2 x velocity at t-point + zvt = vv(ji,jj,imk,Kmm) + vv(ji,jj-1,imk,Kmm) + ! ! here pCd0 = mask*boost * drag + pCdU(ji,jj) = - pCd0(ji,jj) * SQRT( 0.25 * ( zut*zut + zvt*zvt ) + pke0 ) + END DO ; END DO + ENDIF + ! + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pCdU, clinfo1=' Cd*U ') + ! + END SUBROUTINE zdf_drg + + + SUBROUTINE zdf_drg_exp( kt, Kmm, pub, pvb, pua, pva ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_drg_exp *** + !! + !! ** Purpose : compute and add the explicit top and bottom frictions. + !! + !! ** Method : in explicit case, + !! + !! NB: in implicit case the calculation is performed in dynzdf.F90 + !! + !! ** Action : (pua,pva) momentum trend increased by top & bottom friction trend + !!--------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pub, pvb ! the two components of the before velocity + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! the two components of the velocity tendency + !! + INTEGER :: ji, jj ! dummy loop indexes + INTEGER :: ikbu, ikbv ! local integers + REAL(wp) :: zm1_2dt ! local scalar + REAL(wp) :: zCdu, zCdv ! - - + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv + !!--------------------------------------------------------------------- + ! +!!gm bug : time step is only rn_Dt (not 2 rn_Dt if euler start !) + zm1_2dt = - 1._wp / ( 2._wp * rn_Dt ) + + IF( l_trddyn ) THEN ! trends: store the input trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = pua(:,:,:) + ztrdv(:,:,:) = pva(:,:,:) + ENDIF + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ikbu = mbku(ji,jj) ! deepest wet ocean u- & v-levels + ikbv = mbkv(ji,jj) + ! + ! Apply stability criteria on absolute value : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) + zCdu = 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / (e3u_0(ji,jj,ikbu)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,ikbu))) + zCdv = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / (e3v_0(ji,jj,ikbv)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,ikbv))) + ! + pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX( zCdu , zm1_2dt ) * pub(ji,jj,ikbu) + pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX( zCdv , zm1_2dt ) * pvb(ji,jj,ikbv) + END DO ; END DO + ! + IF( ln_isfcav ) THEN ! ocean cavities + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + ikbu = miku(ji,jj) ! first wet ocean u- & v-levels + ikbv = mikv(ji,jj) + ! + ! Apply stability criteria on absolute value : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) + zCdu = 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / (e3u_0(ji,jj,ikbu)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,ikbu))) ! NB: Cdtop masked + zCdv = 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / (e3v_0(ji,jj,ikbv)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,ikbv))) + ! + pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX( zCdu , zm1_2dt ) * pub(ji,jj,ikbu) + pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX( zCdv , zm1_2dt ) * pvb(ji,jj,ikbv) + END DO ; END DO + ENDIF + ! + IF( l_trddyn ) THEN ! trends: send trends to trddyn for further diagnostics + ztrdu(:,:,:) = pua(:,:,:) - ztrdu(:,:,:) + ztrdv(:,:,:) = pva(:,:,:) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu(:,:,:), ztrdv(:,:,:), jpdyn_bfr, kt, Kmm ) + DEALLOCATE( ztrdu, ztrdv ) + ENDIF + ! ! print mean trends (used for debugging) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pua, clinfo1=' bfr - Ua: ', mask1=umask, & + ! & tab3d_2=pva, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + END SUBROUTINE zdf_drg_exp + + + SUBROUTINE zdf_drg_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_brg_init *** + !! + !! ** Purpose : Initialization of the bottom friction + !! + !! ** Method : Read the namdrg namelist and check their consistency + !! called at the first timestep (nit000) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indexes + INTEGER :: ios, ioptio ! local integers + !! + NAMELIST/namdrg/ ln_drg_OFF, ln_lin, ln_non_lin, ln_loglayer, ln_drgimp, ln_drgice_imp + !!---------------------------------------------------------------------- + ! + ! !== drag nature ==! + ! + READ ( numnam_ref, namdrg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam( ios , 'namdrg in reference namelist' ) + READ ( numnam_cfg, namdrg, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam( ios , 'namdrg in configuration namelist' ) + IF(lwm) WRITE ( numond, namdrg ) + ! + IF ( ln_drgice_imp .AND. nn_ice /= 2 ) ln_drgice_imp = .FALSE. + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'zdf_drg_init : top and/or bottom drag setting' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namdrg : top/bottom friction choices' + WRITE(numout,*) ' free-slip : Cd = 0 ln_drg_OFF = ', ln_drg_OFF + WRITE(numout,*) ' linear drag : Cd = Cd0 ln_lin = ', ln_lin + WRITE(numout,*) ' non-linear drag: Cd = Cd0_nl |U| ln_non_lin = ', ln_non_lin + WRITE(numout,*) ' logarithmic drag: Cd = vkarmn/log(z/z0) ln_loglayer = ', ln_loglayer + WRITE(numout,*) ' implicit friction ln_drgimp = ', ln_drgimp + WRITE(numout,*) ' implicit ice-ocean drag ln_drgice_imp =', ln_drgice_imp + ENDIF + ! + ioptio = 0 ! set ndrg and control check + IF( ln_drg_OFF ) THEN ; ndrg = np_OFF ; ioptio = ioptio + 1 ; ENDIF + IF( ln_lin ) THEN ; ndrg = np_lin ; ioptio = ioptio + 1 ; ENDIF + IF( ln_non_lin ) THEN ; ndrg = np_non_lin ; ioptio = ioptio + 1 ; ENDIF + IF( ln_loglayer ) THEN ; ndrg = np_loglayer ; ioptio = ioptio + 1 ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'zdf_drg_init: Choose ONE type of drag coef in namdrg' ) + ! + IF ( ln_drgice_imp.AND.(.NOT.ln_drgimp) ) & + & CALL ctl_stop( 'zdf_drg_init: ln_drgice_imp=T requires ln_drgimp=T' ) + ! + ! !== BOTTOM drag setting ==! (applied at seafloor) + ! + ALLOCATE( rCd0_bot(jpi,jpj), rCdU_bot(jpi,jpj) ) + CALL drg_init( 'BOTTOM' , mbkt , & ! <== in + & r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot, rCd0_bot, rCdU_bot ) ! ==> out + ! + ! !== TOP drag setting ==! (applied at the top of ocean cavities) + ! + IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities: top friction setting + ALLOCATE( rCdU_top(jpi,jpj) ) + ENDIF + ! + IF( ln_isfcav ) THEN + ALLOCATE( rCd0_top(jpi,jpj)) + CALL drg_init( 'TOP ' , mikt , & ! <== in + & r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top, rCd0_top, rCdU_top ) ! ==> out + ENDIF + ! + END SUBROUTINE zdf_drg_init + + + SUBROUTINE drg_init( cd_topbot, k_mk, & + & pCdmin, pCdmax, pz0, pke0, pCd0, pCdU ) + !!---------------------------------------------------------------------- + !! *** ROUTINE drg_init *** + !! + !! ** Purpose : Initialization of the top/bottom friction CdO and Cd + !! from namelist parameters + !!---------------------------------------------------------------------- + CHARACTER(len=6) , INTENT(in ) :: cd_topbot ! top/ bot indicator + INTEGER , DIMENSION(:,:), INTENT(in ) :: k_mk ! 1st/last wet level + REAL(wp) , INTENT( out) :: pCdmin, pCdmax ! min and max drag coef. [-] + REAL(wp) , INTENT( out) :: pz0 ! roughness [m] + REAL(wp) , INTENT( out) :: pke0 ! background KE [m2/s2] + REAL(wp), DIMENSION(:,:), INTENT( out) :: pCd0 ! masked precomputed part of the non-linear drag coefficient + REAL(wp), DIMENSION(:,:), INTENT( out) :: pCdU ! minus linear drag*|U| at t-points [m/s] + !! + CHARACTER(len=40) :: cl_namdrg, cl_file, cl_varname, cl_namref, cl_namcfg ! local names + INTEGER :: ji, jj ! dummy loop indexes + LOGICAL :: ll_top, ll_bot ! local logical + INTEGER :: ios, inum, imk ! local integers + REAL(wp):: zmsk, zzz, zcd ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zmsk_boost ! 2D workspace + !! + NAMELIST/namdrg_top/ rn_Cd0, rn_Uc0, rn_Cdmax, rn_ke0, rn_z0, ln_boost, rn_boost + NAMELIST/namdrg_bot/ rn_Cd0, rn_Uc0, rn_Cdmax, rn_ke0, rn_z0, ln_boost, rn_boost + !!---------------------------------------------------------------------- + ! + ! !== set TOP / BOTTOM specificities ==! + ll_top = .FALSE. + ll_bot = .FALSE. + ! + SELECT CASE (cd_topbot) + CASE( 'TOP ' ) + ll_top = .TRUE. + cl_namdrg = 'namdrg_top' + cl_namref = 'namdrg_top in reference namelist' + cl_namcfg = 'namdrg_top in configuration namelist' + cl_file = 'tfr_coef.nc' + cl_varname = 'tfr_coef' + CASE( 'BOTTOM' ) + ll_bot = .TRUE. + cl_namdrg = 'namdrg_bot' + cl_namref = 'namdrg_bot in reference namelist' + cl_namcfg = 'namdrg_bot in configuration namelist' + cl_file = 'bfr_coef.nc' + cl_varname = 'bfr_coef' + CASE DEFAULT + CALL ctl_stop( 'drg_init: bad value for cd_topbot ' ) + END SELECT + ! + ! !== read namlist ==! + ! + IF(ll_top) READ ( numnam_ref, namdrg_top, IOSTAT = ios, ERR = 901) + IF(ll_bot) READ ( numnam_ref, namdrg_bot, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam( ios , TRIM(cl_namref) ) + IF(ll_top) READ ( numnam_cfg, namdrg_top, IOSTAT = ios, ERR = 902 ) + IF(ll_bot) READ ( numnam_cfg, namdrg_bot, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam( ios , TRIM(cl_namcfg) ) + IF(lwm .AND. ll_top) WRITE ( numond, namdrg_top ) + IF(lwm .AND. ll_bot) WRITE ( numond, namdrg_bot ) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist ',TRIM(cl_namdrg),' : set ',TRIM(cd_topbot),' friction parameters' + WRITE(numout,*) ' drag coefficient rn_Cd0 = ', rn_Cd0 + WRITE(numout,*) ' characteristic velocity (linear case) rn_Uc0 = ', rn_Uc0, ' m/s' + WRITE(numout,*) ' non-linear drag maximum rn_Cdmax = ', rn_Cdmax + WRITE(numout,*) ' background kinetic energy (n-l case) rn_ke0 = ', rn_ke0 + WRITE(numout,*) ' bottom roughness (n-l case) rn_z0 = ', rn_z0 + WRITE(numout,*) ' set a regional boost of Cd0 ln_boost = ', ln_boost + WRITE(numout,*) ' associated boost factor rn_boost = ', rn_boost + ENDIF + ! + ! !== return some namelist parametres ==! (used in non_lin and loglayer cases) + pCdmin = rn_Cd0 + pCdmax = rn_Cdmax + pz0 = rn_z0 + pke0 = rn_ke0 + ! + ! !== mask * boost factor ==! + ! + IF( ln_boost ) THEN !* regional boost: boost factor = 1 + regional boost + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> use a regional boost read in ', TRIM(cl_file), ' file' + IF(lwp) WRITE(numout,*) ' using enhancement factor of ', rn_boost + ! cl_varname is a coefficient in [0,1] giving where to apply the regional boost + CALL iom_open ( TRIM(cl_file), inum ) + CALL iom_get ( inum, jpdom_global, TRIM(cl_varname), zmsk_boost, 1 ) + CALL iom_close( inum) + zmsk_boost(:,:) = 1._wp + rn_boost * zmsk_boost(:,:) + ! + ELSE !* no boost: boost factor = 1 + zmsk_boost(:,:) = 1._wp + ENDIF + ! !* mask outside ocean cavities area (top) or land area (bot) + IF(ll_top) zmsk_boost(:,:) = zmsk_boost(:,:) * ssmask(:,:) * (1. - tmask(:,:,1) ) ! none zero in ocean cavities only + IF(ll_bot) zmsk_boost(:,:) = zmsk_boost(:,:) * ssmask(:,:) ! x seafloor mask + ! + l_log_not_linssh = .FALSE. ! default definition + ! + SELECT CASE( ndrg ) + ! + CASE( np_OFF ) !== No top/bottom friction ==! (pCdU = 0) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> ',TRIM(cd_topbot),' free-slip, friction set to zero' + ! + l_zdfdrg = .FALSE. ! no time variation of the drag: set it one for all + ! + pCdU(:,:) = 0._wp + pCd0(:,:) = 0._wp + ! + CASE( np_lin ) !== linear friction ==! (pCdU = Cd0 * Uc0) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> linear ',TRIM(cd_topbot),' friction (constant coef = Cd0*Uc0 = ', rn_Cd0*rn_Uc0, ')' + ! + l_zdfdrg = .FALSE. ! no time variation of the Cd*|U| : set it one for all + ! + pCd0(:,:) = rn_Cd0 * zmsk_boost(:,:) !* constant in time drag coefficient (= mask (and boost) Cd0) + pCdU(:,:) = - pCd0(:,:) * rn_Uc0 ! using a constant velocity + ! + CASE( np_non_lin ) !== non-linear friction ==! (pCd0 = Cd0 ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> quadratic ',TRIM(cd_topbot),' friction (propotional to module of the velocity)' + IF(lwp) WRITE(numout,*) ' with a drag coefficient Cd0 = ', rn_Cd0, ', and' + IF(lwp) WRITE(numout,*) ' a background velocity module of (rn_ke0)^1/2 = ', SQRT(rn_ke0), 'm/s)' + ! + l_zdfdrg = .TRUE. !* Cd*|U| updated at each time-step (it depends on ocean velocity) + ! + pCd0(:,:) = rn_Cd0 * zmsk_boost(:,:) !* constant in time proportionality coefficient (= mask (and boost) Cd0) + pCdU(:,:) = 0._wp ! + ! + CASE( np_loglayer ) !== logarithmic layer formulation of friction ==! (CdU = (vkarman log(z/z0))^2 |U| ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> quadratic ',TRIM(cd_topbot),' drag (propotional to module of the velocity)' + IF(lwp) WRITE(numout,*) ' with a logarithmic Cd0 formulation Cd0 = ( vkarman log(z/z0) )^2 ,' + IF(lwp) WRITE(numout,*) ' a background velocity module of (rn_ke0)^1/2 = ', SQRT(pke0), 'm/s), ' + IF(lwp) WRITE(numout,*) ' a logarithmic formulation: a roughness of ', pz0, ' meters, and ' + IF(lwp) WRITE(numout,*) ' a proportionality factor bounded by min/max values of ', pCdmin, pCdmax + ! + l_zdfdrg = .TRUE. !* Cd*|U| updated at each time-step (it depends on ocean velocity) + ! + IF( ln_linssh ) THEN !* pCd0 = (v log(z/z0))^2 as velocity points have a fixed z position + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' N.B. linear free surface case, Cd0 computed one for all' + ! + l_log_not_linssh = .FALSE. !- don't update Cd at each time step + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) ! pCd0 = mask (and boosted) logarithmic drag coef. + zzz = 0.5_wp * e3t_0(ji,jj,k_mk(ji,jj)) + zcd = ( vkarmn / LOG( zzz / rn_z0 ) )**2 + pCd0(ji,jj) = zmsk_boost(ji,jj) * MIN( MAX( rn_Cd0 , zcd ) , rn_Cdmax ) ! rn_Cd0 < Cd0 < rn_Cdmax + END DO ; END DO + ELSE !* Cd updated at each time-step ==> pCd0 = mask * boost + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' N.B. non-linear free surface case, Cd0 updated at each time-step ' + ! + l_log_not_linssh = .TRUE. ! compute the drag coef. at each time-step + ! + pCd0(:,:) = zmsk_boost(:,:) + ENDIF + pCdU(:,:) = 0._wp ! initialisation to zero (will be updated at each time step) + ! + CASE DEFAULT + CALL ctl_stop( 'drg_init: bad flag value for ndrg ' ) + END SELECT + ! + END SUBROUTINE drg_init + + !!====================================================================== +END MODULE zdfdrg diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfevd.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfevd.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a79e71b95fe05be586f18b2f85e8157f179d0c5d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfevd.f90 @@ -0,0 +1,157 @@ + + + + + + + + + + + + + +MODULE zdfevd + !!====================================================================== + !! *** MODULE zdfevd *** + !! Ocean physics: parameterization of convection through an enhancement + !! of vertical eddy mixing coefficient + !!====================================================================== + !! History : OPA ! 1997-06 (G. Madec, A. Lazar) Original code + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.2 ! 2009-03 (M. Leclair, G. Madec, R. Benshila) test on both before & after + !! 4.0 ! 2017-04 (G. Madec) evd applied on avm (at t-point) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_evd : increase the momentum and tracer Kz at the location of + !! statically unstable portion of the water column (ln_zdfevd=T) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE zdf_oce ! ocean vertical physics variables + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + ! + USE in_out_manager ! I/O manager + USE iom ! for iom_put + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_evd ! called by step.F90 + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfevd.F90 15298 2021-09-28 10:06:42Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_evd( kt, Kmm, Krhs, p_avm, p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_evd *** + !! + !! ** Purpose : Local increased the vertical eddy viscosity and diffu- + !! sivity coefficients when a static instability is encountered. + !! + !! ** Method : tracer (and momentum if nn_evdm=1) vertical mixing + !! coefficients are set to rn_evd (namelist parameter) + !! if the water column is statically unstable. + !! The test of static instability is performed using + !! Brunt-Vaisala frequency (rn2 < -1.e-12) of to successive + !! time-step (Leap-Frog environnement): before and + !! now time-step. + !! + !! ** Action : avt, avm enhanced where static instability occurs + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step indexocean time step + INTEGER , INTENT(in ) :: Kmm, Krhs ! time level indices + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + ! NOTE: [tiling] use a SAVE array to store diagnostics, then send after all tiles are finished. This is necessary because p_avt/p_avm are modified on adjacent tiles when using nn_hls > 1. zavt_evd/zavm_evd are then zero on some points when subsequently calculated for these tiles. + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: zavt_evd, zavm_evd + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'zdf_evd : Enhanced Vertical Diffusion (evd)' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + IF(lwp) WRITE(numout,*) + ENDIF + + ALLOCATE( zavt_evd(jpi,jpj,jpk) ) + IF( nn_evdm == 1 ) ALLOCATE( zavm_evd(jpi,jpj,jpk) ) + ENDIF + ! + ! + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zavt_evd(ji,jj,jk) = p_avt(ji,jj,jk) ! set avt prior to evd application + END DO ; END DO ; END DO + ! + SELECT CASE ( nn_evdm ) + ! + CASE ( 1 ) !== enhance tracer & momentum Kz ==! (if rn2<-1.e-12) + ! + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zavm_evd(ji,jj,jk) = p_avm(ji,jj,jk) ! set avm prior to evd application + END DO ; END DO ; END DO + ! +!! change last digits results +! WHERE( MAX( rn2(2:jpi,2:jpj,2:jpkm1), rn2b(2:jpi,2:jpj,2:jpkm1) ) <= -1.e-12 ) THEN +! p_avt(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1) +! p_avm(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1) +! END WHERE + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) THEN + p_avt(ji,jj,jk) = rn_evd * wmask(ji,jj,jk) + p_avm(ji,jj,jk) = rn_evd * wmask(ji,jj,jk) + ENDIF + END DO ; END DO ; END DO + ! + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zavm_evd(ji,jj,jk) = p_avm(ji,jj,jk) - zavm_evd(ji,jj,jk) ! change in avm due to evd + END DO ; END DO ; END DO + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + CALL iom_put( "avm_evd", zavm_evd ) ! output this change + DEALLOCATE( zavm_evd ) + ENDIF + ! + CASE DEFAULT !== enhance tracer Kz ==! (if rn2<-1.e-12) +!! change last digits results +! WHERE( MAX( rn2(2:jpi,2:jpj,2:jpkm1), rn2b(2:jpi,2:jpj,2:jpkm1) ) <= -1.e-12 ) +! p_avt(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1) +! END WHERE + + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) & + p_avt(ji,jj,jk) = rn_evd * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + END SELECT + ! + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zavt_evd(ji,jj,jk) = p_avt(ji,jj,jk) - zavt_evd(ji,jj,jk) ! change in avt due to evd + END DO ; END DO ; END DO + ! + IF( l_trdtra ) CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_evd, zavt_evd ) + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + CALL iom_put( "avt_evd", zavt_evd ) ! output this change + DEALLOCATE( zavt_evd ) + ENDIF + ! + END SUBROUTINE zdf_evd + + !!====================================================================== +END MODULE zdfevd diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfgls.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfgls.f90 new file mode 100644 index 0000000000000000000000000000000000000000..20bc36182891e042599bd1aec4ac306872a300bf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfgls.f90 @@ -0,0 +1,1292 @@ + + + + + + + + + + + + + +MODULE zdfgls + !!====================================================================== + !! *** MODULE zdfgls *** + !! Ocean physics: vertical mixing coefficient computed from the gls + !! turbulent closure parameterization + !!====================================================================== + !! History : 3.0 ! 2009-09 (G. Reffray) Original code + !! 3.3 ! 2010-10 (C. Bricaud) Add in the reference + !! 4.0 ! 2017-04 (G. Madec) remove CPP keys & avm at t-point only + !! - ! 2017-05 (G. Madec) add top friction as boundary condition + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_gls : update momentum and tracer Kz from a gls scheme + !! zdf_gls_init : initialization, namelist read, and parameters control + !! gls_rst : read/write gls restart in ocean restart file + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domvvl ! ocean space and time domain : variable volume layer + USE zdfdrg , ONLY : ln_drg_OFF ! top/bottom free-slip flag + USE zdfdrg , ONLY : r_z0_top , r_z0_bot ! top/bottom roughness + USE zdfdrg , ONLY : rCdU_top , rCdU_bot ! top/bottom friction + USE sbc_oce ! surface boundary condition: ocean + USE phycst ! physical constants + USE zdfmxl ! mixed layer + USE sbcwave , ONLY : hsw ! significant wave height + ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP manager + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_gls ! called in zdfphy + PUBLIC zdf_gls_init ! called in zdfphy + PUBLIC gls_rst ! called in zdfphy + + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hmxl_n !: now mixing length + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zwall !: wall function + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_surf !: Squared surface velocity scale at T-points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_top !: Squared top velocity scale at T-points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_bot !: Squared bottom velocity scale at T-points + + ! !! ** Namelist namzdf_gls ** + LOGICAL :: ln_length_lim ! use limit on the dissipation rate under stable stratification (Galperin et al. 1988) + LOGICAL :: ln_sigpsi ! Activate Burchard (2003) modification for k-eps closure & wave breaking mixing + INTEGER :: nn_mxlice ! type of scaling under sea-ice (=0/1/2/3) + INTEGER :: nn_bc_surf ! surface boundary condition (=0/1) + INTEGER :: nn_bc_bot ! bottom boundary condition (=0/1) + INTEGER :: nn_z0_met ! Method for surface roughness computation + INTEGER :: nn_z0_ice ! Roughness accounting for sea ice + INTEGER :: nn_stab_func ! stability functions G88, KC or Canuto (=0/1/2) + INTEGER :: nn_clos ! closure 0/1/2/3 MY82/k-eps/k-w/gen + REAL(wp) :: rn_clim_galp ! Holt 2008 value for k-eps: 0.267 + REAL(wp) :: rn_epsmin ! minimum value of dissipation (m2/s3) + REAL(wp) :: rn_emin ! minimum value of TKE (m2/s2) + REAL(wp) :: rn_charn ! Charnock constant for surface breaking waves mixing : 1400. (standard) or 2.e5 (Stacey value) + REAL(wp) :: rn_crban ! Craig and Banner constant for surface breaking waves mixing + REAL(wp) :: rn_hsro ! Minimum surface roughness + REAL(wp) :: rn_hsri ! Ice ocean roughness + REAL(wp) :: rn_frac_hs ! Fraction of wave height as surface roughness (if nn_z0_met > 1) + + REAL(wp) :: rcm_sf = 0.73_wp ! Shear free turbulence parameters + REAL(wp) :: ra_sf = -2.0_wp ! Must be negative -2 < ra_sf < -1 + REAL(wp) :: rl_sf = 0.2_wp ! 0 > think about that... + ! + IF( .NOT.ln_drg_OFF ) THEN !== top/bottom friction (explicit before friction) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! bottom friction (explicit before friction) + zmsku = 0.5_wp * ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) + zmskv = 0.5_wp * ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! (CAUTION: CdU<0) + ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 & + & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) + END DO ; END DO + IF( ln_isfcav ) THEN + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! top friction + zmsku = 0.5_wp * ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) + zmskv = 0.5_wp * ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) ! (CAUTION: CdU<0) + ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 & + & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 ) + END DO ; END DO + ENDIF + ENDIF + + SELECT CASE ( nn_z0_met ) !== Set surface roughness length ==! + CASE ( 0 ) ! Constant roughness + zhsro(:,:) = rn_hsro + CASE ( 1 ) ! Standard Charnock formula + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zhsro(ji,jj) = MAX( rsbc_zs1 * ustar2_surf(ji,jj) , rn_hsro ) + END DO ; END DO + CASE ( 2 ) ! Roughness formulae according to Rascle et al., Ocean Modelling (2008) +!!gm faster coding : the 2 comment lines should be used +!!gm zcof = 2._wp * 0.6_wp / 28._wp +!!gm zdep(:,:) = 30._wp * TANH( zcof/ SQRT( MAX(ustar2_surf(:,:),rsmall) ) ) ! Wave age (eq. 10) + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zcof = 30.*TANH( 2.*0.3/(28.*SQRT(MAX(ustar2_surf(ji,jj),rsmall))) ) ! Wave age (eq. 10) + zhsro(ji,jj) = MAX(rsbc_zs2 * ustar2_surf(ji,jj) * zcof**1.5, rn_hsro) ! zhsro = rn_frac_hs * Hsw (eq. 11) + END DO ; END DO + CASE ( 3 ) ! Roughness given by the wave model (coupled or read in file) + zhsro(:,:) = MAX(rn_frac_hs * hsw(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)), rn_hsro) ! (rn_frac_hs=1.6 see Eq. (5) of Rascle et al. 2008 ) + END SELECT + ! + ! adapt roughness where there is sea ice + SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice + ! + CASE( 1 ) ! scaling with constant sea-ice roughness + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zhsro(ji,jj) = ( (1._wp-zice_fra(ji,jj)) * zhsro(ji,jj) + zice_fra(ji,jj) * rn_hsri )*tmask(ji,jj,1) + (1._wp - tmask(ji,jj,1))*rn_hsro + END DO ; END DO + ! + CASE( 2 ) ! scaling with mean sea-ice thickness + ! + CASE( 3 ) ! scaling with max sea-ice thickness + ! + END SELECT + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !== Compute dissipation rate ==! + eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk) + END DO ; END DO ; END DO + + ! Save tke at before time step + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + eb (ji,jj,jk) = en (ji,jj,jk) + hmxl_b(ji,jj,jk) = hmxl_n(ji,jj,jk) + END DO ; END DO ; END DO + + IF( nn_clos == 0 ) THEN ! Mellor-Yamada + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zup = hmxl_n(ji,jj,jk) * (gdepw_0(ji,jj,mbkt(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))) + zdown = vkarmn * (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * ( -(gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + (gdepw_0(ji,jj,mbkt(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))) ) + zcoef = ( zup / MAX( zdown, rsmall ) ) + zwall (ji,jj,jk) = ( 1._wp + re2 * zcoef*zcoef ) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + + !!---------------------------------!! + !! Equation to prognostic k !! + !!---------------------------------!! + ! + ! Now Turbulent kinetic energy (output in en) + ! ------------------------------- + ! Resolution of a tridiagonal linear system by a "methode de chasse" + ! computation from level 2 to jpkm1 (e(1) computed after and e(jpk)=0 ). + ! The surface boundary condition are set after + ! The bottom boundary condition are also set after. In standard e(bottom)=0. + ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal + ! Warning : after this step, en : right hand side of the matrix + + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! + buoy = - p_avt(ji,jj,jk) * rn2(ji,jj,jk) ! stratif. destruction + ! + diss = eps(ji,jj,jk) ! dissipation + ! + zdir = 0.5_wp + SIGN( 0.5_wp, p_sh2(ji,jj,jk) + buoy ) ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) + ! + zesh2 = zdir*(p_sh2(ji,jj,jk)+buoy)+(1._wp-zdir)*p_sh2(ji,jj,jk) ! production term + zdiss = zdir*(diss/en(ji,jj,jk)) +(1._wp-zdir)*(diss-buoy)/en(ji,jj,jk) ! dissipation term +!!gm better coding, identical results +! zesh2 = p_sh2(ji,jj,jk) + zdir*buoy ! production term +! zdiss = ( diss - (1._wp-zdir)*buoy ) / en(ji,jj,jk) ! dissipation term +!!gm + ! + ! Compute a wall function from 1. to rsc_psi*zwall/rsc_psi0 + ! Note that as long that Dirichlet boundary conditions are NOT set at the first and last levels (GOTM style) + ! there is no need to set a boundary condition for zwall_psi at the top and bottom boundaries. + ! Otherwise, this should be rsc_psi/rsc_psi0 + IF( ln_sigpsi ) THEN + zsigpsi = MIN( 1._wp, zesh2 / eps(ji,jj,jk) ) ! 0. <= zsigpsi <= 1. + zwall_psi(ji,jj,jk) = rsc_psi / & + & ( zsigpsi * rsc_psi + (1._wp-zsigpsi) * rsc_psi0 / MAX( zwall(ji,jj,jk), 1._wp ) ) + ELSE + zwall_psi(ji,jj,jk) = 1._wp + ENDIF + ! + ! building the matrix + zcof = rfact_tke * tmask(ji,jj,jk) + ! ! lower diagonal, in fact not used for jk = 2 (see surface conditions) + zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) & + & / ( (e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1))) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) + ! ! upper diagonal, in fact not used for jk = ibotm1 (see bottom conditions) + zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) & + & / ( (e3t_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk ))) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) + ! ! diagonal + zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rn_Dt * zdiss * wmask(ji,jj,jk) + ! ! right hand side in en + en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zesh2 * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zdiag(ji,jj,jpk) = 1._wp + ! + ! Set surface condition on zwall_psi (1 at the bottom) + zwall_psi(ji,jj, 1 ) = zwall_psi(ji,jj,2) + zwall_psi(ji,jj,jpk) = 1._wp + END DO ; END DO + ! + ! Surface boundary condition on tke + ! --------------------------------- + ! + SELECT CASE ( nn_bc_surf ) + ! + CASE ( 0 ) ! Dirichlet boundary condition (set e at k=1 & 2) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! First level + en (ji,jj,1) = MAX( rn_emin , rc02r * ustar2_surf(ji,jj) * (1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1)**r2_3 ) + zd_lw(ji,jj,1) = en(ji,jj,1) + zd_up(ji,jj,1) = 0._wp + zdiag(ji,jj,1) = 1._wp + ! + ! One level below + en (ji,jj,2) = MAX( rn_emin , rc02r * ustar2_surf(ji,jj) * (1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1 & + & * ((zhsro(ji,jj)+(gdepw_0(ji,jj,2)*(1._wp+r3t(ji,jj,Kmm)))) / zhsro(ji,jj) )**(1.5_wp*ra_sf) )**r2_3 ) + zd_lw(ji,jj,2) = 0._wp + zd_up(ji,jj,2) = 0._wp + zdiag(ji,jj,2) = 1._wp + END DO ; END DO + ! + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF( mikt(ji,jj) > 1 )THEN + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! ! mask at the + ! ocean surface + ! points + z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) + ! + ! Dirichlet condition applied at: + ! top level (itop) & Just below it (itopp1) + zd_lw(ji,jj,itop) = 0._wp ; zd_lw(ji,jj,itopp1) = 0._wp + zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp + zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = 1._wp + en (ji,jj,itop) = z_en ; en (ji,jj,itopp1) = z_en + ENDIF + END DO ; END DO + ENDIF + ! + CASE ( 1 ) ! Neumann boundary condition (set d(e)/dz) + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! Dirichlet conditions at k=1 + en (ji,jj,1) = MAX( rn_emin , rc02r * ustar2_surf(ji,jj) * (1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1)**r2_3 ) + zd_lw(ji,jj,1) = en(ji,jj,1) + zd_up(ji,jj,1) = 0._wp + zdiag(ji,jj,1) = 1._wp + ! + ! at k=2, set de/dz=Fw + !cbr + ! zdiag zd_lw not defined/used on the halo + zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) ! Remove zd_lw from zdiag + zd_lw(ji,jj,2) = 0._wp + ! + zkar (ji,jj) = (rl_sf + (vkarmn-rl_sf)*(1.-EXP(-rtrans*(gdept_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)))/zhsro(ji,jj)) )) + zflxs(ji,jj) = rsbc_tke2 * (1._wp-zice_fra(ji,jj)) * ustar2_surf(ji,jj)**1.5_wp * zkar(ji,jj) & + & * ( ( zhsro(ji,jj)+(gdept_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))) ) / zhsro(ji,jj) )**(1.5_wp*ra_sf) +!!gm why not : * ( 1._wp + (gdept_0(:,:,1)*(1._wp+r3t(:,:,Kmm))) / zhsro(:,:) )**(1.5_wp*ra_sf) + en(ji,jj,2) = en(ji,jj,2) + zflxs(ji,jj) / (e3w_0(ji,jj,2)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + ! + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF( mikt(ji,jj) > 1 )THEN + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! ! mask at the + ! ocean surface + ! points + z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) + ! + ! Bottom level Dirichlet condition: + ! Bottom level (ibot) & Just above it (ibotm1) + ! Dirichlet ! Neumann + zd_lw(ji,jj,itop) = 0._wp ! ! Remove zd_up from zdiag + zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) + zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp + en (ji,jj,itop) = z_en + ENDIF + END DO ; END DO + ENDIF + ! + END SELECT + + ! Bottom boundary condition on tke + ! -------------------------------- + ! + SELECT CASE ( nn_bc_bot ) + ! + CASE ( 0 ) ! Dirichlet + ! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = rn_lmin + ! ! Balance between the production and the dissipation terms + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) +!!gm This means that bottom and ocean w-level above have a specified "en" value. Sure ???? +!! With thick deep ocean level thickness, this may be quite large, no ??? +!! in particular in ocean cavities where top stratification can be large... + ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point + ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 + ! + z_en = MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) + ! + ! Dirichlet condition applied at: + ! Bottom level (ibot) & Just above it (ibotm1) + zd_lw(ji,jj,ibot) = 0._wp ; zd_lw(ji,jj,ibotm1) = 0._wp + zd_up(ji,jj,ibot) = 0._wp ; zd_up(ji,jj,ibotm1) = 0._wp + zdiag(ji,jj,ibot) = 1._wp ; zdiag(ji,jj,ibotm1) = 1._wp + en (ji,jj,ibot) = z_en ; en (ji,jj,ibotm1) = z_en + END DO ; END DO + ! + ! NOTE: ctl_stop with ln_isfcav when using GLS + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! ! mask at the ocean surface points + z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) + ! + !!gm TO BE VERIFIED !!! + ! Dirichlet condition applied at: + ! top level (itop) & Just below it (itopp1) + zd_lw(ji,jj,itop) = 0._wp ; zd_lw(ji,jj,itopp1) = 0._wp + zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp + zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = 1._wp + en (ji,jj,itop) = z_en ; en (ji,jj,itopp1) = z_en + END DO ; END DO + ENDIF + ! + CASE ( 1 ) ! Neumman boundary condition + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point + ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 + ! + z_en = MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) + ! + ! Bottom level Dirichlet condition: + ! Bottom level (ibot) & Just above it (ibotm1) + ! Dirichlet ! Neumann + zd_lw(ji,jj,ibot) = 0._wp ! ! Remove zd_up from zdiag + zdiag(ji,jj,ibot) = 1._wp ; zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) + zd_up(ji,jj,ibot) = 0._wp ; zd_up(ji,jj,ibotm1) = 0._wp + en (ji,jj,ibot) = z_en + END DO ; END DO + ! NOTE: ctl_stop with ln_isfcav when using GLS + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! ! mask at the ocean surface points + z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) + ! + ! Bottom level Dirichlet condition: + ! Bottom level (ibot) & Just above it (ibotm1) + ! Dirichlet ! Neumann + zd_lw(ji,jj,itop) = 0._wp ! ! Remove zd_up from zdiag + zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) + zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp + en (ji,jj,itop) = z_en + END DO ; END DO + ENDIF + ! + END SELECT + + ! Matrix inversion (en prescribed at surface and the bottom) + ! ---------------------------------------------------------- + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) + END DO ; END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 + zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) + END DO ; END DO ; END DO + DO jk = jpkm1, 2, -1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) + END DO ; END DO ; END DO + ! ! set the minimum value of tke + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) + END DO ; END DO ; END DO + + !!----------------------------------------!! + !! Solve prognostic equation for psi !! + !!----------------------------------------!! + + ! Set psi to previous time step value + ! + SELECT CASE ( nn_clos ) + ! + CASE( 0 ) ! k-kl (Mellor-Yamada) + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + psi(ji,jj,jk) = eb(ji,jj,jk) * hmxl_b(ji,jj,jk) + END DO ; END DO ; END DO + ! + CASE( 1 ) ! k-eps + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + psi(ji,jj,jk) = eps(ji,jj,jk) + END DO ; END DO ; END DO + ! + CASE( 2 ) ! k-w + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + psi(ji,jj,jk) = SQRT( eb(ji,jj,jk) ) / ( rc0 * hmxl_b(ji,jj,jk) ) + END DO ; END DO ; END DO + ! + CASE( 3 ) ! generic + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + psi(ji,jj,jk) = rc02 * eb(ji,jj,jk) * hmxl_b(ji,jj,jk)**rnn + END DO ; END DO ; END DO + ! + END SELECT + ! + ! Now gls (output in psi) + ! ------------------------------- + ! Resolution of a tridiagonal linear system by a "methode de chasse" + ! computation from level 2 to jpkm1 (e(1) already computed and e(jpk)=0 ). + ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal + ! Warning : after this step, en : right hand side of the matrix + + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ! + ! psi / k + zratio = psi(ji,jj,jk) / eb(ji,jj,jk) + ! + ! psi3+ : stable : B=-KhN²<0 => N²>0 if rn2>0 zdir = 1 (stable) otherwise zdir = 0 (unstable) + zdir = 0.5_wp + SIGN( 0.5_wp, rn2(ji,jj,jk) ) + ! + rpsi3 = zdir * rpsi3m + ( 1._wp - zdir ) * rpsi3p + ! + ! shear prod. - stratif. destruction + prod = rpsi1 * zratio * p_sh2(ji,jj,jk) + ! + ! stratif. destruction + buoy = rpsi3 * zratio * (- p_avt(ji,jj,jk) * rn2(ji,jj,jk) ) + ! + ! shear prod. - stratif. destruction + diss = rpsi2 * zratio * zwall(ji,jj,jk) * eps(ji,jj,jk) + ! + zdir = 0.5_wp + SIGN( 0.5_wp, prod + buoy ) ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) + ! + zesh2 = zdir * ( prod + buoy ) + (1._wp - zdir ) * prod ! production term + zdiss = zdir * ( diss / psi(ji,jj,jk) ) + (1._wp - zdir ) * (diss-buoy) / psi(ji,jj,jk) ! dissipation term + ! + ! building the matrix + zcof = rfact_psi * zwall_psi(ji,jj,jk) * tmask(ji,jj,jk) + ! ! lower diagonal + zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) & + & / ( (e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1))) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) + ! ! upper diagonal + zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) & + & / ( (e3t_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk ))) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) + ! ! diagonal + zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rn_Dt * zdiss * wmask(ji,jj,jk) + ! ! right hand side in psi + psi(ji,jj,jk) = psi(ji,jj,jk) + rn_Dt * zesh2 * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zdiag(ji,jj,jpk) = 1._wp + END DO ; END DO + + ! Surface boundary condition on psi + ! --------------------------------- + ! + SELECT CASE ( nn_bc_surf ) + ! + CASE ( 0 ) ! Dirichlet boundary conditions + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ! Surface value + zdep (ji,jj) = zhsro(ji,jj) * rl_sf ! Cosmetic + psi (ji,jj,1) = rc0**rpp * en(ji,jj,1)**rmm * zdep(ji,jj)**rnn * tmask(ji,jj,1) + zd_lw(ji,jj,1) = psi(ji,jj,1) + zd_up(ji,jj,1) = 0._wp + zdiag(ji,jj,1) = 1._wp + ! + ! One level below + zkar (ji,jj) = (rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*(gdepw_0(ji,jj,2)*(1._wp+r3t(ji,jj,Kmm)))/zhsro(ji,jj) ))) + zdep (ji,jj) = (zhsro(ji,jj) + (gdepw_0(ji,jj,2)*(1._wp+r3t(ji,jj,Kmm)))) * zkar(ji,jj) + psi (ji,jj,2) = rc0**rpp * en(ji,jj,2)**rmm * zdep(ji,jj)**rnn * tmask(ji,jj,1) + zd_lw(ji,jj,2) = 0._wp + zd_up(ji,jj,2) = 0._wp + zdiag(ji,jj,2) = 1._wp + END DO ; END DO + ! + CASE ( 1 ) ! Neumann boundary condition on d(psi)/dz + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ! Surface value: Dirichlet + zdep (ji,jj) = zhsro(ji,jj) * rl_sf + psi (ji,jj,1) = rc0**rpp * en(ji,jj,1)**rmm * zdep(ji,jj)**rnn * tmask(ji,jj,1) + zd_lw(ji,jj,1) = psi(ji,jj,1) + zd_up(ji,jj,1) = 0._wp + zdiag(ji,jj,1) = 1._wp + ! + ! Neumann condition at k=2, zdiag zd_lw not defined/used on the halo + zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) ! Remove zd_lw from zdiag + zd_lw(ji,jj,2) = 0._wp + ! + ! Set psi vertical flux at the surface: + zkar (ji,jj) = rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*(gdept_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)))/zhsro(ji,jj) )) ! Lengh scale slope + zdep (ji,jj) = ((zhsro(ji,jj) + (gdept_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)))) / zhsro(ji,jj))**(rmm*ra_sf) + zflxs(ji,jj) = (rnn + (1._wp-zice_fra(ji,jj))*rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(ji,jj)) & + & *(1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1*zdep(ji,jj))**(2._wp*rmm/3._wp-1_wp) + zdep (ji,jj) = rsbc_psi1 * (zwall_psi(ji,jj,1)*p_avm(ji,jj,1)+zwall_psi(ji,jj,2)*p_avm(ji,jj,2)) * & + & ustar2_surf(ji,jj)**rmm * zkar(ji,jj)**rnn * (zhsro(ji,jj) + (gdept_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))))**(rnn-1.) + zflxs(ji,jj) = zdep(ji,jj) * zflxs(ji,jj) + psi (ji,jj,2) = psi(ji,jj,2) + zflxs(ji,jj) / (e3w_0(ji,jj,2)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + ! + END SELECT + + ! Bottom boundary condition on psi + ! -------------------------------- + ! +!!gm should be done for ISF (top boundary cond.) +!!gm so, totally new staff needed ===>>> think about that ! +! + SELECT CASE ( nn_bc_bot ) ! bottom boundary + ! + CASE ( 0 ) ! Dirichlet + ! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = vkarmn * r_z0_bot + ! ! Balance between the production and the dissipation terms + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point + ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 + zdep(ji,jj) = vkarmn * r_z0_bot + psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn + zd_lw(ji,jj,ibot) = 0._wp + zd_up(ji,jj,ibot) = 0._wp + zdiag(ji,jj,ibot) = 1._wp + ! + ! Just above last level, Dirichlet condition again (GOTM like) + zdep(ji,jj) = vkarmn * ( r_z0_bot + (e3t_0(ji,jj,ibotm1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,ibotm1))) ) + psi (ji,jj,ibotm1) = rc0**rpp * en(ji,jj,ibot )**rmm * zdep(ji,jj)**rnn + zd_lw(ji,jj,ibotm1) = 0._wp + zd_up(ji,jj,ibotm1) = 0._wp + zdiag(ji,jj,ibotm1) = 1._wp + END DO ; END DO + ! + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + IF ( mikt(ji,jj) > 1 ) THEN + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! + zdep(ji,jj) = vkarmn * r_z0_top + psi (ji,jj,itop) = rc0**rpp * en(ji,jj,itop)**rmm *zdep(ji,jj)**rnn + zd_lw(ji,jj,itop) = 0._wp + zd_up(ji,jj,itop) = 0._wp + zdiag(ji,jj,itop) = 1._wp + ! + ! Just above last level, Dirichlet condition again (GOTM like) + zdep(ji,jj) = vkarmn * ( r_z0_top + (e3t_0(ji,jj,itopp1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,itopp1))) ) + psi (ji,jj,itopp1) = rc0**rpp * en(ji,jj,itop )**rmm *zdep(ji,jj)**rnn + zd_lw(ji,jj,itopp1) = 0._wp + zd_up(ji,jj,itopp1) = 0._wp + zdiag(ji,jj,itopp1) = 1._wp + END IF + END DO ; END DO + END IF + ! + CASE ( 1 ) ! Neumman boundary condition + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point + ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 + ! + ! Bottom level Dirichlet condition: + zdep(ji,jj) = vkarmn * r_z0_bot + psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn + ! + zd_lw(ji,jj,ibot) = 0._wp + zd_up(ji,jj,ibot) = 0._wp + zdiag(ji,jj,ibot) = 1._wp + ! + ! Just above last level: Neumann condition with flux injection + zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) ! Remove zd_up from zdiag + zd_up(ji,jj,ibotm1) = 0. + ! + ! Set psi vertical flux at the bottom: + zdep(ji,jj) = r_z0_bot + 0.5_wp*(e3t_0(ji,jj,ibotm1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,ibotm1))) + zflxb = rsbc_psi2 * ( p_avm(ji,jj,ibot) + p_avm(ji,jj,ibotm1) ) & + & * (0.5_wp*(en(ji,jj,ibot)+en(ji,jj,ibotm1)))**rmm * zdep(ji,jj)**(rnn-1._wp) + psi(ji,jj,ibotm1) = psi(ji,jj,ibotm1) + zflxb / (e3w_0(ji,jj,ibotm1)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + ! + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + IF ( mikt(ji,jj) > 1 ) THEN + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! + ! Bottom level Dirichlet condition: + zdep(ji,jj) = vkarmn * r_z0_top + psi (ji,jj,itop) = rc0**rpp * en(ji,jj,itop)**rmm *zdep(ji,jj)**rnn + ! + zd_lw(ji,jj,itop) = 0._wp + zd_up(ji,jj,itop) = 0._wp + zdiag(ji,jj,itop) = 1._wp + ! + ! Just below cavity level: Neumann condition with flux + ! injection + zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) ! Remove zd_up from zdiag + zd_up(ji,jj,itopp1) = 0._wp + ! + ! Set psi vertical flux below cavity: + zdep(ji,jj) = r_z0_top + 0.5_wp*(e3t_0(ji,jj,itopp1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,itopp1))) + zflxb = rsbc_psi2 * ( p_avm(ji,jj,itop) + p_avm(ji,jj,itopp1)) & + & * (0.5_wp*(en(ji,jj,itop)+en(ji,jj,itopp1)))**rmm * zdep(ji,jj)**(rnn-1._wp) + psi(ji,jj,itopp1) = psi(ji,jj,itopp1) + zflxb / (e3w_0(ji,jj,itopp1)*(1._wp+r3t(ji,jj,Kmm))) + END IF + END DO ; END DO + END IF + + ! + END SELECT + + ! Matrix inversion + ! ---------------- + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) + END DO ; END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 + zd_lw(ji,jj,jk) = psi(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) + END DO ; END DO ; END DO + DO jk = jpkm1, 2, -1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk) + END DO ; END DO ; END DO + + ! Set dissipation + !---------------- + + SELECT CASE ( nn_clos ) + ! + CASE( 0 ) ! k-kl (Mellor-Yamada) + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin) + END DO ; END DO ; END DO + ! + CASE( 1 ) ! k-eps + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + eps(ji,jj,jk) = psi(ji,jj,jk) + END DO ; END DO ; END DO + ! + CASE( 2 ) ! k-w + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + eps(ji,jj,jk) = rc04 * en(ji,jj,jk) * psi(ji,jj,jk) + END DO ; END DO ; END DO + ! + CASE( 3 ) ! generic + zcoef = rc0**( 3._wp + rpp/rnn ) + zex1 = ( 1.5_wp + rmm/rnn ) + zex2 = -1._wp / rnn + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + eps(ji,jj,jk) = zcoef * en(ji,jj,jk)**zex1 * psi(ji,jj,jk)**zex2 + END DO ; END DO ; END DO + ! + END SELECT + + ! Limit dissipation rate under stable stratification + ! -------------------------------------------------- + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! Note that this set boundary conditions on hmxl_n at the same time + ! limitation + eps (ji,jj,jk) = MAX( eps(ji,jj,jk), rn_epsmin ) + hmxl_n(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / eps(ji,jj,jk) + END DO ; END DO ; END DO + IF( ln_length_lim ) THEN ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated) + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zrn2 = MAX( rn2(ji,jj,jk), rsmall ) + hmxl_n(ji,jj,jk) = MIN( rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), hmxl_n(ji,jj,jk) ) + END DO ; END DO ; END DO + ENDIF + + ! + ! Stability function and vertical viscosity and diffusivity + ! --------------------------------------------------------- + ! + SELECT CASE ( nn_stab_func ) + ! + CASE ( 0 , 1 ) ! Galperin or Kantha-Clayson stability functions + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ! zcof = l²/q² + zcof = hmxl_b(ji,jj,jk) * hmxl_b(ji,jj,jk) / ( 2._wp*eb(ji,jj,jk) ) + ! Gh = -N²l²/q² + gh = - rn2(ji,jj,jk) * zcof + gh = MIN( gh, rgh0 ) + gh = MAX( gh, rghmin ) + ! Stability functions from Kantha and Clayson (if C2=C3=0 => Galperin) + sh = ra2*( 1._wp-6._wp*ra1/rb1 ) / ( 1.-3.*ra2*gh*(6.*ra1+rb2*( 1._wp-rc3 ) ) ) + sm = ( rb1**(-1._wp/3._wp) + ( 18._wp*ra1*ra1 + 9._wp*ra1*ra2*(1._wp-rc2) )*sh*gh ) / (1._wp-9._wp*ra1*ra2*gh) + ! + ! Store stability function in zstt and zstm + zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) + zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + CASE ( 2, 3 ) ! Canuto stability functions + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ! zcof = l²/q² + zcof = hmxl_b(ji,jj,jk)*hmxl_b(ji,jj,jk) / ( 2._wp * eb(ji,jj,jk) ) + ! Gh = -N²l²/q² + gh = - rn2(ji,jj,jk) * zcof + gh = MIN( gh, rgh0 ) + gh = MAX( gh, rghmin ) + gh = gh * rf6 + ! Gm = M²l²/q² Shear number + shr = p_sh2(ji,jj,jk) / MAX( p_avm(ji,jj,jk), rsmall ) + gm = MAX( shr * zcof , 1.e-10 ) + gm = gm * rf6 + gm = MIN ( (rd0 - rd1*gh + rd3*gh*gh) / (rd2-rd4*gh) , gm ) + ! Stability functions from Canuto + rcff = rd0 - rd1*gh +rd2*gm + rd3*gh*gh - rd4*gh*gm + rd5*gm*gm + sm = (rs0 - rs1*gh + rs2*gm) / rcff + sh = (rs4 - rs5*gh + rs6*gm) / rcff + ! + ! Store stability function in zstt and zstm + zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) + zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + END SELECT + + ! Boundary conditions on stability functions for momentum (Neumann): + ! Lines below are useless if GOTM style Dirichlet conditions are used + + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zstm(ji,jj,1) = zstm(ji,jj,2) + zstm(ji,jj,jpk) = 0. ! default value, in case jpk > mbkt(ji,jj)+1 + ! ! Not needed but avoid a bug when looking for undefined values (-fpe0) + END DO ; END DO + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! update bottom with good values + zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj)) + END DO ; END DO + + zstt(:,:, 1) = wmask(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls), 1) ! default value not needed but avoid a bug when looking for undefined values (-fpe0) + zstt(:,:,jpk) = wmask(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) ! default value not needed but avoid a bug when looking for undefined values (-fpe0) + +!!gm should be done for ISF (top boundary cond.) +!!gm so, totally new staff needed!!gm + + ! Compute diffusivities/viscosities + ! The computation below could be restrained to jk=2 to jpkm1 if GOTM style Dirichlet conditions are used + ! -> yes BUT p_avm(:,:1) and p_avm(:,:jpk) are used when we compute zd_lw(:,:2) and zd_up(:,:jpkm1). These values are + ! later overwritten by surface/bottom boundaries conditions, so we don't really care of p_avm(:,:1) and p_avm(:,:jpk) + ! for zd_lw and zd_up but they have to be defined to avoid a bug when looking for undefined values (-fpe0) + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zsqen = SQRT( 2._wp * en(ji,jj,jk) ) * hmxl_n(ji,jj,jk) + zavt = zsqen * zstt(ji,jj,jk) + zavm = zsqen * zstm(ji,jj,jk) + p_avt(ji,jj,jk) = MAX( zavt, avtb(jk) ) * wmask(ji,jj,jk) ! apply mask for zdfmxl routine + p_avm(ji,jj,jk) = MAX( zavm, avmb(jk) ) ! Note that avm is not masked at the surface and the bottom + END DO ; END DO ; END DO + p_avt(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),1) = 0._wp + ! + ! IF(sn_cfctl%l_prtctl) THEN + !CALL prt_ctl( tab3d_1=en , clinfo1=' gls - e: ', tab3d_2=p_avt, clinfo2=' t: ' ) + !CALL prt_ctl( tab3d_1=p_avm, clinfo1=' gls - m: ' ) + ! ENDIF + ! + END SUBROUTINE zdf_gls + + + SUBROUTINE zdf_gls_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_gls_init *** + !! + !! ** Purpose : Initialization of the vertical eddy diffivity and + !! viscosity computed using a GLS turbulent closure scheme + !! + !! ** Method : Read the namzdf_gls namelist and check the parameters + !! + !! ** input : Namlist namzdf_gls + !! + !! ** Action : Increase by 1 the nstop flag is setting problem encounter + !! + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indices + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp):: zcr ! local scalar + !! + NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, & + & rn_clim_galp, ln_sigpsi, rn_hsro, rn_hsri, & + & nn_mxlice, rn_crban, rn_charn, rn_frac_hs, & + & nn_bc_surf, nn_bc_bot, nn_z0_met, nn_z0_ice, & + & nn_stab_func, nn_clos + !!---------------------------------------------------------- + ! + READ ( numnam_ref, namzdf_gls, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_gls in reference namelist' ) + + READ ( numnam_cfg, namzdf_gls, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_gls ) + + IF(lwp) THEN !* Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_gls_init : GLS turbulent closure scheme' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_gls : set gls mixing parameters' + WRITE(numout,*) ' minimum value of en rn_emin = ', rn_emin + WRITE(numout,*) ' minimum value of eps rn_epsmin = ', rn_epsmin + WRITE(numout,*) ' Limit dissipation rate under stable stratif. ln_length_lim = ', ln_length_lim + WRITE(numout,*) ' Galperin limit (Standard: 0.53, Holt: 0.26) rn_clim_galp = ', rn_clim_galp + WRITE(numout,*) ' TKE Surface boundary condition nn_bc_surf = ', nn_bc_surf + WRITE(numout,*) ' TKE Bottom boundary condition nn_bc_bot = ', nn_bc_bot + WRITE(numout,*) ' Modify psi Schmidt number (wb case) ln_sigpsi = ', ln_sigpsi + WRITE(numout,*) ' Craig and Banner coefficient rn_crban = ', rn_crban + WRITE(numout,*) ' Charnock coefficient rn_charn = ', rn_charn + WRITE(numout,*) ' Surface roughness formula nn_z0_met = ', nn_z0_met + WRITE(numout,*) ' surface wave breaking under ice nn_z0_ice = ', nn_z0_ice + SELECT CASE( nn_z0_ice ) + CASE( 0 ) ; WRITE(numout,*) ' ==>>> no impact of ice cover on surface wave breaking' + CASE( 1 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weigthed by 1-TANH( fr_i(:,:) * 10 )' + CASE( 2 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weighted by 1-fr_i(:,:)' + CASE( 3 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weighted by 1-MIN( 1, 4 * fr_i(:,:) )' + CASE DEFAULT + CALL ctl_stop( 'zdf_gls_init: wrong value for nn_z0_ice, should be 0,1,2, or 3') + END SELECT + WRITE(numout,*) ' Wave height frac. (used if nn_z0_met=2) rn_frac_hs = ', rn_frac_hs + WRITE(numout,*) ' Stability functions nn_stab_func = ', nn_stab_func + WRITE(numout,*) ' Type of closure nn_clos = ', nn_clos + WRITE(numout,*) ' Surface roughness (m) rn_hsro = ', rn_hsro + WRITE(numout,*) ' type of scaling under sea-ice nn_mxlice = ', nn_mxlice + IF( nn_mxlice == 1 ) & + WRITE(numout,*) ' Ice-ocean roughness (used if nn_z0_ice/=0) rn_hsri = ', rn_hsri + SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice + CASE( 0 ) ; WRITE(numout,*) ' ==>>> No scaling under sea-ice' + CASE( 1 ) ; WRITE(numout,*) ' ==>>> scaling with constant sea-ice thickness' + CASE( 2 ) ; WRITE(numout,*) ' ==>>> scaling with mean sea-ice thickness' + CASE( 3 ) ; WRITE(numout,*) ' ==>>> scaling with max sea-ice thickness' + CASE DEFAULT + CALL ctl_stop( 'zdf_tke_init: wrong value for nn_mxlice, should be 0,1,2,3 ') + END SELECT + WRITE(numout,*) + ENDIF + + ! !* allocate GLS arrays + IF( zdf_gls_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_gls_init : unable to allocate arrays' ) + + ! !* Check of some namelist values + IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_bc_surf is 0 or 1' ) + IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_bc_surf is 0 or 1' ) + IF( nn_z0_met < 0 .OR. nn_z0_met > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_z0_met is 0, 1, 2 or 3' ) + IF( nn_z0_met == 3 .AND. .NOT. (ln_wave .AND. ln_sdw ) ) CALL ctl_stop( 'zdf_gls_init: nn_z0_met=3 requires ln_wave=T and ln_sdw=T' ) + IF( nn_stab_func < 0 .OR. nn_stab_func > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_stab_func is 0, 1, 2 and 3' ) + IF( nn_clos < 0 .OR. nn_clos > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_clos is 0, 1, 2 or 3' ) + + SELECT CASE ( nn_clos ) !* set the parameters for the chosen closure + ! + CASE( 0 ) ! k-kl (Mellor-Yamada) + ! + IF(lwp) WRITE(numout,*) ' ==>> k-kl closure chosen (i.e. closed to the classical Mellor-Yamada)' + IF(lwp) WRITE(numout,*) + rpp = 0._wp + rmm = 1._wp + rnn = 1._wp + rsc_tke = 1.96_wp + rsc_psi = 1.96_wp + rpsi1 = 0.9_wp + rpsi3p = 1._wp + rpsi2 = 0.5_wp + ! + SELECT CASE ( nn_stab_func ) + CASE( 0, 1 ) ; rpsi3m = 2.53_wp ! G88 or KC stability functions + CASE( 2 ) ; rpsi3m = 2.62_wp ! Canuto A stability functions + CASE( 3 ) ; rpsi3m = 2.38 ! Canuto B stability functions (caution : constant not identified) + END SELECT + ! + CASE( 1 ) ! k-eps + ! + IF(lwp) WRITE(numout,*) ' ==>> k-eps closure chosen' + IF(lwp) WRITE(numout,*) + rpp = 3._wp + rmm = 1.5_wp + rnn = -1._wp + rsc_tke = 1._wp + rsc_psi = 1.2_wp ! Schmidt number for psi + rpsi1 = 1.44_wp + rpsi3p = 1._wp + rpsi2 = 1.92_wp + ! + SELECT CASE ( nn_stab_func ) + CASE( 0, 1 ) ; rpsi3m = -0.52_wp ! G88 or KC stability functions + CASE( 2 ) ; rpsi3m = -0.629_wp ! Canuto A stability functions + CASE( 3 ) ; rpsi3m = -0.566 ! Canuto B stability functions + END SELECT + ! + CASE( 2 ) ! k-omega + ! + IF(lwp) WRITE(numout,*) ' ==>> k-omega closure chosen' + IF(lwp) WRITE(numout,*) + rpp = -1._wp + rmm = 0.5_wp + rnn = -1._wp + rsc_tke = 2._wp + rsc_psi = 2._wp + rpsi1 = 0.555_wp + rpsi3p = 1._wp + rpsi2 = 0.833_wp + ! + SELECT CASE ( nn_stab_func ) + CASE( 0, 1 ) ; rpsi3m = -0.58_wp ! G88 or KC stability functions + CASE( 2 ) ; rpsi3m = -0.64_wp ! Canuto A stability functions + CASE( 3 ) ; rpsi3m = -0.64_wp ! Canuto B stability functions caution : constant not identified) + END SELECT + ! + CASE( 3 ) ! generic + ! + IF(lwp) WRITE(numout,*) ' ==>> generic closure chosen' + IF(lwp) WRITE(numout,*) + rpp = 2._wp + rmm = 1._wp + rnn = -0.67_wp + rsc_tke = 0.8_wp + rsc_psi = 1.07_wp + rpsi1 = 1._wp + rpsi3p = 1._wp + rpsi2 = 1.22_wp + ! + SELECT CASE ( nn_stab_func ) + CASE( 0, 1 ) ; rpsi3m = 0.1_wp ! G88 or KC stability functions + CASE( 2 ) ; rpsi3m = 0.05_wp ! Canuto A stability functions + CASE( 3 ) ; rpsi3m = 0.05_wp ! Canuto B stability functions caution : constant not identified) + END SELECT + ! + END SELECT + + ! + SELECT CASE ( nn_stab_func ) !* set the parameters of the stability functions + ! + CASE ( 0 ) ! Galperin stability functions + ! + IF(lwp) WRITE(numout,*) ' ==>> Stability functions from Galperin' + rc2 = 0._wp + rc3 = 0._wp + rc_diff = 1._wp + rc0 = 0.5544_wp + rcm_sf = 0.9884_wp + rghmin = -0.28_wp + rgh0 = 0.0233_wp + rghcri = 0.02_wp + ! + CASE ( 1 ) ! Kantha-Clayson stability functions + ! + IF(lwp) WRITE(numout,*) ' ==>> Stability functions from Kantha-Clayson' + rc2 = 0.7_wp + rc3 = 0.2_wp + rc_diff = 1._wp + rc0 = 0.5544_wp + rcm_sf = 0.9884_wp + rghmin = -0.28_wp + rgh0 = 0.0233_wp + rghcri = 0.02_wp + ! + CASE ( 2 ) ! Canuto A stability functions + ! + IF(lwp) WRITE(numout,*) ' ==>> Stability functions from Canuto A' + rs0 = 1.5_wp * rl1 * rl5*rl5 + rs1 = -rl4*(rl6+rl7) + 2._wp*rl4*rl5*(rl1-(1._wp/3._wp)*rl2-rl3) + 1.5_wp*rl1*rl5*rl8 + rs2 = -(3._wp/8._wp) * rl1*(rl6*rl6-rl7*rl7) + rs4 = 2._wp * rl5 + rs5 = 2._wp * rl4 + rs6 = (2._wp/3._wp) * rl5 * ( 3._wp*rl3*rl3 - rl2*rl2 ) - 0.5_wp * rl5*rl1 * (3._wp*rl3-rl2) & + & + 0.75_wp * rl1 * ( rl6 - rl7 ) + rd0 = 3._wp * rl5*rl5 + rd1 = rl5 * ( 7._wp*rl4 + 3._wp*rl8 ) + rd2 = rl5*rl5 * ( 3._wp*rl3*rl3 - rl2*rl2 ) - 0.75_wp*(rl6*rl6 - rl7*rl7 ) + rd3 = rl4 * ( 4._wp*rl4 + 3._wp*rl8) + rd4 = rl4 * ( rl2 * rl6 - 3._wp*rl3*rl7 - rl5*(rl2*rl2 - rl3*rl3 ) ) + rl5*rl8 * ( 3._wp*rl3*rl3 - rl2*rl2 ) + rd5 = 0.25_wp * ( rl2*rl2 - 3._wp *rl3*rl3 ) * ( rl6*rl6 - rl7*rl7 ) + rc0 = 0.5268_wp + rf6 = 8._wp / (rc0**6._wp) + rc_diff = SQRT(2._wp) / (rc0**3._wp) + rcm_sf = 0.7310_wp + rghmin = -0.28_wp + rgh0 = 0.0329_wp + rghcri = 0.03_wp + ! + CASE ( 3 ) ! Canuto B stability functions + ! + IF(lwp) WRITE(numout,*) ' ==>> Stability functions from Canuto B' + rs0 = 1.5_wp * rm1 * rm5*rm5 + rs1 = -rm4 * (rm6+rm7) + 2._wp * rm4*rm5*(rm1-(1._wp/3._wp)*rm2-rm3) + 1.5_wp * rm1*rm5*rm8 + rs2 = -(3._wp/8._wp) * rm1 * (rm6*rm6-rm7*rm7 ) + rs4 = 2._wp * rm5 + rs5 = 2._wp * rm4 + rs6 = (2._wp/3._wp) * rm5 * (3._wp*rm3*rm3-rm2*rm2) - 0.5_wp * rm5*rm1*(3._wp*rm3-rm2) + 0.75_wp * rm1*(rm6-rm7) + rd0 = 3._wp * rm5*rm5 + rd1 = rm5 * (7._wp*rm4 + 3._wp*rm8) + rd2 = rm5*rm5 * (3._wp*rm3*rm3 - rm2*rm2) - 0.75_wp * (rm6*rm6 - rm7*rm7) + rd3 = rm4 * ( 4._wp*rm4 + 3._wp*rm8 ) + rd4 = rm4 * ( rm2*rm6 -3._wp*rm3*rm7 - rm5*(rm2*rm2 - rm3*rm3) ) + rm5 * rm8 * ( 3._wp*rm3*rm3 - rm2*rm2 ) + rd5 = 0.25_wp * ( rm2*rm2 - 3._wp*rm3*rm3 ) * ( rm6*rm6 - rm7*rm7 ) + rc0 = 0.5268_wp !! rc0 = 0.5540_wp (Warner ...) to verify ! + rf6 = 8._wp / ( rc0**6._wp ) + rc_diff = SQRT(2._wp)/(rc0**3.) + rcm_sf = 0.7470_wp + rghmin = -0.28_wp + rgh0 = 0.0444_wp + rghcri = 0.0414_wp + ! + END SELECT + + ! !* Set Schmidt number for psi diffusion in the wave breaking case + ! ! See Eq. (13) of Carniel et al, OM, 30, 225-239, 2009 + ! ! or Eq. (17) of Burchard, JPO, 31, 3133-3145, 2001 + IF( ln_sigpsi ) THEN + ra_sf = -1.5 ! Set kinetic energy slope, then deduce rsc_psi and rl_sf + ! Verification: retrieve Burchard (2001) results by uncomenting the line below: + ! Note that the results depend on the value of rn_cm_sf which is constant (=rc0) in his work + ! ra_sf = -SQRT(2./3.*rc0**3./rn_cm_sf*rn_sc_tke)/vkarmn + rsc_psi0 = rsc_tke/(24.*rpsi2)*(-1.+(4.*rnn + ra_sf*(1.+4.*rmm))**2./(ra_sf**2.)) + ELSE + rsc_psi0 = rsc_psi + ENDIF + + ! !* Shear free turbulence parameters + ! + ra_sf = -4._wp*rnn*SQRT(rsc_tke) / ( (1._wp+4._wp*rmm)*SQRT(rsc_tke) & + & - SQRT(rsc_tke + 24._wp*rsc_psi0*rpsi2 ) ) + + IF ( rn_crban==0._wp ) THEN + rl_sf = vkarmn + ELSE + rl_sf = rc0 * SQRT(rc0/rcm_sf) * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm**2_wp) * rsc_tke & + & + 12._wp*rsc_psi0*rpsi2 - (1._wp + 4._wp*rmm) & + & *SQRT(rsc_tke*(rsc_tke & + & + 24._wp*rsc_psi0*rpsi2)) ) & + & /(12._wp*rnn**2.) ) + ENDIF + + ! + IF(lwp) THEN !* Control print + WRITE(numout,*) + WRITE(numout,*) ' Limit values :' + WRITE(numout,*) ' Parameter m = ', rmm + WRITE(numout,*) ' Parameter n = ', rnn + WRITE(numout,*) ' Parameter p = ', rpp + WRITE(numout,*) ' rpsi1 = ', rpsi1 + WRITE(numout,*) ' rpsi2 = ', rpsi2 + WRITE(numout,*) ' rpsi3m = ', rpsi3m + WRITE(numout,*) ' rpsi3p = ', rpsi3p + WRITE(numout,*) ' rsc_tke = ', rsc_tke + WRITE(numout,*) ' rsc_psi = ', rsc_psi + WRITE(numout,*) ' rsc_psi0 = ', rsc_psi0 + WRITE(numout,*) ' rc0 = ', rc0 + WRITE(numout,*) + WRITE(numout,*) ' Shear free turbulence parameters:' + WRITE(numout,*) ' rcm_sf = ', rcm_sf + WRITE(numout,*) ' ra_sf = ', ra_sf + WRITE(numout,*) ' rl_sf = ', rl_sf + ENDIF + + ! !* Constants initialization + rc02 = rc0 * rc0 ; rc02r = 1. / rc02 + rc03 = rc02 * rc0 + rc04 = rc03 * rc0 + rsbc_tke1 = -3._wp/2._wp*rn_crban*ra_sf*rl_sf ! Dirichlet + Wave breaking + rsbc_tke2 = rn_Dt * rn_crban / rl_sf ! Neumann + Wave breaking + zcr = MAX(rsmall, rsbc_tke1**(1./(-ra_sf*3._wp/2._wp))-1._wp ) + rtrans = 0.2_wp / zcr ! Ad. inverse transition length between log and wave layer + rsbc_zs1 = rn_charn/grav ! Charnock formula for surface roughness + rsbc_zs2 = rn_frac_hs / 0.85_wp / grav * 665._wp ! Rascle formula for surface roughness + rsbc_psi1 = -0.5_wp * rn_Dt * rc0**(rpp-2._wp*rmm) / rsc_psi + rsbc_psi2 = -0.5_wp * rn_Dt * rc0**rpp * rnn * vkarmn**rnn / rsc_psi ! Neumann + NO Wave breaking + ! + rfact_tke = -0.5_wp / rsc_tke * rn_Dt ! Cst used for the Diffusion term of tke + rfact_psi = -0.5_wp / rsc_psi * rn_Dt ! Cst used for the Diffusion term of tke + ! + ! !* Wall proximity function +!!gm tmask or wmask ???? + zwall(:,:,:) = 1._wp * tmask(:,:,:) + + ! !* read or initialize all required files + CALL gls_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, hmxl_n) + ! + END SUBROUTINE zdf_gls_init + + + SUBROUTINE gls_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE gls_rst *** + !! + !! ** Purpose : Read or write TKE file (en) in restart file + !! + !! ** Method : use of IOM library + !! if the restart does not contain TKE, en is either + !! set to rn_emin or recomputed (nn_igls/=0) + !!---------------------------------------------------------------------- + USE zdf_oce , ONLY : en, avt_k, avm_k ! ocean vertical physics + !! + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + INTEGER :: jit, jk ! dummy loop indices + INTEGER :: id1, id2, id3, id4 + INTEGER :: ji, jj, ikbu, ikbv + REAL(wp):: cbx, cby + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + ! ! --------------- + IF( ln_rstart ) THEN !* Read the restart file + id1 = iom_varid( numror, 'en' , ldstop = .FALSE. ) + id2 = iom_varid( numror, 'avt_k' , ldstop = .FALSE. ) + id3 = iom_varid( numror, 'avm_k' , ldstop = .FALSE. ) + id4 = iom_varid( numror, 'hmxl_n', ldstop = .FALSE. ) + ! + IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! all required arrays exist + CALL iom_get( numror, jpdom_auto, 'en' , en , kfill = jpfillcopy ) ! we devide by en -> must be != 0. + CALL iom_get( numror, jpdom_auto, 'avt_k' , avt_k ) + CALL iom_get( numror, jpdom_auto, 'avm_k' , avm_k ) + CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n, kfill = jpfillcopy ) ! we devide by hmxl_n -> must be != 0. + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>> previous run without GLS scheme, set en and hmxl_n to background values' + en (:,:,:) = rn_emin + hmxl_n(:,:,:) = 0.05_wp + ! avt_k, avm_k already set to the background value in zdf_phy_init + ENDIF + ELSE !* Start from rest + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>> start from rest, set en and hmxl_n by background values' + en (:,:,:) = rn_emin + hmxl_n(:,:,:) = 0.05_wp + ! avt_k, avm_k already set to the background value in zdf_phy_init + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) '---- gls-rst ----' + CALL iom_rstput( kt, nitrst, numrow, 'en' , en ) + CALL iom_rstput( kt, nitrst, numrow, 'avt_k' , avt_k ) + CALL iom_rstput( kt, nitrst, numrow, 'avm_k' , avm_k ) + CALL iom_rstput( kt, nitrst, numrow, 'hmxl_n', hmxl_n ) + ! + ENDIF + ! + END SUBROUTINE gls_rst + + !!====================================================================== +END MODULE zdfgls diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfiwm.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfiwm.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8df6167445e212eb618bc652947080d3b6903989 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfiwm.f90 @@ -0,0 +1,467 @@ + + + + + + + + + + + + + +MODULE zdfiwm + !!======================================================================== + !! *** MODULE zdfiwm *** + !! Ocean physics: Internal gravity wave-driven vertical mixing + !!======================================================================== + !! History : 1.0 ! 2004-04 (L. Bessieres, G. Madec) Original code + !! - ! 2006-08 (A. Koch-Larrouy) Indonesian strait + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.6 ! 2016-03 (C. de Lavergne) New param: internal wave-driven mixing + !! 4.0 ! 2017-04 (G. Madec) renamed module, remove the old param. and the CPP keys + !! 4.0 ! 2020-12 (C. de Lavergne) Update param to match published one + !! 4.0 ! 2021-09 (C. de Lavergne) Add energy from trapped and shallow internal tides + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_iwm : global momentum & tracer Kz with wave induced Kz + !! zdf_iwm_init : global momentum & tracer Kz with wave induced Kz + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE zdf_oce ! ocean vertical physics variables + USE zdfddm ! ocean vertical physics: double diffusive mixing + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE eosbn2 ! ocean equation of state + USE phycst ! physical constants + ! + USE fldread ! field read + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE iom ! I/O Manager + USE lib_mpp ! MPP library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_iwm ! called in step module + PUBLIC zdf_iwm_init ! called in nemogcm module + + ! !!* Namelist namzdf_iwm : internal wave-driven mixing * + LOGICAL :: ln_mevar ! variable (=T) or constant (=F) mixing efficiency + LOGICAL :: ln_tsdiff ! account for differential T/S wave-driven mixing (=T) or not (=F) + + REAL(wp):: r1_6 = 1._wp / 6._wp + REAL(wp):: rnu = 1.4e-6_wp ! molecular kinematic viscosity + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ebot_iwm ! bottom-intensified dissipation above abyssal hills (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ecri_iwm ! bottom-intensified dissipation at topographic slopes (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ensq_iwm ! dissipation scaling with squared buoyancy frequency (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: esho_iwm ! dissipation due to shoaling internal tides (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbot_iwm ! decay scale for abyssal hill dissipation (m) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hcri_iwm ! inverse decay scale for topographic slope dissipation (m-1) + + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfiwm.F90 15533 2021-11-24 12:07:20Z cdllod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_iwm_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_iwm_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( ebot_iwm(jpi,jpj), ecri_iwm(jpi,jpj), ensq_iwm(jpi,jpj) , & + & esho_iwm(jpi,jpj), hbot_iwm(jpi,jpj), hcri_iwm(jpi,jpj) , STAT=zdf_iwm_alloc ) + ! + CALL mpp_sum ( 'zdfiwm', zdf_iwm_alloc ) + IF( zdf_iwm_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_iwm_alloc: failed to allocate arrays' ) + END FUNCTION zdf_iwm_alloc + + + SUBROUTINE zdf_iwm( kt, Kmm, p_avm, p_avt, p_avs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_iwm *** + !! + !! ** Purpose : add to the vertical mixing coefficients the effect of + !! breaking internal waves. + !! + !! ** Method : - internal wave-driven vertical mixing is given by: + !! Kz_wave = min( f( Reb = zemx_iwm / (Nu * N^2) ), 100 cm2/s ) + !! where zemx_iwm is the 3D space distribution of the wave-breaking + !! energy and Nu the molecular kinematic viscosity. + !! The function f(Reb) is linear (constant mixing efficiency) + !! if the namelist parameter ln_mevar = F and nonlinear if ln_mevar = T. + !! + !! - Compute zemx_iwm, the 3D power density that allows to compute + !! Reb and therefrom the wave-induced vertical diffusivity. + !! This is divided into four components: + !! 1. Bottom-intensified dissipation at topographic slopes, expressed + !! as an exponential decay above the bottom. + !! zemx_iwm(z) = ( ecri_iwm / rho0 ) * EXP( -(H-z)/hcri_iwm ) + !! / ( 1. - EXP( - H/hcri_iwm ) ) * hcri_iwm + !! where hcri_iwm is the characteristic length scale of the bottom + !! intensification, ecri_iwm a static 2D map of available power, and + !! H the ocean depth. + !! 2. Bottom-intensified dissipation above abyssal hills, expressed + !! as an algebraic decay above bottom. + !! zemx_iwm(z) = ( ebot_iwm / rho0 ) * ( 1 + hbot_iwm/H ) + !! / ( 1 + (H-z)/hbot_iwm )^2 + !! where hbot_iwm is the characteristic length scale of the bottom + !! intensification and ebot_iwm is a static 2D map of available power. + !! 3. Dissipation scaling in the vertical with the squared buoyancy + !! frequency (N^2). + !! zemx_iwm(z) = ( ensq_iwm / rho0 ) * rn2(z) + !! / ZSUM( rn2 * e3w ) + !! where ensq_iwm is a static 2D map of available power. + !! 4. Dissipation due to shoaling internal tides, scaling in the + !! vertical with the buoyancy frequency (N). + !! zemx_iwm(z) = ( esho_iwm / rho0 ) * sqrt(rn2(z)) + !! / ZSUM( sqrt(rn2) * e3w ) + !! where esho_iwm is a static 2D map of available power. + !! + !! - update the model vertical eddy viscosity and diffusivity: + !! avt = avt + av_wave + !! avs = avs + av_wave + !! avm = avm + av_wave + !! + !! - if namelist parameter ln_tsdiff = T, account for differential mixing: + !! avs = avs + av_wave * diffusivity_ratio(Reb) + !! + !! ** Action : - avt, avs, avm, increased by internal wave-driven mixing + !! + !! References : de Lavergne et al. JAMES 2020, https://doi.org/10.1029/2020MS002065 + !! de Lavergne et al. JPO 2016, https://doi.org/10.1175/JPO-D-14-0259.1 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), SAVE :: zztmp + ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zfact ! Used for vertical structure + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zReb ! Turbulence intensity parameter + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zemx_iwm ! local energy density available for mixing (W/kg) + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zav_ratio ! S/T diffusivity ratio (only for ln_tsdiff=T) + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zav_wave ! Internal wave-induced diffusivity + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d ! 3D workspace used for iom_put + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D - - - - + !!---------------------------------------------------------------------- + ! + ! !* Initialize appropriately certain variables + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zav_ratio(ji,jj,jk) = 1._wp * wmask(ji,jj,jk) ! important to set it to 1 here + END DO ; END DO ; END DO + IF( iom_use("emix_iwm") ) zemx_iwm (:,:,:) = 0._wp + IF( iom_use("av_wave") .OR. sn_cfctl%l_prtctl ) zav_wave (:,:,:) = 0._wp + ! + ! ! ----------------------------- ! + ! ! Internal wave-driven mixing ! (compute zav_wave) + ! ! ----------------------------- ! + ! + ! !* 'cri' component: distribute energy over the time-varying + ! !* ocean depth using an exponential decay from the seafloor. + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! part independent of the level + IF( (ht_0(ji,jj)*(1._wp+r3t(ji,jj,Kmm))) /= 0._wp ) THEN ; zfact(ji,jj) = ecri_iwm(ji,jj) * r1_rho0 / ( 1._wp - EXP( -(ht_0(ji,jj)*(1._wp+r3t(ji,jj,Kmm))) * hcri_iwm(ji,jj) ) ) + ELSE ; zfact(ji,jj) = 0._wp + ENDIF + END DO ; END DO + + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! complete with the level-dependent part + zemx_iwm(ji,jj,jk) = zfact(ji,jj) * ( EXP( ( (gdept_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm))) - (ht_0(ji,jj)*(1._wp+r3t(ji,jj,Kmm))) ) * hcri_iwm(ji,jj) ) & + & - EXP( ( (gdept_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm))) - (ht_0(ji,jj)*(1._wp+r3t(ji,jj,Kmm))) ) * hcri_iwm(ji,jj) ) & + & ) * wmask(ji,jj,jk) / (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO ; END DO + + !* 'bot' component: distribute energy over the time-varying + !* ocean depth using an algebraic decay above the seafloor. + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! part independent of the level + IF( (ht_0(ji,jj)*(1._wp+r3t(ji,jj,Kmm))) /= 0._wp ) THEN ; zfact(ji,jj) = ebot_iwm(ji,jj) * ( 1._wp + hbot_iwm(ji,jj) / (ht_0(ji,jj)*(1._wp+r3t(ji,jj,Kmm))) ) * r1_rho0 + ELSE ; zfact(ji,jj) = 0._wp + ENDIF + END DO ; END DO + + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! complete with the level-dependent part + zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + & + & zfact(ji,jj) * ( 1._wp / ( 1._wp + ( (ht_0(ji,jj)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm))) ) / hbot_iwm(ji,jj) ) & + & - 1._wp / ( 1._wp + ( (ht_0(ji,jj)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm))) ) / hbot_iwm(ji,jj) ) & + & ) * wmask(ji,jj,jk) / (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO ; END DO + + !* 'nsq' component: distribute energy over the time-varying + !* ocean depth as proportional to rn2 + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zfact(ji,jj) = 0._wp + END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! part independent of the level + zfact(ji,jj) = zfact(ji,jj) + (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * MAX( 0._wp, rn2(ji,jj,jk) ) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + IF( zfact(ji,jj) /= 0._wp ) zfact(ji,jj) = ensq_iwm(ji,jj) * r1_rho0 / zfact(ji,jj) + END DO ; END DO + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! complete with the level-dependent part + zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + zfact(ji,jj) * MAX( 0._wp, rn2(ji,jj,jk) ) + END DO ; END DO ; END DO + + !* 'sho' component: distribute energy over the time-varying + !* ocean depth as proportional to sqrt(rn2) + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zfact(ji,jj) = 0._wp + END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! part independent of the level + zfact(ji,jj) = zfact(ji,jj) + (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * SQRT( MAX( 0._wp, rn2(ji,jj,jk) ) ) + END DO ; END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + IF( zfact(ji,jj) /= 0._wp ) zfact(ji,jj) = esho_iwm(ji,jj) * r1_rho0 / zfact(ji,jj) + END DO ; END DO + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! complete with the level-dependent part + zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + zfact(ji,jj) * SQRT( MAX( 0._wp, rn2(ji,jj,jk) ) ) + END DO ; END DO ; END DO + + ! Calculate turbulence intensity parameter Reb + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zReb(ji,jj,jk) = zemx_iwm(ji,jj,jk) / MAX( 1.e-20_wp, rnu * rn2(ji,jj,jk) ) + END DO ; END DO ; END DO + ! + ! Define internal wave-induced diffusivity + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zav_wave(ji,jj,jk) = zReb(ji,jj,jk) * r1_6 * rnu ! This corresponds to a constant mixing efficiency of 1/6 + END DO ; END DO ; END DO + ! + IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224) regimes + IF( zReb(ji,jj,jk) > 480.00_wp ) THEN + zav_wave(ji,jj,jk) = 3.6515_wp * rnu * SQRT( zReb(ji,jj,jk) ) + ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN + zav_wave(ji,jj,jk) = 0.052125_wp * rnu * zReb(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) + ENDIF + END DO ; END DO ; END DO + ENDIF + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! Bound diffusivity by molecular value and 100 cm2/s + zav_wave(ji,jj,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(ji,jj,jk) ), 1.e-2_wp ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! ! ----------------------- ! + ! ! Update mixing coefs ! + ! ! ----------------------- ! + ! + IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! Calculate S/T diffusivity ratio as a function of Reb (else it is set to 1) + zav_ratio(ji,jj,jk) = ( 0.505_wp + & + & 0.495_wp * TANH( 0.92_wp * ( LOG10( MAX( 1.e-20, zReb(ji,jj,jk) * 5._wp * r1_6 ) ) - 0.60_wp ) ) & + & ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + CALL iom_put( "av_ratio", zav_ratio ) + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) !* update momentum & tracer diffusivity with wave-driven mixing + p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zav_wave(ji,jj,jk) * zav_ratio(ji,jj,jk) + p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zav_wave(ji,jj,jk) + p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + zav_wave(ji,jj,jk) + END DO ; END DO ; END DO + ! !* output internal wave-driven mixing coefficient + CALL iom_put( "av_wave", zav_wave ) + !* output useful diagnostics: Kz*N^2 , + ! vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm) + IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN + ALLOCATE( z2d(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) , z3d(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) ) + z2d(:,:) = 0._wp ; z3d(:,:,:) = 0._wp ! Initialisation for iom_put + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + z3d(ji,jj,jk) = MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) + z2d(ji,jj) = z2d(ji,jj) + rho0 * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * z3d(ji,jj,jk) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + CALL iom_put( "bflx_iwm", z3d ) + CALL iom_put( "pcmap_iwm", z2d ) + DEALLOCATE( z2d , z3d ) + ENDIF + CALL iom_put( "emix_iwm", zemx_iwm ) + + ! + IF( kt == nit000 ) THEN !* Control print at first time-step: diagnose the energy consumed by zav_wave + IF( .NOT. l_istiled .OR. ntile == 1 ) zztmp = 0._wp ! Do only on the first tile + DO jk = 2, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zztmp = zztmp + (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * e1e2t(ji,jj) & + & * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) + END DO ; END DO ; END DO + + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + CALL mpp_sum( 'zdfiwm', zztmp ) + zztmp = rho0 * zztmp ! Global integral of rho0 * Kz * N^2 = power contributing to mixing + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'zdf_iwm : Internal wave-driven mixing (iwm)' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) + WRITE(numout,*) ' Total power consumption by av_wave = ', zztmp * 1.e-12_wp, 'TW' + ENDIF + ENDIF + ENDIF + + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' iwm - av_wave: ', tab3d_2=avt, clinfo2=' avt: ') + ! + END SUBROUTINE zdf_iwm + + + SUBROUTINE zdf_iwm_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_iwm_init *** + !! + !! ** Purpose : Initialization of the internal wave-driven vertical mixing, reading + !! of input power maps and decay length scales in a netcdf file. + !! + !! ** Method : - Read the namzdf_iwm namelist and check the parameters + !! + !! - Read the input data in a NetCDF file (zdfiwm_forcing.nc) with variables: + !! 'power_bot' bottom-intensified dissipation above abyssal hills + !! 'power_cri' bottom-intensified dissipation at topographic slopes + !! 'power_nsq' dissipation scaling with squared buoyancy frequency + !! 'power_sho' dissipation due to shoaling internal tides + !! 'scale_bot' decay scale for abyssal hill dissipation + !! 'scale_cri' decay scale for topographic-slope dissipation + !! + !! ** input : - Namlist namzdf_iwm + !! - NetCDF file : zdfiwm_forcing.nc + !! + !! ** Action : - Increase by 1 the nstop flag is setting problem encounter + !! - Define ebot_iwm, ecri_iwm, ensq_iwm, esho_iwm, hbot_iwm, hcri_iwm + !! + !! References : de Lavergne et al. JAMES 2020, https://doi.org/10.1029/2020MS002065 + !!---------------------------------------------------------------------- + INTEGER :: ifpr ! dummy loop indices + INTEGER :: inum ! local integer + INTEGER :: ios + ! + CHARACTER(len=256) :: cn_dir ! Root directory for location of ssr files + INTEGER, PARAMETER :: jpiwm = 6 ! maximum number of variables to read + INTEGER, PARAMETER :: jp_mpb = 1 + INTEGER, PARAMETER :: jp_mpc = 2 + INTEGER, PARAMETER :: jp_mpn = 3 + INTEGER, PARAMETER :: jp_mps = 4 + INTEGER, PARAMETER :: jp_dsb = 5 + INTEGER, PARAMETER :: jp_dsc = 6 + ! + TYPE(FLD_N), DIMENSION(jpiwm) :: slf_iwm ! array of namelist informations + TYPE(FLD_N) :: sn_mpb, sn_mpc, sn_mpn, sn_mps ! information about Mixing Power field to be read + TYPE(FLD_N) :: sn_dsb, sn_dsc ! information about Decay Scale field to be read + TYPE(FLD ), DIMENSION(jpiwm) :: sf_iwm ! structure of input fields (file informations, fields read) + ! + REAL(wp), DIMENSION(jpi,jpj,4) :: ztmp + REAL(wp), DIMENSION(4) :: zdia + ! + NAMELIST/namzdf_iwm/ ln_mevar, ln_tsdiff, & + & cn_dir, sn_mpb, sn_mpc, sn_mpn, sn_mps, sn_dsb, sn_dsc + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namzdf_iwm, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist' ) + ! + READ ( numnam_cfg, namzdf_iwm, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_iwm ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_iwm_init : internal wave-driven mixing' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_iwm : set wave-driven mixing parameters' + WRITE(numout,*) ' Variable (T) or constant (F) mixing efficiency = ', ln_mevar + WRITE(numout,*) ' Differential internal wave-driven mixing (T) or not (F) = ', ln_tsdiff + ENDIF + + ! This internal-wave-driven mixing parameterization elevates avt and avm in the interior, and + ! ensures that avt remains larger than its molecular value (=1.4e-7). Therefore, avtb should + ! be set here to a very small value, and avmb to its (uniform) molecular value (=1.4e-6). + avmb(:) = rnu ! molecular value + avtb(:) = 1.e-10_wp ! very small diffusive minimum (background avt is specified in zdf_iwm) + avtb_2d(:,:) = 1._wp ! uniform + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) ' Force the background value applied to avm & avt in TKE to be everywhere ', & + & 'the viscous molecular value & a very small diffusive value, resp.' + ENDIF + + ! ! allocate iwm arrays + IF( zdf_iwm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_iwm_init : unable to allocate iwm arrays' ) + ! + ! store namelist information in an array + slf_iwm(jp_mpb) = sn_mpb ; slf_iwm(jp_mpc) = sn_mpc ; slf_iwm(jp_mpn) = sn_mpn ; slf_iwm(jp_mps) = sn_mps + slf_iwm(jp_dsb) = sn_dsb ; slf_iwm(jp_dsc) = sn_dsc + ! + DO ifpr= 1, jpiwm + ALLOCATE( sf_iwm(ifpr)%fnow(jpi,jpj,1) ) + IF( slf_iwm(ifpr)%ln_tint ) ALLOCATE( sf_iwm(ifpr)%fdta(jpi,jpj,1,2) ) + END DO + + ! fill sf_iwm with sf_iwm and control print + CALL fld_fill( sf_iwm, slf_iwm , cn_dir, 'zdfiwm_init', 'iwm input file', 'namiwm' ) + + ! ! hard-coded default values + sf_iwm(jp_mpb)%fnow(:,:,1) = 1.e-10_wp + sf_iwm(jp_mpc)%fnow(:,:,1) = 1.e-10_wp + sf_iwm(jp_mpn)%fnow(:,:,1) = 1.e-5_wp + sf_iwm(jp_mps)%fnow(:,:,1) = 1.e-10_wp + sf_iwm(jp_dsb)%fnow(:,:,1) = 100._wp + sf_iwm(jp_dsc)%fnow(:,:,1) = 100._wp + + ! ! read necessary fields + CALL fld_read( nit000, 1, sf_iwm ) + + ebot_iwm(:,:) = sf_iwm(1)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation above abyssal hills [W/m2] + ecri_iwm(:,:) = sf_iwm(2)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation at topographic slopes [W/m2] + ensq_iwm(:,:) = sf_iwm(3)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation scaling with N^2 [W/m2] + esho_iwm(:,:) = sf_iwm(4)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation due to shoaling [W/m2] + hbot_iwm(:,:) = sf_iwm(5)%fnow(:,:,1) ! spatially variable decay scale for abyssal hill dissipation [m] + hcri_iwm(:,:) = sf_iwm(6)%fnow(:,:,1) ! spatially variable decay scale for topographic-slope [m] + + hcri_iwm(:,:) = 1._wp / hcri_iwm(:,:) ! only the inverse height is used, hence calculated here once for all + + ! diags + ztmp(:,:,1) = e1e2t(:,:) * ebot_iwm(:,:) + ztmp(:,:,2) = e1e2t(:,:) * ecri_iwm(:,:) + ztmp(:,:,3) = e1e2t(:,:) * ensq_iwm(:,:) + ztmp(:,:,4) = e1e2t(:,:) * esho_iwm(:,:) + + zdia(1:4) =glob_sum_vec( 'zdfiwm', REAL(ztmp(:,:,1:4),dp) ) + + IF(lwp) THEN + WRITE(numout,*) ' Dissipation above abyssal hills: ', zdia(1) * 1.e-12_wp, 'TW' + WRITE(numout,*) ' Dissipation along topographic slopes: ', zdia(2) * 1.e-12_wp, 'TW' + WRITE(numout,*) ' Dissipation scaling with N^2: ', zdia(3) * 1.e-12_wp, 'TW' + WRITE(numout,*) ' Dissipation due to shoaling: ', zdia(4) * 1.e-12_wp, 'TW' + ENDIF + ! + END SUBROUTINE zdf_iwm_init + + !!====================================================================== +END MODULE zdfiwm diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfmfc.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfmfc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c4ac5e6a623d51073e17c9e71a0d4114d159a8e9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfmfc.f90 @@ -0,0 +1,515 @@ + + + + + + + + + + + + + +MODULE zdfmfc + !!====================================================================== + !! *** MODULE zdfmfc *** + !! Ocean physics: Mass-Flux scheme parameterization of Convection: + !! Non-local transport for the convective ocean boundary + !! layer. Subgrid-scale large eddies are represented by a + !! mass-flux contribution (ln_zdfmfc = .TRUE.) + !!====================================================================== + !! History : NEMO ! + !! 3.6 ! 2016-06 (H. Giordani, R. Bourdallé-Badie) Original code + !! 4.2 ! 2020-12 (H. Giordani, R. Bourdallé-Badie) adapt to NEM04.2 + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! tra_mfc : Compute the Mass Flux and trends of T/S + !! diag_mfc : Modify diagonal of trazdf Matrix + !! rhs_mfc : Modify RHS of trazdf Matrix + !! zdf_mfc_init : initialization, namelist read, and parameters control + !!---------------------------------------------------------------------- + ! + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domvvl ! ocean space and time domain : variable volume layer + USE domzgr + USE zdf_oce ! ocean vertical physics + USE sbc_oce ! surface boundary condition: ocean + USE phycst ! physical constants + USE eosbn2 ! equation of state (eos routine) + USE zdfmxl ! mixed layer + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP manager + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE timing ! Timing + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_mfc ! routine called in step module + PUBLIC diag_mfc ! routine called in trazdf module + PUBLIC rhs_mfc ! routine called in trazdf module + PUBLIC zdf_mfc_init ! routine called in nemo module + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: edmfa, edmfb, edmfc !: diagonal term of the matrix. + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: edmftra !: y term for matrix inversion + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: edmfm !: y term for matrix inversion + ! + !! ** Namelist namzdf_edmf ** + REAL(wp) :: rn_cemf ! entrain of T/S + REAL(wp) :: rn_cwmf ! detrain of T/S + REAL(wp) :: rn_cent ! entrain of the convective mass flux + REAL(wp) :: rn_cdet ! detrain of the convective mass flux + REAL(wp) :: rn_cap ! Factor of computation for convective area (negative => area constant) + REAL(wp) :: App_max ! Maximum of the convective area + LOGICAL, PUBLIC, SAVE :: ln_edmfuv !: EDMF flag for velocity ! + ! + !! * Substitutions + + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.2 , NEMO Consortium (2018) + !! $Id: zdfmfc.F90 13783 2020-20-02 15:30:22Z rbourdal $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_mfc_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_edmf_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( edmfa(jpi,jpj,jpk) , edmfb(jpi,jpj,jpk) , edmfc(jpi,jpj,jpk) & + & , edmftra(jpi,jpj,jpk,2), edmfm(jpi,jpj,jpk) , STAT= zdf_mfc_alloc ) + ! + IF( lk_mpp ) CALL mpp_sum ( 'zdfmfc', zdf_mfc_alloc ) + IF( zdf_mfc_alloc /= 0 ) CALL ctl_warn('zdf_mfc_alloc: failed to allocate arrays') + END FUNCTION zdf_mfc_alloc + + + SUBROUTINE tra_mfc( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_mfc *** + !! + !! ** Purpose : Compute a mass flux, depending on surface flux, over + !! the instable part of the water column. + !! + !! ** Method : Compute surface instability and mix tracers until stable level + !! + !! + !! ** Action : Compute convection plume and (ta,sa)-trends for trazdf (EDMF scheme) + !! + !! References : + !! Giordani, Bourdallé-Badie and Madec JAMES 2020 + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk,2) :: ztsp ! T/S of the plume + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk,2) :: ztse ! T/S at W point + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zrwp ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zrwp2 ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zapp ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zedmf ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zepsT, zepsW ! + ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zustar, zustar2 ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zuws, zvws, zsws, zfnet ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zfbuo, zrautbm1, zrautb, zraupl + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zwpsurf ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zop0 , zsp0 ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zrwp_0, zrwp2_0 ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zapp0 ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zphp, zph, zphpm1, zphm1, zNHydro + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zhcmo ! + ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zn2 ! N^2 + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),2 ) :: zab, zabm1, zabp ! alpha and beta + + REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value + + REAL(wp) :: zrho, zrhop + REAL(wp) :: zcnh, znum, zden, zcoef1, zcoef2 + REAL(wp) :: zca, zcb, zcd, zrw, zxl, zcdet, zctre + REAL(wp) :: zaw, zbw, zxw + REAL(wp) :: alpha + ! + INTEGER, INTENT(in ) :: kt ! ocean time-step index ! + ! + INTEGER :: ji, jj, jk ! dummy loop arguments + ! + !------------------------------------------------------------------ + ! Initialisation of coefficients + !------------------------------------------------------------------ + zca = 1._wp + zcb = 1._wp + zcd = 1._wp + + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + !------------------------------------------------------------------ + ! Surface boundary condition + !------------------------------------------------------------------ + ! surface Stress + !-------------------- + zuws(ji,jj) = utau(ji,jj) * r1_rho0 + zvws(ji,jj) = vtau(ji,jj) * r1_rho0 + zustar2(ji,jj) = SQRT(zuws(ji,jj)*zuws(ji,jj)+zvws(ji,jj)*zvws(ji,jj)) + zustar(ji,jj) = SQRT(zustar2(ji,jj)) + + ! Heat Flux + !-------------------- + zfnet(ji,jj) = qns(ji,jj) + qsr(ji,jj) + zfnet(ji,jj) = zfnet(ji,jj) / (rho0 * rcp) + + ! Water Flux + !--------------------- + zsws(ji,jj) = emp(ji,jj) + + !------------------------------------------- + ! Initialisation of prognostic variables + !------------------------------------------- + zrwp (ji,jj,:) = 0._wp ; zrwp2(ji,jj,:) = 0._wp ; zedmf(ji,jj,:) = 0._wp + zph (ji,jj) = 0._wp ; zphm1(ji,jj) = 0._wp ; zphpm1(ji,jj) = 0._wp + ztsp(ji,jj,:,:)= 0._wp + + ! Tracers inside plume (ztsp) and environment (ztse) + ztsp(ji,jj,1,jp_tem) = pts(ji,jj,1,jp_tem,Kmm) * tmask(ji,jj,1) + ztsp(ji,jj,1,jp_sal) = pts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1) + ztse(ji,jj,1,jp_tem) = pts(ji,jj,1,jp_tem,Kmm) * tmask(ji,jj,1) + ztse(ji,jj,1,jp_sal) = pts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1) + END DO ; END DO + + CALL eos( ztse(:,:,1,:) , zrautb(:,:) ) + CALL eos( ztsp(:,:,1,:) , zraupl(:,:) ) + + !------------------------------------------- + ! Boundary Condition of Mass Flux (plume velo.; convective area, entrain/detrain) + !------------------------------------------- + zhcmo(:,:) = (e3t_0(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),1)*(1._wp+r3t(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),Kmm)*tmask(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),1))) + zfbuo(:,:) = 0._wp + WHERE ( ABS(zrautb(:,:)) > 1.e-20 ) zfbuo(:,:) = & + & grav * ( 2.e-4_wp *zfnet(:,:) & + & - 7.6E-4_wp*pts(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),1,jp_sal,Kmm) & + & * zsws(:,:)/zrautb(:,:)) * zhcmo(:,:) + + zedmf(:,:,1) = -0.065_wp*(ABS(zfbuo(:,:)))**(1._wp/3._wp)*SIGN(1.,zfbuo(:,:)) + zedmf(:,:,1) = MAX(0., zedmf(:,:,1)) + + zwpsurf(:,:) = 2._wp/3._wp*zustar(:,:) + 2._wp/3._wp*ABS(zfbuo(:,:))**(1._wp/3._wp) + zwpsurf(:,:) = MAX(1.e-5_wp,zwpsurf(:,:)) + zwpsurf(:,:) = MIN(1.,zwpsurf(:,:)) + + zapp(:,:,:) = App_max + WHERE(zwpsurf .NE. 0.) zapp(:,:,1) = MIN(MAX(0.,zedmf(:,:,1)/zwpsurf(:,:)), App_max) + + zedmf(:,:,1) = 0._wp + zrwp (:,:,1) = 0._wp + zrwp2(:,:,1) = 0._wp + zepsT(:,:,:) = 0.001_wp + zepsW(:,:,:) = 0.001_wp + + + !-------------------------------------------------------------- + ! Compute plume properties + ! In the same loop on vert. levels computation of: + ! - Vertical velocity: zWp + ! - Convective Area: zAp + ! - Tracers properties inside the plume (if necessary): ztp + !--------------------------------------------------------------- + + DO jk= 2, jpk + + ! Compute the buoyancy acceleration on T-points at jk-1 + zrautbm1(:,:) = zrautb(:,:) + CALL eos( REAL(pts (:,:,jk ,:,Kmm),sp) , zrautb(:,:) ) + CALL eos( ztsp(:,:,jk-1,: ) , zraupl(:,:) ) + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + zphm1(ji,jj) = zphm1(ji,jj) + grav * zrautbm1(ji,jj) * (e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj, Kmm)*tmask(ji,jj,jk-1))) + zphpm1(ji,jj) = zphpm1(ji,jj) + grav * zraupl(ji,jj) * (e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj, Kmm)*tmask(ji,jj,jk-1))) + zph(ji,jj) = zphm1(ji,jj) + grav * zrautb(ji,jj) * (e3t_0(ji,jj,jk )*(1._wp+r3t(ji,jj, Kmm)*tmask(ji,jj,jk ))) + zph(ji,jj) = MAX( zph(ji,jj), zepsilon) + END DO ; END DO + + WHERE(zrautbm1 .NE. 0.) zfbuo(:,:) = grav * (zraupl(:,:) - zrautbm1(:,:)) / zrautbm1(:,:) + + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + + ! Compute Environment of Plume. Interpolation T/S (before time step) on W-points + zrw = ((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))) & + & / ((gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)))) + ztse(ji,jj,jk,:) = (pts(ji,jj,jk,:,Kmm) * zrw + pts(ji,jj,jk-1,:,Kmm)*(1._wp - zrw) )*tmask(ji,jj,jk) + + !--------------------------------------------------------------- + ! Compute the vertical velocity on W-points + !--------------------------------------------------------------- + + ! Non-hydrostatic pressure terms in the wp2 equation + zcnh = 0.2_wp + znum = 0.5_wp + zcnh - & + (zcnh*grav*zraupl(ji,jj)/zph(ji,jj)+zcb*zepsW(ji,jj,jk-1)) & + *(e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1)))*0.5_wp + zden = 0.5_wp + zcnh + & + (zcnh*grav*zraupl(ji,jj)/zph(ji,jj)+zcb*zepsW(ji,jj,jk-1)) & + *(e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1)))*0.5_wp + + zcoef1 = zca*(e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1))) / zden + zcoef2 = znum/zden + + ! compute wp2 + zrwp2(ji,jj,jk) = zcoef1*zfbuo(ji,jj) & + + zcoef2*zrwp2(ji,jj,jk-1) + zrwp2(ji,jj,jk) = MAX ( zrwp2(ji,jj,jk)*wmask(ji,jj,jk) , 0.) + zrwp (ji,jj,jk) = SQRT( zrwp2(ji,jj,jk) ) + + !---------------------------------------------------------------------------------- + ! Compute convective area on W-point + ! Compute vertical profil of the convective area with mass conservation hypothesis + ! If rn_cap negative => constant value on the water column. + !---------------------------------------------------------------------------------- + IF( rn_cap .GT. 0. ) THEN + + zxw = MAX(zrwp(ji,jj,jk-1), zrwp(ji,jj,jk) ) + IF( zxw > 0. ) THEN + + zxl = (zrwp(ji,jj,jk-1)-zrwp(ji,jj,jk))/((e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1)))*zxw) + IF (zxl .LT. 0._wp) THEN + zctre = -1.*rn_cap*zxl + zcdet = 0._wp + ELSE + zctre = 0._wp + zcdet = rn_cap*zxl + END IF + zapp(ji,jj,jk) = zapp(ji,jj,jk-1)* & + & (1._wp + (zxl + zctre - zcdet )*(e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1)))) + ELSE + zapp(ji,jj,jk) = App_max + END IF + zapp(ji,jj,jk) = MIN( MAX(zapp(ji,jj,jk),0.), App_max) + ELSE + zapp(ji,jj,jk) = -1. * rn_cap + END IF + + ! Compute Mass Flux on W-point + zedmf(ji,jj,jk) = -zapp(ji,jj,jk) * zrwp(ji,jj,jk)* wmask(ji,jj,jk) + + ! Compute Entrainment coefficient + IF(rn_cemf .GT. 0.) THEN + zxw = 0.5_wp*(zrwp(ji,jj,jk-1)+ zrwp(ji,jj,jk) ) + zepsT(ji,jj,jk) = 0.01_wp + IF( zxw > 0. ) THEN + zepsT(ji,jj,jk) = zepsT(ji,jj,jk) + & + & ABS( zrwp(ji,jj,jk-1)-zrwp(ji,jj,jk) ) & + & / ( (e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1))) * zxw ) + zepsT(ji,jj,jk) = zepsT(ji,jj,jk) * rn_cemf * wmask(ji,jj,jk) + ENDIF + ELSE + zepsT(ji,jj,jk) = -rn_cemf + ENDIF + + ! Compute the detrend coef for velocity (on W-point and not T-points, bug ???) + IF(rn_cwmf .GT. 0.) THEN + zepsW(ji,jj,jk) = rn_cwmf * zepsT(ji,jj,jk) + ELSE + zepsW(ji,jj,jk) = -rn_cwmf + ENDIF + + !--------------------------------------------------------------- + ! Compute the plume properties on T-points + !--------------------------------------------------------------- + IF(zrwp (ji,jj,jk) .LT. 1.e-12_wp .AND. zrwp (ji,jj,jk-1) .LT. 1.e-12_wp) THEN + ztsp(ji,jj,jk-1,jp_tem) = pts(ji,jj,jk-1,jp_tem,Kmm) + ztsp(ji,jj,jk-1,jp_sal) = pts(ji,jj,jk-1,jp_sal,Kmm) + ENDIF + + zcoef1 = (1._wp-zepsT(ji,jj,jk)*(1._wp-zrw)*(e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))*wmask(ji,jj,jk ) ) & + & / (1._wp+zepsT(ji,jj,jk)*zrw*(e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))*wmask(ji,jj,jk) ) + ! + zcoef2 = zepsT(ji,jj,jk)*(e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))*wmask(ji,jj,jk) & + & / (1._wp+zepsT(ji,jj,jk)*zrw*(e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)))*wmask(ji,jj,jk)) + ! + ztsp(ji,jj,jk,jp_tem) = (zcoef1 * ztsp(ji,jj,jk-1,jp_tem) + & + & zcoef2 * ztse(ji,jj,jk ,jp_tem) )*tmask(ji,jj,jk) + ztsp(ji,jj,jk,jp_sal) = (zcoef1 * ztsp(ji,jj,jk-1,jp_sal) + & + & zcoef2 * ztse(ji,jj,jk ,jp_sal) )*tmask(ji,jj,jk) + + END DO ; END DO + END DO ! end of loop on jpk + + ! Compute Mass Flux on T-point + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + edmfm(ji,jj,jk) = (zedmf(ji,jj,jk+1) + zedmf(ji,jj,jk) )*0.5_wp + END DO ; END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + edmfm(ji,jj,jpk) = zedmf(ji,jj,jpk) + END DO ; END DO + + ! Save variable (on T point) + CALL iom_put( "mf_Tp" , ztsp(:,:,:,jp_tem) ) ! Save plume temperature + CALL iom_put( "mf_Sp" , ztsp(:,:,:,jp_sal) ) ! Save plume salinity + CALL iom_put( "mf_mf" , edmfm(:,:,:) ) ! Save Mass Flux + ! Save variable (on W point) + CALL iom_put( "mf_wp" , zrwp (:,:,:) ) ! Save convective velocity in the plume + CALL iom_put( "mf_app", zapp (:,:,:) ) ! Save convective area + + !================================================================================= + ! Computation of a tridiagonal matrix and right hand side terms of the linear system + !================================================================================= + DO jk = 1, jpk ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + edmfa(ji,jj,jk) = 0._wp + edmfb(ji,jj,jk) = 0._wp + edmfc(ji,jj,jk) = 0._wp + edmftra(ji,jj,jk,:) = 0._wp + END DO ; END DO ; END DO + + !--------------------------------------------------------------- + ! Diagonal terms + !--------------------------------------------------------------- + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + edmfa(ji,jj,jk) = 0._wp + edmfb(ji,jj,jk) = -edmfm(ji,jj,jk ) / (e3w_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) + edmfc(ji,jj,jk) = edmfm(ji,jj,jk+1) / (e3w_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + edmfa(ji,jj,jpk) = -edmfm(ji,jj,jpk-1) / (e3w_0(ji,jj,jpk)*(1._wp+r3t(ji,jj,Kmm))) + edmfb(ji,jj,jpk) = edmfm(ji,jj,jpk ) / (e3w_0(ji,jj,jpk)*(1._wp+r3t(ji,jj,Kmm))) + edmfc(ji,jj,jpk) = 0._wp + END DO ; END DO + + !--------------------------------------------------------------- + ! right hand side term for Temperature + !--------------------------------------------------------------- + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + edmftra(ji,jj,jk,1) = - edmfm(ji,jj,jk ) * ztsp(ji,jj,jk ,jp_tem) / (e3w_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) & + & + edmfm(ji,jj,jk+1) * ztsp(ji,jj,jk+1,jp_tem) / (e3w_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + edmftra(ji,jj,jpk,1) = - edmfm(ji,jj,jpk-1) * ztsp(ji,jj,jpk-1,jp_tem) / (e3w_0(ji,jj,jpk)*(1._wp+r3t(ji,jj,Kmm))) & + & + edmfm(ji,jj,jpk ) * ztsp(ji,jj,jpk ,jp_tem) / (e3w_0(ji,jj,jpk)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + + !--------------------------------------------------------------- + ! Right hand side term for Salinity + !--------------------------------------------------------------- + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + edmftra(ji,jj,jk,2) = - edmfm(ji,jj,jk ) * ztsp(ji,jj,jk ,jp_sal) / (e3w_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) & + & + edmfm(ji,jj,jk+1) * ztsp(ji,jj,jk+1,jp_sal) / (e3w_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO ; END DO + DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) + edmftra(ji,jj,jpk,2) = - edmfm(ji,jj,jpk-1) * ztsp(ji,jj,jpk-1,jp_sal) / (e3w_0(ji,jj,jpk)*(1._wp+r3t(ji,jj,Kmm))) & + & + edmfm(ji,jj,jpk ) * ztsp(ji,jj,jpk ,jp_sal) / (e3w_0(ji,jj,jpk)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + ! + END SUBROUTINE tra_mfc + + + SUBROUTINE diag_mfc( zdiagi, zdiagd, zdiags, p2dt, Kaa ) + + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(inout) :: zdiags! inout: tridaig. terms + REAL(dp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(inout) :: zdiagi, zdiagd! inout: tridaig. terms + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + INTEGER , INTENT(in ) :: Kaa ! ocean time level indices + + INTEGER :: ji, jj, jk ! dummy loop arguments + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zdiagi(ji,jj,jk) = zdiagi(ji,jj,jk) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kaa)*tmask(ji,jj,jk))) * p2dt *edmfa(ji,jj,jk) + zdiags(ji,jj,jk) = zdiags(ji,jj,jk) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kaa)*tmask(ji,jj,jk))) * p2dt *edmfc(ji,jj,jk) + zdiagd(ji,jj,jk) = zdiagd(ji,jj,jk) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kaa)*tmask(ji,jj,jk))) * p2dt *edmfb(ji,jj,jk) + END DO ; END DO ; END DO + + END SUBROUTINE diag_mfc + + SUBROUTINE rhs_mfc( zrhs, jjn ) + + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: zrhs ! inout: rhs trend + INTEGER , INTENT(in ) :: jjn ! tracer indices + + INTEGER :: ji, jj, jk ! dummy loop arguments + + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + zrhs(ji,jj,jk) = zrhs(ji,jj,jk) + edmftra(ji,jj,jk,jjn) + END DO ; END DO ; END DO + + END SUBROUTINE rhs_mfc + + + + SUBROUTINE zdf_mfc_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_mfc_init *** + !! + !! ** Purpose : Initialization of the vertical eddy diffivity and + !! mass flux + !! + !! ** Method : Read the namzdf_mfc namelist and check the parameters + !! called at the first timestep (nit000) + !! + !! ** input : Namlist namzdf_mfc + !! + !! ** Action : Increase by 1 the nstop flag is setting problem encounter + !! + !!---------------------------------------------------------------------- + ! + INTEGER :: jk ! dummy loop indices + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp):: zcr ! local scalar + !! + NAMELIST/namzdf_mfc/ ln_edmfuv, rn_cemf, rn_cwmf, rn_cent, rn_cdet, rn_cap, App_max + !!---------------------------------------------------------- + ! + ! +! REWIND( numnam_ref ) ! Namelist namzdf_mfc in reference namelist : Vertical eddy diffivity mass flux + READ ( numnam_ref, namzdf_mfc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_edmf in reference namelist' ) + +! REWIND( numnam_cfg ) ! Namelist namzdf_mfc in configuration namelist : Vertical eddy diffivity mass flux + READ ( numnam_cfg, namzdf_mfc, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_edmf in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_mfc ) + + IF(lwp) THEN !* Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_mfc_init' + WRITE(numout,*) '~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_mfc : set eddy diffusivity Mass Flux Convection' + WRITE(numout,*) ' Apply mass flux on velocities (Not yet avail.) ln_edmfuv = ', ln_edmfuv + WRITE(numout,*) ' Coeff for entrain/detrain T/S of plume (Neg => cte) rn_cemf = ', rn_cemf + WRITE(numout,*) ' Coeff for entrain/detrain Wp of plume (Neg => cte) rn_cwmf = ', rn_cwmf + WRITE(numout,*) ' Coeff for entrain/detrain area of plume rn_cap = ', rn_cap + WRITE(numout,*) ' Coeff for entrain area of plume rn_cent = ', rn_cent + WRITE(numout,*) ' Coeff for detrain area of plume rn_cdet = ', rn_cdet + WRITE(numout,*) ' Max convective area App_max = ', App_max + ENDIF + !* allocate edmf arrays + IF( zdf_mfc_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_edmf_init : unable to allocate arrays' ) + edmfa(:,:,:) = 0._wp + edmfb(:,:,:) = 0._wp + edmfc(:,:,:) = 0._wp + edmftra(:,:,:,:) = 0._wp + ! + END SUBROUTINE zdf_mfc_init + + !!====================================================================== + + !!====================================================================== +END MODULE zdfmfc diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfmxl.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfmxl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e5eaac9b817925eaf7ea9a5c345dcd6c2d028fca --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfmxl.f90 @@ -0,0 +1,193 @@ + + + + + + + + + + + + + +MODULE zdfmxl + !!====================================================================== + !! *** MODULE zdfmxl *** + !! Ocean physics: mixed layer depth + !!====================================================================== + !! History : 1.0 ! 2003-08 (G. Madec) original code + !! 3.2 ! 2009-07 (S. Masson, G. Madec) IOM + merge of DO-loop + !! 3.7 ! 2012-03 (G. Madec) make public the density criteria for trdmxl + !! - ! 2014-02 (F. Roquet) mixed layer depth calculated using N2 instead of rhop + !!---------------------------------------------------------------------- + !! zdf_mxl : Compute the turbocline and mixed layer depths. + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE isf_oce ! ice shelf + USE dom_oce ! ocean space and time domain variables + USE trc_oce , ONLY: l_offline ! ocean space and time domain variables + USE zdf_oce ! ocean vertical physics + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE phycst ! physical constants + USE iom ! I/O library + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_mxl, zdf_mxl_turb, zdf_mxl_alloc ! called by zdfphy.F90 + + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmln !: number of level in the mixed layer (used by LDF, ZDF, TRD, TOP) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmld !: mixing layer depth (turbocline) [m] (used by TOP) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlp !: mixed layer depth (rho=rho0+zdcrit) [m] (used by LDF) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlpt !: depth of the last T-point inside the mixed layer [m] (used by LDF) + + REAL(wp), PUBLIC :: rho_c = 0.01_wp !: density criterion for mixed layer depth + REAL(wp), PUBLIC :: avt_c = 5.e-4_wp ! Kz criterion for the turbocline depth + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfmxl.F90 15249 2021-09-13 09:59:09Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_mxl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_mxl_alloc *** + !!---------------------------------------------------------------------- + zdf_mxl_alloc = 0 ! set to zero if no array to be allocated + IF( .NOT. ALLOCATED( nmln ) ) THEN + ALLOCATE( nmln(jpi,jpj), hmld(jpi,jpj), hmlp(jpi,jpj), hmlpt(jpi,jpj), STAT= zdf_mxl_alloc ) + ! + CALL mpp_sum ( 'zdfmxl', zdf_mxl_alloc ) + IF( zdf_mxl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_mxl_alloc: failed to allocate arrays.' ) + ! + ENDIF + END FUNCTION zdf_mxl_alloc + + + SUBROUTINE zdf_mxl( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdfmxl *** + !! + !! ** Purpose : Compute the mixed layer depth with density criteria. + !! + !! ** Method : The mixed layer depth is the shallowest W depth with + !! the density of the corresponding T point (just bellow) bellow a + !! given value defined locally as rho(10m) + rho_c + !! + !! ** Action : nmln, hmlp, hmlpt + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iik, ikt ! local integer + REAL(wp) :: zN2_c ! local scalar + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'zdf_mxl : mixed layer depth' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ENDIF + ! + ! w-level of the mixing and mixed layers + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + nmln(ji,jj) = nlb10 ! Initialization to the number of w ocean point + hmlp(ji,jj) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2 + END DO ; END DO + zN2_c = grav * rho_c * r1_rho0 ! convert density criteria into N^2 criteria + DO jk = nlb10, jpkm1 ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) ! Mixed layer level: w-level + ikt = mbkt(ji,jj) + hmlp(ji,jj) = & + & hmlp(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + IF( hmlp(ji,jj) < zN2_c ) nmln(ji,jj) = MIN( jk , ikt ) + 1 ! Mixed layer level + END DO ; END DO ; END DO + ! depth of the mixed layer + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + iik = nmln(ji,jj) + hmlp (ji,jj) = (gdepw_0(ji,jj,iik )*(1._wp+r3t(ji,jj,Kmm))) * ssmask(ji,jj) ! Mixed layer depth + hmlpt(ji,jj) = (gdept_0(ji,jj,iik-1)*(1._wp+r3t(ji,jj,Kmm))) * ssmask(ji,jj) ! depth of the last T-point inside the mixed layer + END DO ; END DO + ! + IF( .NOT.l_offline .AND. iom_use("mldr10_1") ) THEN + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF( ln_isfcav ) THEN ; CALL iom_put( "mldr10_1", hmlp - risfdep) ! mixed layer thickness + ELSE ; CALL iom_put( "mldr10_1", hmlp ) ! mixed layer depth + END IF + ENDIF + ENDIF + ! + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ' ) + ! + END SUBROUTINE zdf_mxl + + + SUBROUTINE zdf_mxl_turb( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_mxl_turb *** + !! + !! ** Purpose : Compute the turbocline depth. + !! + !! ** Method : The turbocline depth is the depth at which the vertical + !! eddy diffusivity coefficient (resulting from the vertical physics + !! alone, not the isopycnal part, see trazdf.F) fall below a given + !! value defined locally (avt_c here taken equal to 5 cm/s2 by default) + !! + !! ** Action : hmld + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iik ! local integer + INTEGER, DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: imld ! 2D workspace + !!---------------------------------------------------------------------- + ! + ! w-level of the turbocline and mixing layer (iom_use) + imld(:,:) = mbkt(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) + 1 ! Initialization to the number of w ocean point + DO jk = jpkm1, nlb10, -1 ; DO jj = ntsj-( 1), ntej+( 1) ; DO ji = ntsi-( 1), ntei+( 1) ! from the bottom to nlb10 + IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) ) imld(ji,jj) = jk ! Turbocline + END DO ; END DO ; END DO + ! depth of the mixing layer + DO jj = ntsj-( 1-( 1+ 1 )*nthb), ntej+( 1 -( 1 + 1)*ntht) ; DO ji = ntsi-( 1-( 1+ 1)*nthl), ntei+( 1-( 1+ 1)*nthr) + iik = imld(ji,jj) + hmld (ji,jj) = (gdepw_0(ji,jj,iik )*(1._wp+r3t(ji,jj,Kmm))) * ssmask(ji,jj) ! Turbocline depth + END DO ; END DO + ! + IF( .NOT.l_offline .AND. iom_use("mldkz5") ) THEN + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF( ln_isfcav ) THEN ; CALL iom_put( "mldkz5" , hmld - risfdep ) ! turbocline thickness + ELSE ; CALL iom_put( "mldkz5" , hmld ) ! turbocline depth + END IF + ENDIF + ENDIF + ! + END SUBROUTINE zdf_mxl_turb + !!====================================================================== +END MODULE zdfmxl diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfosm.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfosm.f90 new file mode 100644 index 0000000000000000000000000000000000000000..349728d6af5a048e1b139b91136d2bfdc4ff2a7b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfosm.f90 @@ -0,0 +1,3512 @@ + + + + + + + + + + + + + +MODULE zdfosm + !!====================================================================== + !! *** MODULE zdfosm *** + !! Ocean physics: vertical mixing coefficient compute from the OSMOSIS + !! turbulent closure parameterization + !!===================================================================== + !! History : NEMO 4.0 ! A. Grant, G. Nurser + !! 15/03/2017 Changed calculation of pycnocline thickness in unstable conditions and stable conditions AG + !! 15/03/2017 Calculation of pycnocline gradients for stable conditions changed. Pycnocline gradients now depend on stability of the OSBL. A.G + !! 06/06/2017 (1) Checks on sign of buoyancy jump in calculation of OSBL depth. A.G. + !! (2) Removed variable zbrad0, zbradh and zbradav since they are not used. + !! (3) Approximate treatment for shear turbulence. + !! Minimum values for zustar and zustke. + !! Add velocity scale, zvstr, that tends to zustar for large Langmuir numbers. + !! Limit maximum value for Langmuir number. + !! Use zvstr in definition of stability parameter zhol. + !! (4) Modified parametrization of entrainment flux, changing original coefficient 0.0485 for Langmuir contribution to 0.135 * zla + !! (5) For stable boundary layer add factor that depends on length of timestep to 'slow' collapse and growth. Make sure buoyancy jump not negative. + !! (6) For unstable conditions when growth is over multiple levels, limit change to maximum of one level per cycle through loop. + !! (7) Change lower limits for loops that calculate OSBL averages from 1 to 2. Large gradients between levels 1 and 2 can cause problems. + !! (8) Change upper limits from ibld-1 to ibld. + !! (9) Calculation of pycnocline thickness in unstable conditions. Check added to ensure that buoyancy jump is positive before calculating Ri. + !! (10) Thickness of interface layer at base of the stable OSBL set by Richardson number. Gives continuity in transition from unstable OSBL. + !! (11) Checks that buoyancy jump is poitive when calculating pycnocline profiles. + !! (12) Replace zwstrl with zvstr in calculation of eddy viscosity. + !! 27/09/2017 (13) Calculate Stokes drift and Stokes penetration depth from wave information + !! (14) Buoyancy flux due to entrainment changed to include contribution from shear turbulence. + !! 28/09/2017 (15) Calculation of Stokes drift moved into separate do-loops to allow for different options for the determining the Stokes drift to be added. + !! (16) Calculation of Stokes drift from windspeed for PM spectrum (for testing, commented out) + !! (17) Modification to Langmuir velocity scale to include effects due to the Stokes penetration depth (for testing, commented out) + !! ??/??/2018 (18) Revision to code structure, selected using key_osmldpth1. Inline code moved into subroutines. Changes to physics made, + !! (a) Pycnocline temperature and salinity profies changed for unstable layers + !! (b) The stable OSBL depth parametrization changed. + !! 16/05/2019 (19) Fox-Kemper parametrization of restratification through mixed layer eddies added to revised code. + !! 23/05/19 (20) Old code where key_osmldpth1` is *not* set removed, together with the key key_osmldpth1 + !! 4.2 ! 2021-05 (S. Mueller) Efficiency improvements, source-code clarity enhancements, and adaptation to tiling + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 'ln_zdfosm' OSMOSIS scheme + !!---------------------------------------------------------------------- + !! zdf_osm : update momentum and tracer Kz from osm scheme + !! zdf_osm_vertical_average : compute vertical averages over boundary layers + !! zdf_osm_velocity_rotation : rotate velocity components + !! zdf_osm_velocity_rotation_2d : rotation of 2d fields + !! zdf_osm_velocity_rotation_3d : rotation of 3d fields + !! zdf_osm_osbl_state : determine the state of the OSBL + !! zdf_osm_external_gradients : calculate gradients below the OSBL + !! zdf_osm_calculate_dhdt : calculate rate of change of hbl + !! zdf_osm_timestep_hbl : hbl timestep + !! zdf_osm_pycnocline_thickness : calculate thickness of pycnocline + !! zdf_osm_diffusivity_viscosity : compute eddy diffusivity and viscosity profiles + !! zdf_osm_fgr_terms : compute flux-gradient relationship terms + !! zdf_osm_pycnocline_buoyancy_profiles : calculate pycnocline buoyancy profiles + !! zdf_osm_zmld_horizontal_gradients : calculate horizontal buoyancy gradients for use with Fox-Kemper parametrization + !! zdf_osm_osbl_state_fk : determine state of OSBL and MLE layers + !! zdf_osm_mle_parameters : timestep MLE depth and calculate MLE fluxes + !! zdf_osm_init : initialization, namelist read, and parameters control + !! zdf_osm_alloc : memory allocation + !! osm_rst : read (or initialize) and write osmosis restart fields + !! tra_osm : compute and add to the T & S trend the non-local flux + !! trc_osm : compute and add to the passive tracer trend the non-local flux (TBD) + !! dyn_osm : compute and add to u & v trensd the non-local flux + !! zdf_osm_iomput : iom_put wrapper that accepts arrays without halo + !! zdf_osm_iomput_2d : iom_put wrapper for 2D fields + !! zdf_osm_iomput_3d : iom_put wrapper for 3D fields + !!---------------------------------------------------------------------- + USE oce ! Ocean dynamics and active tracers + ! ! Uses ww from previous time step (which is now wb) to calculate hbl + USE dom_oce ! Ocean space and time domain + USE zdf_oce ! Ocean vertical physics + USE sbc_oce ! Surface boundary condition: ocean + USE sbcwave ! Surface wave parameters + USE phycst ! Physical constants + USE eosbn2 ! Equation of state + USE traqsr ! Details of solar radiation absorption + USE zdfdrg, ONLY : rCdU_bot ! Bottom friction velocity + USE zdfddm ! Double diffusion mixing (avs array) + USE iom ! I/O library + USE lib_mpp ! MPP library + USE trd_oce ! Ocean trends definition + USE trdtra ! Tracers trends + USE in_out_manager ! I/O manager + USE lbclnk ! Ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + ! Public subroutines + PUBLIC zdf_osm ! Routine called by step.F90 + PUBLIC zdf_osm_init ! Routine called by nemogcm.F90 + PUBLIC osm_rst ! Routine called by step.F90 + PUBLIC tra_osm ! Routine called by step.F90 + PUBLIC trc_osm ! Routine called by trcstp.F90 + PUBLIC dyn_osm ! Routine called by step.F90 + + ! Public variables + LOGICAL, PUBLIC :: ln_osm_mle !: Flag to activate the Mixed Layer Eddy (MLE) + ! ! parameterisation, needed by tra_mle_init in + ! ! tramle.F90 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamu !: Non-local u-momentum flux + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamv !: Non-local v-momentum flux + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamt !: Non-local temperature flux (gamma/o) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghams !: Non-local salinity flux (gamma/o) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbl !: Boundary layer depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hml !: ML depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmle !: Depth of layer affexted by mixed layer eddies in Fox-Kemper parametrization + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dbdx_mle !: Zonal buoyancy gradient in ML + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dbdy_mle !: Meridional buoyancy gradient in ML + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mld_prof !: Level of base of MLE layer + + INTERFACE zdf_osm_velocity_rotation + !!--------------------------------------------------------------------- + !! *** INTERFACE zdf_velocity_rotation *** + !!--------------------------------------------------------------------- + MODULE PROCEDURE zdf_osm_velocity_rotation_2d + MODULE PROCEDURE zdf_osm_velocity_rotation_3d + END INTERFACE + ! + INTERFACE zdf_osm_iomput + !!--------------------------------------------------------------------- + !! *** INTERFACE zdf_osm_iomput *** + !!--------------------------------------------------------------------- + MODULE PROCEDURE zdf_osm_iomput_2d + MODULE PROCEDURE zdf_osm_iomput_3d + END INTERFACE + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: etmean ! Averaging operator for avt + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dh ! Depth of pycnocline + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_ft ! Inverse of the modified Coriolis parameter at t-pts + ! Layer indices + INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nbld ! Level of boundary layer base + INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmld ! Level of mixed-layer depth (pycnocline top) + ! Layer type + INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: n_ddh ! Type of shear layer + ! ! n_ddh=0: active shear layer + ! ! n_ddh=1: shear layer not active + ! ! n_ddh=2: shear production low + ! Layer flags + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_conv ! Unstable/stable bl + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_shear ! Shear layers + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_coup ! Coupling to bottom + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_pyc ! OSBL pycnocline present + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_flux ! Surface flux extends below OSBL into MLE layer + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_mle ! MLE layer increases in hickness. + ! Scales + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swth0 ! Surface heat flux (Kinematic) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sws0 ! Surface freshwater flux + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swb0 ! Surface buoyancy flux + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: suw0 ! Surface u-momentum flux + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sustar ! Friction velocity + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: scos_wind ! Cos angle of surface stress + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssin_wind ! Sin angle of surface stress + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swthav ! Heat flux - bl average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swsav ! Freshwater flux - bl average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swbav ! Buoyancy flux - bl average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sustke ! Surface Stokes drift + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dstokes ! Penetration depth of the Stokes drift + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swstrl ! Langmuir velocity scale + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swstrc ! Convective velocity scale + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sla ! Trubulent Langmuir number + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: svstr ! Velocity scale that tends to sustar for large Langmuir number + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: shol ! Stability parameter for boundary layer + ! Layer averages: BL + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_bl ! Temperature average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_bl ! Salinity average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_bl ! Velocity average (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_bl ! Velocity average (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_bl ! Buoyancy average + ! Difference between layer average and parameter at the base of the layer: BL + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dt_bl ! Temperature difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_ds_bl ! Salinity difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_du_bl ! Velocity difference (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dv_bl ! Velocity difference (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_db_bl ! Buoyancy difference + ! Layer averages: ML + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_ml ! Temperature average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_ml ! Salinity average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_ml ! Velocity average (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_ml ! Velocity average (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_ml ! Buoyancy average + ! Difference between layer average and parameter at the base of the layer: ML + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dt_ml ! Temperature difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_ds_ml ! Salinity difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_du_ml ! Velocity difference (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dv_ml ! Velocity difference (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_db_ml ! Buoyancy difference + ! Layer averages: MLE + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_mle ! Temperature average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_mle ! Salinity average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_mle ! Velocity average (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_mle ! Velocity average (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_mle ! Buoyancy average + ! Diagnostic output + REAL(WP), ALLOCATABLE, SAVE, DIMENSION(:,:) :: osmdia2d ! Auxiliary array for diagnostic output + REAL(WP), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: osmdia3d ! Auxiliary array for diagnostic output + LOGICAL :: ln_dia_pyc_scl = .FALSE. ! Output of pycnocline scalar-gradient profiles + LOGICAL :: ln_dia_pyc_shr = .FALSE. ! Output of pycnocline velocity-shear profiles + + ! !!* namelist namzdf_osm * + LOGICAL :: ln_use_osm_la ! Use namelist rn_osm_la + REAL(wp) :: rn_osm_la ! Turbulent Langmuir number + REAL(wp) :: rn_osm_dstokes ! Depth scale of Stokes drift + REAL(wp) :: rn_zdfosm_adjust_sd = 1.0_wp ! Factor to reduce Stokes drift by + REAL(wp) :: rn_osm_hblfrac = 0.1_wp ! For nn_osm_wave = 3/4 specify fraction in top of hbl + LOGICAL :: ln_zdfosm_ice_shelter ! Flag to activate ice sheltering + REAL(wp) :: rn_osm_hbl0 = 10.0_wp ! Initial value of hbl for 1D runs + INTEGER :: nn_ave ! = 0/1 flag for horizontal average on avt + INTEGER :: nn_osm_wave = 0 ! = 0/1/2 flag for getting stokes drift from La# / PM wind-waves/Inputs into + ! ! sbcwave + INTEGER :: nn_osm_SD_reduce ! = 0/1/2 flag for getting effective stokes drift from surface value + LOGICAL :: ln_dia_osm ! Use namelist rn_osm_la + LOGICAL :: ln_kpprimix = .TRUE. ! Shear instability mixing + REAL(wp) :: rn_riinfty = 0.7_wp ! Local Richardson Number limit for shear instability + REAL(wp) :: rn_difri = 0.005_wp ! Maximum shear mixing at Rig = 0 (m2/s) + LOGICAL :: ln_convmix = .TRUE. ! Convective instability mixing + REAL(wp) :: rn_difconv = 1.0_wp ! Diffusivity when unstable below BL (m2/s) + ! OSMOSIS mixed layer eddy parametrization constants + INTEGER :: nn_osm_mle ! = 0/1 flag for horizontal average on avt + REAL(wp) :: rn_osm_mle_ce ! MLE coefficient + ! Parameters used in nn_osm_mle = 0 case + REAL(wp) :: rn_osm_mle_lf ! Typical scale of mixed layer front + REAL(wp) :: rn_osm_mle_time ! Time scale for mixing momentum across the mixed layer + ! Parameters used in nn_osm_mle = 1 case + REAL(wp) :: rn_osm_mle_lat ! Reference latitude for a 5 km scale of ML front + LOGICAL :: ln_osm_hmle_limit ! If true arbitrarily restrict hmle to rn_osm_hmle_limit*zmld + REAL(wp) :: rn_osm_hmle_limit ! If ln_osm_hmle_limit true arbitrarily restrict hmle to rn_osm_hmle_limit*zmld + REAL(wp) :: rn_osm_mle_rho_c ! Density criterion for definition of MLD used by FK + REAL(wp) :: rb_c ! ML buoyancy criteria = g rho_c /rho0 where rho_c is defined in zdfmld + REAL(wp) :: rc_f ! MLE coefficient (= rn_ce / (5 km * fo) ) in nn_osm_mle=1 case + REAL(wp) :: rn_osm_mle_thresh ! Threshold buoyancy for deepening of MLE layer below OSBL base + REAL(wp) :: rn_osm_bl_thresh ! Threshold buoyancy for deepening of OSBL base + REAL(wp) :: rn_osm_mle_tau ! Adjustment timescale for MLE + + ! General constants + REAL(wp) :: epsln = 1.0e-20_wp ! A small positive number to ensure no div by zero + REAL(wp) :: depth_tol = 1.0e-6_wp ! A small-ish positive number to give a hbl slightly shallower than gdepw + REAL(wp) :: pthird = 1.0_wp/3.0_wp ! 1/3 + REAL(wp) :: p2third = 2.0_wp/3.0_wp ! 2/3 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfosm.F90 14921 2021-05-28 12:19:26Z smueller $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_osm_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_osm_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + zdf_osm_alloc = 0 + ! + ALLOCATE( ghamu(jpi,jpj,jpk), ghamv(jpi,jpj,jpk), ghamt(jpi,jpj,jpk), ghams(jpi,jpj,jpk), hbl(jpi,jpj), hml(jpi,jpj), & + & hmle(jpi,jpj), dbdx_mle(jpi,jpj), dbdy_mle(jpi,jpj), mld_prof(jpi,jpj), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( etmean(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1),jpk), dh(jpi,jpj), r1_ft(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( nbld(jpi,jpj), nmld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( n_ddh(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( l_conv(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), l_shear(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), l_coup(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), l_pyc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), & + & l_flux(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), l_mle(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( swth0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), sws0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), swb0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), suw0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), & + & sustar(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), scos_wind(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), ssin_wind(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), swthav(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), & + & swsav(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), swbav(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), sustke(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), dstokes(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), & + & swstrl(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), sla(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), svstr(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), & + & shol(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( av_t_bl(jpi,jpj), av_s_bl(jpi,jpj), av_u_bl(jpi,jpj), av_v_bl(jpi,jpj), & + & av_b_bl(jpi,jpj), STAT=ierr) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( av_dt_bl(jpi,jpj), av_ds_bl(jpi,jpj), av_du_bl(jpi,jpj), av_dv_bl(jpi,jpj), & + & av_db_bl(jpi,jpj), STAT=ierr) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( av_t_ml(jpi,jpj), av_s_ml(jpi,jpj), av_u_ml(jpi,jpj), av_v_ml(jpi,jpj), & + & av_b_ml(jpi,jpj), STAT=ierr) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( av_dt_ml(jpi,jpj), av_ds_ml(jpi,jpj), av_du_ml(jpi,jpj), av_dv_ml(jpi,jpj), & + & av_db_ml(jpi,jpj), STAT=ierr) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( av_t_mle(jpi,jpj), av_s_mle(jpi,jpj), av_u_mle(jpi,jpj), av_v_mle(jpi,jpj), & + & av_b_mle(jpi,jpj), STAT=ierr) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + IF ( ln_dia_osm ) THEN + ALLOCATE( osmdia2d(jpi,jpj), osmdia3d(jpi,jpj,jpk), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + END IF + ! + CALL mpp_sum ( 'zdfosm', zdf_osm_alloc ) + IF( zdf_osm_alloc /= 0 ) CALL ctl_warn( 'zdf_osm_alloc: failed to allocate zdf_osm arrays' ) + ! + END FUNCTION zdf_osm_alloc + + SUBROUTINE zdf_osm( kt, Kbb, Kmm, Krhs, p_avm, & + & p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm *** + !! + !! ** Purpose : Compute the vertical eddy viscosity and diffusivity + !! coefficients and non local mixing using the OSMOSIS scheme + !! + !! ** Method : The boundary layer depth hosm is diagnosed at tracer points + !! from profiles of buoyancy, and shear, and the surface forcing. + !! Above hbl (sigma=-z/hbl <1) the mixing coefficients are computed from + !! + !! Kx = hosm Wx(sigma) G(sigma) + !! + !! and the non local term ghamt = Cs / Ws(sigma) / hosm + !! Below hosm the coefficients are the sum of mixing due to internal waves + !! shear instability and double diffusion. + !! + !! -1- Compute the now interior vertical mixing coefficients at all depths. + !! -2- Diagnose the boundary layer depth. + !! -3- Compute the now boundary layer vertical mixing coefficients. + !! -4- Compute the now vertical eddy vicosity and diffusivity. + !! -5- Smoothing + !! + !! N.B. The computation is done from jk=2 to jpkm1 + !! Surface value of avt are set once a time to zero + !! in routine zdf_osm_init. + !! + !! ** Action : update the non-local terms ghamts + !! update avt (before vertical eddy coef.) + !! + !! References : Large W.G., Mc Williams J.C. and Doney S.C. + !! Reviews of Geophysics, 32, 4, November 1994 + !! Comments in the code refer to this paper, particularly + !! the equation number. (LMD94, here after) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! Ocean time step + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! Ocean time level indices + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm, p_avt ! Momentum and tracer Kz (w-points) + !! + INTEGER :: ji, jj, jk, jl, jm, jkflt ! Dummy loop indices + !! + REAL(wp) :: zthermal, zbeta + REAL(wp) :: zesh2, zri, zfri ! Interior Richardson mixing + !! Scales + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zrad0 ! Surface solar temperature flux (deg m/s) + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zradh ! Radiative flux at bl base (Buoyancy units) + REAL(wp) :: zradav ! Radiative flux, bl average (Buoyancy Units) + REAL(wp) :: zvw0 ! Surface v-momentum flux + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zwb0tot ! Total surface buoyancy flux including insolation + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zwb_min + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zwb_fk_b ! MLE buoyancy flux averaged over OSBL + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zwb_fk ! Max MLE buoyancy flux + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zdiff_mle ! Extra MLE vertical diff + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zvel_mle ! Velocity scale for dhdt with stable ML and FK + !! Mixed-layer variables + INTEGER, DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: jk_nlev ! Number of levels + INTEGER, DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: jk_ext ! Offset for external level + !! + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zhbl ! BL depth - grid + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zhml ! ML depth - grid + !! + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zhmle ! MLE depth - grid + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zmld ! ML depth on grid + !! + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zdh ! Pycnocline depth - grid + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zdhdt ! BL depth tendency + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zdtdz_bl_ext, zdsdz_bl_ext ! External temperature/salinity gradients + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zdtdx, zdtdy, zdsdx, zdsdy ! Horizontal gradients for Fox-Kemper parametrization + !! + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zdbds_mle ! Magnitude of horizontal buoyancy gradient + !! Flux-gradient relationship variables + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zshear ! Shear production + !! + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zhbl_t ! Holds boundary layer depth updated by full timestep + !! For calculating Ri#-dependent mixing + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: z2du ! u-shear^2 + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: z2dv ! v-shear^2 + REAL(wp) :: zrimix ! Spatial form of ri#-induced diffusion + !! Temporary variables + REAL(wp) :: znd ! Temporary non-dimensional depth + REAL(wp) :: zz0, zz1, zfac + REAL(wp) :: zus_x, zus_y ! Temporary Stokes drift + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1),jpk) :: zviscos ! Viscosity + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1),jpk) :: zdiffut ! t-diffusivity + REAL(wp) :: zabsstke + REAL(wp) :: zsqrtpi, z_two_thirds, zthickness + REAL(wp) :: z2k_times_thickness, zsqrt_depth, zexp_depth, zf, zexperfc + !! For debugging + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !!---------------------------------------------------------------------- + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + nmld(ji,jj) = 0 + sustke(ji,jj) = pp_large + l_pyc(ji,jj) = .FALSE. + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + END DO ; END DO + ! Mixed layer + ! No initialization of zhbl or zhml (or zdh?) + zhbl(:,:) = pp_large + zhml(:,:) = pp_large + zdh(:,:) = pp_large + ! + IF ( ln_osm_mle ) THEN ! Only initialise arrays if needed + zdtdx(:,:) = pp_large ; zdtdy(:,:) = pp_large ; zdsdx(:,:) = pp_large + zdsdy(:,:) = pp_large + zwb_fk(:,:) = pp_large ; zvel_mle(:,:) = pp_large + zhmle(:,:) = pp_large ; zmld(:,:) = pp_large + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + dbdx_mle(ji,jj) = pp_large + dbdy_mle(ji,jj) = pp_large + END DO ; END DO + ENDIF + zhbl_t(:,:) = pp_large + ! + zdiffut(:,:,:) = 0.0_wp + zviscos(:,:,:) = 0.0_wp + ! + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + ghamt(ji,jj,jk) = pp_large + ghams(ji,jj,jk) = pp_large + ghamu(ji,jj,jk) = pp_large + ghamv(ji,jj,jk) = pp_large + END DO ; END DO ; END DO + DO jk = 1, jpk ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ghamt(ji,jj,jk) = 0.0_wp + ghams(ji,jj,jk) = 0.0_wp + ghamu(ji,jj,jk) = 0.0_wp + ghamv(ji,jj,jk) = 0.0_wp + END DO ; END DO ; END DO + ! + zdiff_mle(:,:) = 0.0_wp + ! + ! Ensure only positive hbl values are accessed when using extended halo + ! (nn_hls==2) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + hbl(ji,jj) = MAX( hbl(ji,jj), epsln ) + END DO ; END DO + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Calculate boundary layer scales + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + ! Turbulent surface fluxes and fluxes averaged over depth of the OSBL + zz0 = rn_abs ! Assume two-band radiation model for depth of OSBL - surface equi-partition in 2-bands + zz1 = 1.0_wp - rn_abs + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zrad0(ji,jj) = qsr(ji,jj) * r1_rho0_rcp ! Surface downward irradiance (so always +ve) + zradh(ji,jj) = zrad0(ji,jj) * & ! Downwards irradiance at base of boundary layer + & ( zz0 * EXP( -1.0_wp * hbl(ji,jj) / rn_si0 ) + zz1 * EXP( -1.0_wp * hbl(ji,jj) / rn_si1 ) ) + zradav = zrad0(ji,jj) * & ! Downwards irradiance averaged + & ( zz0 * ( 1.0_wp - EXP( -hbl(ji,jj)/rn_si0 ) ) * rn_si0 + & ! over depth of the OSBL + & zz1 * ( 1.0_wp - EXP( -hbl(ji,jj)/rn_si1 ) ) * rn_si1 ) / hbl(ji,jj) + swth0(ji,jj) = - qns(ji,jj) * r1_rho0_rcp * tmask(ji,jj,1) ! Upwards surface Temperature flux for non-local term + swthav(ji,jj) = 0.5_wp * swth0(ji,jj) - ( 0.5_wp * ( zrad0(ji,jj) + zradh(ji,jj) ) - & ! Turbulent heat flux averaged + & zradav ) ! over depth of OSBL + END DO ; END DO + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + sws0(ji,jj) = -1.0_wp * ( ( emp(ji,jj) - rnf(ji,jj) ) * ts(ji,jj,1,jp_sal,Kmm) + & ! Upwards surface salinity flux + & sfx(ji,jj) ) * r1_rho0 * tmask(ji,jj,1) ! for non-local term + zthermal = rab_n(ji,jj,1,jp_tem) + zbeta = rab_n(ji,jj,1,jp_sal) + swb0(ji,jj) = grav * zthermal * swth0(ji,jj) - grav * zbeta * sws0(ji,jj) ! Non radiative upwards surface buoyancy flux + zwb0tot(ji,jj) = swb0(ji,jj) - grav * zthermal * ( zrad0(ji,jj) - zradh(ji,jj) ) ! Total upwards surface buoyancy flux + swsav(ji,jj) = 0.5_wp * sws0(ji,jj) ! Turbulent salinity flux averaged over depth of the OBSL + swbav(ji,jj) = grav * zthermal * swthav(ji,jj) - & ! Turbulent buoyancy flux averaged over the depth of the + & grav * zbeta * swsav(ji,jj) ! OBSBL + END DO ; END DO + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + suw0(ji,jj) = -0.5_wp * (utau(ji-1,jj) + utau(ji,jj)) * r1_rho0 * tmask(ji,jj,1) ! Surface upward velocity fluxes + zvw0 = -0.5_wp * (vtau(ji,jj-1) + vtau(ji,jj)) * r1_rho0 * tmask(ji,jj,1) + sustar(ji,jj) = MAX( SQRT( SQRT( suw0(ji,jj) * suw0(ji,jj) + zvw0 * zvw0 ) ), & ! Friction velocity (sustar), at + & 1e-8_wp ) ! T-point : LMD94 eq. 2 + scos_wind(ji,jj) = -1.0_wp * suw0(ji,jj) / ( sustar(ji,jj) * sustar(ji,jj) ) + ssin_wind(ji,jj) = -1.0_wp * zvw0 / ( sustar(ji,jj) * sustar(ji,jj) ) + END DO ; END DO + ! Calculate Stokes drift in direction of wind (sustke) and Stokes penetration depth (dstokes) + SELECT CASE (nn_osm_wave) + ! Assume constant La#=0.3 + CASE(0) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zus_x = scos_wind(ji,jj) * sustar(ji,jj) / 0.3_wp**2 + zus_y = ssin_wind(ji,jj) * sustar(ji,jj) / 0.3_wp**2 + ! Linearly + sustke(ji,jj) = MAX( SQRT( zus_x * zus_x + zus_y * zus_y ), 1e-8_wp ) + dstokes(ji,jj) = rn_osm_dstokes + END DO ; END DO + ! Assume Pierson-Moskovitz wind-wave spectrum + CASE(1) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! Use wind speed wndm included in sbc_oce module + sustke(ji,jj) = MAX ( 0.016_wp * wndm(ji,jj), 1e-8_wp ) + dstokes(ji,jj) = MAX ( 0.12_wp * wndm(ji,jj)**2 / grav, 5e-1_wp ) + END DO ; END DO + ! Use ECMWF wave fields as output from SBCWAVE + CASE(2) + zfac = 2.0_wp * rpi / 16.0_wp + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( hsw(ji,jj) > 1e-4_wp ) THEN + ! Use wave fields + zabsstke = SQRT( ut0sd(ji,jj)**2 + vt0sd(ji,jj)**2 ) + sustke(ji,jj) = MAX( ( scos_wind(ji,jj) * ut0sd(ji,jj) + ssin_wind(ji,jj) * vt0sd(ji,jj) ), 1e-8_wp ) + dstokes(ji,jj) = MAX( zfac * hsw(ji,jj) * hsw(ji,jj) / ( MAX( zabsstke * wmp(ji,jj), 1e-7 ) ), 5e-1_wp ) + ELSE + ! Assume masking issue (e.g. ice in ECMWF reanalysis but not in model run) + ! .. so default to Pierson-Moskowitz + sustke(ji,jj) = MAX( 0.016_wp * wndm(ji,jj), 1e-8_wp ) + dstokes(ji,jj) = MAX( 0.12_wp * wndm(ji,jj)**2 / grav, 5e-1_wp ) + END IF + END DO ; END DO + END SELECT + ! + IF (ln_zdfosm_ice_shelter) THEN + ! Reduce both Stokes drift and its depth scale by ocean fraction to represent sheltering by ice + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + sustke(ji,jj) = sustke(ji,jj) * ( 1.0_wp - fr_i(ji,jj) ) + dstokes(ji,jj) = dstokes(ji,jj) * ( 1.0_wp - fr_i(ji,jj) ) + END DO ; END DO + END IF + ! + SELECT CASE (nn_osm_SD_reduce) + ! Reduce surface Stokes drift by a constant factor or following Breivik (2016) + van Roekel (2012) or Grant (2020). + CASE(0) + ! The Langmur number from the ECMWF model (or from PM) appears to give La<0.3 for wind-driven seas. + ! The coefficient rn_zdfosm_adjust_sd = 0.8 gives La=0.3 in this situation. + ! It could represent the effects of the spread of wave directions around the mean wind. The effect of this adjustment needs to be tested. + IF(nn_osm_wave > 0) THEN + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + sustke(ji,jj) = rn_zdfosm_adjust_sd * sustke(ji,jj) + END DO ; END DO + END IF + CASE(1) + ! Van Roekel (2012): consider average SD over top 10% of boundary layer + ! Assumes approximate depth profile of SD from Breivik (2016) + zsqrtpi = SQRT(rpi) + z_two_thirds = 2.0_wp / 3.0_wp + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zthickness = rn_osm_hblfrac*hbl(ji,jj) + z2k_times_thickness = zthickness * 2.0_wp / MAX( ABS( 5.97_wp * dstokes(ji,jj) ), 1e-7_wp ) + zsqrt_depth = SQRT( z2k_times_thickness ) + zexp_depth = EXP( -1.0_wp * z2k_times_thickness ) + sustke(ji,jj) = sustke(ji,jj) * ( 1.0_wp - zexp_depth - & + & z_two_thirds * ( zsqrtpi * zsqrt_depth * z2k_times_thickness * ERFC(zsqrt_depth) + & + & 1.0_wp - ( 1.0_wp + z2k_times_thickness ) * zexp_depth ) ) / & + & z2k_times_thickness + END DO ; END DO + CASE(2) + ! Grant (2020): Match to exponential with same SD and d/dz(Sd) at depth 10% of boundary layer + ! Assumes approximate depth profile of SD from Breivik (2016) + zsqrtpi = SQRT(rpi) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zthickness = rn_osm_hblfrac*hbl(ji,jj) + z2k_times_thickness = zthickness * 2.0_wp / MAX( ABS( 5.97_wp * dstokes(ji,jj) ), 1e-7_wp ) + IF( z2k_times_thickness < 50.0_wp ) THEN + zsqrt_depth = SQRT( z2k_times_thickness ) + zexperfc = zsqrtpi * zsqrt_depth * ERFC(zsqrt_depth) * EXP( z2k_times_thickness ) + ELSE + ! Asymptotic expansion of sqrt(pi)*zsqrt_depth*EXP(z2k_times_thickness)*ERFC(zsqrt_depth) for large + ! z2k_times_thickness + ! See Abramowitz and Stegun, Eq. 7.1.23 + ! zexperfc = 1._wp - (1/2)/(z2k_times_thickness) + (3/4)/(z2k_times_thickness**2) - (15/8)/(z2k_times_thickness**3) + zexperfc = ( ( -1.875_wp / z2k_times_thickness + 0.75_wp ) / z2k_times_thickness - 0.5_wp ) / & + & z2k_times_thickness + 1.0_wp + END IF + zf = z2k_times_thickness * ( 1.0_wp / zexperfc - 1.0_wp ) + dstokes(ji,jj) = 5.97_wp * zf * dstokes(ji,jj) + sustke(ji,jj) = sustke(ji,jj) * EXP( z2k_times_thickness * ( 1.0_wp / ( 2.0_wp * zf ) - 1.0_wp ) ) * & + & ( 1.0_wp - zexperfc ) + END DO ; END DO + END SELECT + ! + ! Langmuir velocity scale (swstrl), La # (sla) + ! Mixed scale (svstr), convective velocity scale (swstrc) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! Langmuir velocity scale (swstrl), at T-point + swstrl(ji,jj) = ( sustar(ji,jj) * sustar(ji,jj) * sustke(ji,jj) )**pthird + sla(ji,jj) = MAX( MIN( SQRT( sustar(ji,jj) / ( swstrl(ji,jj) + epsln ) )**3, 4.0_wp ), 0.2_wp ) + IF ( sla(ji,jj) > 0.45_wp ) dstokes(ji,jj) = MIN( dstokes(ji,jj), 0.5_wp * hbl(ji,jj) ) + ! Velocity scale that tends to sustar for large Langmuir numbers + svstr(ji,jj) = ( swstrl(ji,jj)**3 + ( 1.0_wp - EXP( -0.5_wp * sla(ji,jj)**2 ) ) * sustar(ji,jj) * sustar(ji,jj) * & + & sustar(ji,jj) )**pthird + ! + ! Limit maximum value of Langmuir number as approximate treatment for shear turbulence + ! Note sustke and swstrl are not amended + ! + ! Get convective velocity (swstrc), stabilty scale (shol) and logical conection flag l_conv + IF ( swbav(ji,jj) > 0.0_wp ) THEN + swstrc(ji,jj) = ( 2.0_wp * swbav(ji,jj) * 0.9_wp * hbl(ji,jj) )**pthird + shol(ji,jj) = -0.9_wp * hbl(ji,jj) * 2.0_wp * swbav(ji,jj) / ( svstr(ji,jj)**3 + epsln ) + ELSE + swstrc(ji,jj) = 0.0_wp + shol(ji,jj) = -1.0_wp * hbl(ji,jj) * 2.0_wp * swbav(ji,jj) / ( svstr(ji,jj)**3 + epsln ) + ENDIF + END DO ; END DO + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Mixed-layer model - calculate averages over the boundary layer, and the change in the boundary layer depth + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! BL must be always 4 levels deep. + ! For calculation of lateral buoyancy gradients for FK in + ! zdf_osm_zmld_horizontal_gradients need halo values for nbld + ! + ! agn 23/6/20: not clear all this is needed, as hbl checked after it is re-calculated anyway + ! ########################################################################## + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + hbl(ji,jj) = MAX(hbl(ji,jj), (gdepw_0(ji,jj,4)*(1._wp+r3t(ji,jj,Kmm))) ) + END DO ; END DO + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + nbld(ji,jj) = 4 + END DO ; END DO + DO jk = 5, jpkm1 ; DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls)*nthb), ntej+( nn_hls-( nn_hls+ nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + IF ( MAX( hbl(ji,jj), (gdepw_0(ji,jj,4)*(1._wp+r3t(ji,jj,Kmm))) ) >= (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) THEN + nbld(ji,jj) = MIN(mbkt(ji,jj)-2, jk) + ENDIF + END DO ; END DO ; END DO + ! ########################################################################## + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zhbl(ji,jj) = (gdepw_0(ji,jj,nbld(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) + nmld(ji,jj) = MAX( 3, nbld(ji,jj) - MAX( INT( dh(ji,jj) / (e3t_0(ji,jj,nbld(ji,jj)-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,nbld(ji,jj)-1))) ), 1 ) ) + zhml(ji,jj) = (gdepw_0(ji,jj,nmld(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) + zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) + END DO ; END DO + ! + ! Averages over well-mixed and boundary layer, note BL averages use jk_ext=2 everywhere + jk_nlev(:,:) = nbld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + jk_ext(:,:) = 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_bl, av_s_bl, & + & av_b_bl, av_u_bl, av_v_bl, jk_ext, av_dt_bl, & + & av_ds_bl, av_db_bl, av_du_bl, av_dv_bl ) + jk_nlev(:,:) = nmld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) - 1 + jk_ext(:,:) = nbld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) - nmld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_ml, av_s_ml, & + & av_b_ml, av_u_ml, av_v_ml, jk_ext, av_dt_ml, & + & av_ds_ml, av_db_ml, av_du_ml, av_dv_ml ) + ! Velocity components in frame aligned with surface stress + CALL zdf_osm_velocity_rotation( av_u_ml, av_v_ml ) + CALL zdf_osm_velocity_rotation( av_du_ml, av_dv_ml ) + CALL zdf_osm_velocity_rotation( av_u_bl, av_v_bl ) + CALL zdf_osm_velocity_rotation( av_du_bl, av_dv_bl ) + ! + ! Determine the state of the OSBL, stable/unstable, shear/no shear + CALL zdf_osm_osbl_state( Kmm, zwb_ent, zwb_min, zshear, zhbl, & + & zhml, zdh ) + ! + IF ( ln_osm_mle ) THEN + ! Fox-Kemper Scheme + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls )*nthb), ntej+( nn_hls -( nn_hls + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls)*nthl), ntei+( nn_hls-( nn_hls+ nn_hls)*nthr) + mld_prof(ji,jj) = 4 + END DO ; END DO + DO jk = 5, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( hmle(ji,jj) >= (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) mld_prof(ji,jj) = MIN( mbkt(ji,jj), jk) + END DO ; END DO ; END DO + jk_nlev(:,:) = mld_prof(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_mle, av_s_mle, & + & av_b_mle, av_u_mle, av_v_mle ) + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zhmle(ji,jj) = (gdepw_0(ji,jj,mld_prof(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + ! + ! Calculate fairly-well-mixed depth zmld & its index mld_prof + lateral zmld-averaged gradients + CALL zdf_osm_zmld_horizontal_gradients( Kmm, zmld, zdtdx, zdtdy, zdsdx, & + & zdsdy, zdbds_mle ) + ! Calculate max vertical FK flux zwb_fk & set logical descriptors + CALL zdf_osm_osbl_state_fk( Kmm, zwb_fk, zhbl, zhmle, zwb_ent, & + & zdbds_mle ) + ! Recalculate hmle, zmle, zvel_mle, zdiff_mle & redefine mld_proc to be index for new hmle + CALL zdf_osm_mle_parameters( Kmm, zmld, zhmle, zvel_mle, zdiff_mle, & + & zdbds_mle, zhbl, zwb0tot ) + ELSE ! ln_osm_mle + ! FK not selected, Boundary Layer only. + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + l_pyc(ji,jj) = .TRUE. + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + IF ( l_conv(ji,jj) .AND. av_db_bl(ji,jj) < rn_osm_bl_thresh ) l_pyc(ji,jj) = .FALSE. + END DO ; END DO + ENDIF ! ln_osm_mle + ! + !! External gradient below BL needed both with and w/o FK + jk_ext(:,:) = nbld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + 1 + CALL zdf_osm_external_gradients( Kmm, jk_ext, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext ) ! ag 19/03 + ! + ! Test if pycnocline well resolved + ! DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) Removed with ag 19/03 changes. A change in eddy diffusivity/viscosity + ! IF (l_conv(ji,jj) ) THEN should account for this. + ! ztmp = 0.2 * zhbl(ji,jj) / (e3w_0(ji,jj,nbld(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) + ! IF ( ztmp > 6 ) THEN + ! ! pycnocline well resolved + ! jk_ext(ji,jj) = 1 + ! ELSE + ! ! pycnocline poorly resolved + ! jk_ext(ji,jj) = 0 + ! ENDIF + ! ELSE + ! ! Stable conditions + ! jk_ext(ji,jj) = 0 + ! ENDIF + ! END DO ; END DO + ! + ! Recalculate bl averages using jk_ext & ml averages .... note no rotation of u & v here.. + jk_nlev(:,:) = nbld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + jk_ext(:,:) = 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_bl, av_s_bl, & + & av_b_bl, av_u_bl, av_v_bl, jk_ext, av_dt_bl, & + & av_ds_bl, av_db_bl, av_du_bl, av_dv_bl ) + jk_nlev(:,:) = nmld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) - 1 + jk_ext(:,:) = nbld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) - nmld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_ml, av_s_ml, & + & av_b_ml, av_u_ml, av_v_ml, jk_ext, av_dt_ml, & + & av_ds_ml, av_db_ml, av_du_ml, av_dv_ml ) ! ag 19/03 + ! + ! Rate of change of hbl + CALL zdf_osm_calculate_dhdt( zdhdt, zhbl, zdh, zwb_ent, zwb_min, & + & zdbdz_bl_ext, zwb_fk_b, zwb_fk, zvel_mle ) + ! Test if surface boundary layer coupled to bottom + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + l_coup(ji,jj) = .FALSE. ! ag 19/03 + zhbl_t(ji,jj) = hbl(ji,jj) + ( zdhdt(ji,jj) - ww(ji,jj,nbld(ji,jj)) ) * rn_Dt ! Certainly need ww here, so subtract it + ! Adjustment to represent limiting by ocean bottom + IF ( mbkt(ji,jj) > 2 ) THEN ! To ensure mbkt(ji,jj) - 2 > 0 so no incorrect array access + IF ( zhbl_t(ji,jj) > (gdepw_0(ji, jj,mbkt(ji,jj)-2)*(1._wp+r3t(ji, jj,Kmm))) ) THEN + zhbl_t(ji,jj) = MIN( zhbl_t(ji,jj), (gdepw_0(ji,jj,mbkt(ji,jj)-2)*(1._wp+r3t(ji,jj,Kmm))) ) ! (ht_0(:,:)*(1._wp+r3t(:,:,Kmm)))) + l_pyc(ji,jj) = .FALSE. + l_coup(ji,jj) = .TRUE. ! ag 19/03 + END IF + END IF + END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + nmld(ji,jj) = nbld(ji,jj) ! use nmld to hold previous blayer index + nbld(ji,jj) = 4 + END DO ; END DO + ! + DO jk = 4, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( zhbl_t(ji,jj) >= (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) THEN + nbld(ji,jj) = jk + END IF + END DO ; END DO ; END DO + ! + ! + ! Step through model levels taking account of buoyancy change to determine the effect on dhdt + ! + CALL zdf_osm_timestep_hbl( Kmm, zdhdt, zhbl, zhbl_t, zwb_ent, & + & zwb_fk_b ) + ! Is external level in bounds? + ! + ! Recalculate BL averages and differences using new BL depth + jk_nlev(:,:) = nbld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + jk_ext(:,:) = 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_bl, av_s_bl, & + & av_b_bl, av_u_bl, av_v_bl, jk_ext, av_dt_bl, & + & av_ds_bl, av_db_bl, av_du_bl, av_dv_bl ) + ! + CALL zdf_osm_pycnocline_thickness( Kmm, zdh, zhml, zdhdt, zhbl, & + & zwb_ent, zdbdz_bl_ext, zwb_fk_b ) + ! + ! Reset l_pyc before calculating terms in the flux-gradient relationship + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( av_db_bl(ji,jj) < rn_osm_bl_thresh .OR. nbld(ji,jj) >= mbkt(ji,jj) - 2 .OR. & + & nbld(ji,jj) - nmld(ji,jj) == 1 .OR. zdhdt(ji,jj) < 0.0_wp ) THEN ! ag 19/03 + l_pyc(ji,jj) = .FALSE. ! ag 19/03 + IF ( nbld(ji,jj) >= mbkt(ji,jj) -2 ) THEN + nmld(ji,jj) = nbld(ji,jj) - 1 ! ag 19/03 + zdh(ji,jj) = (gdepw_0(ji,jj,nbld(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) - (gdepw_0(ji,jj,nmld(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) ! ag 19/03 + zhml(ji,jj) = (gdepw_0(ji,jj,nmld(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) ! ag 19/03 + dh(ji,jj) = zdh(ji,jj) ! ag 19/03 + hml(ji,jj) = hbl(ji,jj) - dh(ji,jj) ! ag 19/03 + ENDIF + ENDIF ! ag 19/03 + END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! Limit delta for shallow boundary layers for calculating + dstokes(ji,jj) = MIN ( dstokes(ji,jj), hbl(ji,jj) / 3.0_wp ) ! flux-gradient terms + END DO ; END DO + ! + ! + ! Average over the depth of the mixed layer in the convective boundary layer + ! jk_ext = nbld - nmld + 1 + ! Recalculate ML averages and differences using new ML depth + jk_nlev(:,:) = nmld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) - 1 + jk_ext(:,:) = nbld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) - nmld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_ml, av_s_ml, & + & av_b_ml, av_u_ml, av_v_ml, jk_ext, av_dt_ml, & + & av_ds_ml, av_db_ml, av_du_ml, av_dv_ml ) + ! + jk_ext(:,:) = nbld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + 1 + CALL zdf_osm_external_gradients( Kmm, jk_ext, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext ) + ! Rotate mean currents and changes onto wind aligned co-ordinates + CALL zdf_osm_velocity_rotation( av_u_ml, av_v_ml ) + CALL zdf_osm_velocity_rotation( av_du_ml, av_dv_ml ) + CALL zdf_osm_velocity_rotation( av_u_bl, av_v_bl ) + CALL zdf_osm_velocity_rotation( av_du_bl, av_dv_bl ) + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Eddy viscosity/diffusivity and non-gradient terms in the flux-gradient relationship + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL zdf_osm_diffusivity_viscosity( Kbb, Kmm, zdiffut, zviscos, zhbl, & + & zhml, zdh, zdhdt, zshear, zwb_ent, & + & zwb_min ) + ! + ! Calculate non-gradient components of the flux-gradient relationships + ! -------------------------------------------------------------------- + jk_ext(:,:) = 1 ! ag 19/03 + CALL zdf_osm_fgr_terms( Kmm, jk_ext, zhbl, zhml, zdh, & + & zdhdt, zshear, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext, & + & zdiffut, zviscos ) + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Need to put in code for contributions that are applied explicitly to + ! the prognostic variables + ! 1. Entrainment flux + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + ! Rotate non-gradient velocity terms back to model reference frame + jk_nlev(:,:) = nbld(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + CALL zdf_osm_velocity_rotation( ghamu, ghamv, .FALSE., 2, jk_nlev ) + ! + ! KPP-style Ri# mixing + IF ( ln_kpprimix ) THEN + jkflt = jpk + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( nbld(ji,jj) < jkflt ) jkflt = nbld(ji,jj) + END DO ; END DO + DO jk = jkflt+1, jpkm1 + ! Shear production at uw- and vw-points (energy conserving form) + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + z2du(ji,jj) = 0.5_wp * ( uu(ji,jj,jk-1,Kmm) - uu(ji,jj,jk,Kmm) ) * ( uu(ji,jj,jk-1,Kbb) - uu(ji,jj,jk,Kbb) ) * & + & wumask(ji,jj,jk) / ( (e3uw_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm))) * (e3uw_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kbb))) ) + z2dv(ji,jj) = 0.5_wp * ( vv(ji,jj,jk-1,Kmm) - vv(ji,jj,jk,Kmm) ) * ( vv(ji,jj,jk-1,Kbb) - vv(ji,jj,jk,Kbb) ) * & + & wvmask(ji,jj,jk) / ( (e3vw_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm))) * (e3vw_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kbb))) ) + END DO ; END DO + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( jk > nbld(ji,jj) ) THEN + ! Shear prod. at w-point weightened by mask + zesh2 = ( z2du(ji-1,jj) + z2du(ji,jj) ) / MAX( 1.0_wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) ) + & + & ( z2dv(ji,jj-1) + z2dv(ji,jj) ) / MAX( 1.0_wp , vmask(ji,jj-1,jk) + vmask(ji,jj,jk) ) + ! Local Richardson number + zri = MAX( rn2b(ji,jj,jk), 0.0_wp ) / MAX( zesh2, epsln ) + zfri = MIN( zri / rn_riinfty, 1.0_wp ) + zfri = ( 1.0_wp - zfri * zfri ) + zrimix = zfri * zfri * zfri * wmask(ji, jj, jk) + zdiffut(ji,jj,jk) = MAX( zdiffut(ji,jj,jk), zrimix*rn_difri ) + zviscos(ji,jj,jk) = MAX( zviscos(ji,jj,jk), zrimix*rn_difri ) + END IF + END DO ; END DO + END DO + END IF ! ln_kpprimix = .true. + ! + ! KPP-style set diffusivity large if unstable below BL + IF ( ln_convmix) THEN + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + DO jk = nbld(ji,jj) + 1, jpkm1 + IF ( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1e-12_wp ) zdiffut(ji,jj,jk) = MAX( rn_difconv, zdiffut(ji,jj,jk) ) + END DO + END DO ; END DO + END IF ! ln_convmix = .true. + ! + IF ( ln_osm_mle ) THEN ! Set up diffusivity and non-gradient mixing + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_flux(ji,jj) ) THEN ! MLE mixing extends below boundary layer + ! Calculate MLE flux contribution from surface fluxes + DO jk = 1, nbld(ji,jj) + znd = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / MAX( zhbl(ji,jj), epsln ) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) - ( swth0(ji,jj) - zrad0(ji,jj) + zradh(ji,jj) ) * ( 1.0_wp - znd ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) - sws0(ji,jj) * ( 1.0_wp - znd ) + END DO + DO jk = 1, mld_prof(ji,jj) + znd = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / MAX( zhmle(ji,jj), epsln ) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + ( swth0(ji,jj) - zrad0(ji,jj) + zradh(ji,jj) ) * ( 1.0_wp - znd ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + sws0(ji,jj) * ( 1.0_wp -znd ) + END DO + ! Viscosity for MLEs + DO jk = 1, mld_prof(ji,jj) + znd = -1.0_wp * (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / MAX( zhmle(ji,jj), epsln ) + zdiffut(ji,jj,jk) = zdiffut(ji,jj,jk) + zdiff_mle(ji,jj) * ( 1.0_wp - ( 2.0_wp * znd + 1.0_wp )**2 ) * & + & ( 1.0_wp + 5.0_wp / 21.0_wp * ( 2.0_wp * znd + 1.0_wp )**2 ) + END DO + ELSE ! Surface transports limited to OSBL + ! Viscosity for MLEs + DO jk = 1, mld_prof(ji,jj) + znd = -1.0_wp * (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / MAX( zhmle(ji,jj), epsln ) + zdiffut(ji,jj,jk) = zdiffut(ji,jj,jk) + zdiff_mle(ji,jj) * ( 1.0_wp - ( 2.0_wp * znd + 1.0_wp )**2 ) * & + & ( 1.0_wp + 5.0_wp / 21.0_wp * ( 2.0_wp * znd + 1.0_wp )**2 ) + END DO + END IF + END DO ; END DO + ENDIF + ! + ! Lateral boundary conditions on zvicos (sign unchanged), needed to caclulate viscosities on u and v grids + ! CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1.0_wp ) + ! GN 25/8: need to change tmask --> wmask + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + p_avt(ji,jj,jk) = MAX( zdiffut(ji,jj,jk), avtb(jk) ) * tmask(ji,jj,jk) + p_avm(ji,jj,jk) = MAX( zviscos(ji,jj,jk), avmb(jk) ) * tmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + IF ( ln_dia_osm ) THEN + SELECT CASE (nn_osm_wave) + ! Stokes drift set by assumimg onstant La#=0.3 (=0) or Pierson-Moskovitz spectrum (=1) + CASE(0:1) + CALL zdf_osm_iomput( "us_x", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * sustke(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) * scos_wind(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! x surface Stokes drift + CALL zdf_osm_iomput( "us_y", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * sustke(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) * scos_wind(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! y surface Stokes drift + CALL zdf_osm_iomput( "wind_wave_abs_power", 1000.0_wp * rho0 * tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * sustar(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0))**2 * sustke(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) + ! Stokes drift read in from sbcwave (=2). + CASE(2:3) + CALL zdf_osm_iomput( "us_x", ut0sd(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) * umask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) ) ! x surface Stokes drift + CALL zdf_osm_iomput( "us_y", vt0sd(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) * vmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) ) ! y surface Stokes drift + CALL zdf_osm_iomput( "wmp", wmp(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) * tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) ) ! Wave mean period + CALL zdf_osm_iomput( "hsw", hsw(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) * tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) ) ! Significant wave height + CALL zdf_osm_iomput( "wmp_NP", ( 2.0_wp * rpi * 1.026_wp / ( 0.877_wp * grav ) ) * & ! Wave mean period from NP + & wndm(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) * tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) ) ! spectrum + CALL zdf_osm_iomput( "hsw_NP", ( 0.22_wp / grav ) * wndm(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0))**2 * tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) ) ! Significant wave height from + ! ! NP spectrum + CALL zdf_osm_iomput( "wndm", wndm(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) * tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) ) ! U_10 + CALL zdf_osm_iomput( "wind_wave_abs_power", 1000.0_wp * rho0 * tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * sustar(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0))**2 * & + & SQRT( ut0sd(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0))**2 + vt0sd(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0))**2 ) ) + END SELECT + CALL zdf_osm_iomput( "zwth0", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * swth0(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! + CALL zdf_osm_iomput( "zws0", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * sws0(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! + CALL zdf_osm_iomput( "zwb0", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * swb0(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! + CALL zdf_osm_iomput( "zwbav", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * swth0(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Upward BL-avged turb buoyancy flux + CALL zdf_osm_iomput( "ibld", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * nbld(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Boundary-layer max k + CALL zdf_osm_iomput( "zdt_bl", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * av_dt_bl(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! dt at ml base + CALL zdf_osm_iomput( "zds_bl", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * av_ds_bl(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! ds at ml base + CALL zdf_osm_iomput( "zdb_bl", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * av_db_bl(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! db at ml base + CALL zdf_osm_iomput( "zdu_bl", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * av_du_bl(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! du at ml base + CALL zdf_osm_iomput( "zdv_bl", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * av_dv_bl(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! dv at ml base + CALL zdf_osm_iomput( "dh", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * dh(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Initial boundary-layer depth + CALL zdf_osm_iomput( "hml", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * hml(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Initial boundary-layer depth + CALL zdf_osm_iomput( "zdt_ml", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * av_dt_ml(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! dt at ml base + CALL zdf_osm_iomput( "zds_ml", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * av_ds_ml(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! ds at ml base + CALL zdf_osm_iomput( "zdb_ml", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * av_db_ml(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! db at ml base + CALL zdf_osm_iomput( "dstokes", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * dstokes(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Stokes drift penetration depth + CALL zdf_osm_iomput( "zustke", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * sustke(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Stokes drift magnitude at T-points + CALL zdf_osm_iomput( "zwstrc", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * swstrc(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Convective velocity scale + CALL zdf_osm_iomput( "zwstrl", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * swstrl(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Langmuir velocity scale + CALL zdf_osm_iomput( "zustar", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * sustar(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Friction velocity scale + CALL zdf_osm_iomput( "zvstr", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * svstr(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Mixed velocity scale + CALL zdf_osm_iomput( "zla", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * sla(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Langmuir # + CALL zdf_osm_iomput( "wind_power", 1000.0_wp * rho0 * tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * & ! BL depth internal to zdf_osm routine + & sustar(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0))**3 ) + CALL zdf_osm_iomput( "wind_wave_power", 1000.0_wp * rho0 * tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * & + & sustar(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0))**2 * sustke(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) + CALL zdf_osm_iomput( "zhbl", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zhbl(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! BL depth internal to zdf_osm routine + CALL zdf_osm_iomput( "zhml", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zhml(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! ML depth internal to zdf_osm routine + CALL zdf_osm_iomput( "imld", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * nmld(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Index for ML depth internal to zdf_osm + ! ! routine + CALL zdf_osm_iomput( "jp_ext", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * jk_ext(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! =1 if pycnocline resolved internal to + ! ! zdf_osm routine + CALL zdf_osm_iomput( "j_ddh", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * n_ddh(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Index forpyc thicknessh internal to + ! ! zdf_osm routine + CALL zdf_osm_iomput( "zshear", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zshear(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Shear production of TKE internal to + ! ! zdf_osm routine + CALL zdf_osm_iomput( "zdh", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zdh(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Pyc thicknessh internal to zdf_osm + ! ! routine + CALL zdf_osm_iomput( "zhol", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * shol(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! ML depth internal to zdf_osm routine + CALL zdf_osm_iomput( "zwb_ent", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zwb_ent(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Upward turb buoyancy entrainment flux + CALL zdf_osm_iomput( "zt_ml", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * av_t_ml(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Average T in ML + CALL zdf_osm_iomput( "zmld", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zmld(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK target layer depth + CALL zdf_osm_iomput( "zwb_fk", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zwb_fk(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK b flux + CALL zdf_osm_iomput( "zwb_fk_b", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zwb_fk_b(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK b flux averaged over ML + CALL zdf_osm_iomput( "mld_prof", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * mld_prof(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK layer max k + CALL zdf_osm_iomput( "zdtdx", umask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zdtdx(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK dtdx at u-pt + CALL zdf_osm_iomput( "zdtdy", vmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zdtdy(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK dtdy at v-pt + CALL zdf_osm_iomput( "zdsdx", umask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zdsdx(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK dtdx at u-pt + CALL zdf_osm_iomput( "zdsdy", vmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zdsdy(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK dsdy at v-pt + CALL zdf_osm_iomput( "dbdx_mle", umask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * dbdx_mle(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK dbdx at u-pt + CALL zdf_osm_iomput( "dbdy_mle", vmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * dbdy_mle(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK dbdy at v-pt + CALL zdf_osm_iomput( "zdiff_mle", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zdiff_mle(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK diff in MLE at t-pt + CALL zdf_osm_iomput( "zvel_mle", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zdiff_mle(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! FK diff in MLE at t-pt + END IF + ! + ! Lateral boundary conditions on ghamu and ghamv, currently on W-grid (sign unchanged), needed to caclulate gham[uv] on u and + ! v grids + IF ( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Finalise ghamu, ghamv, hbl, and hmle only after full domain has been + ! ! processed + IF ( nn_hls == 1 ) CALL lbc_lnk( 'zdfosm', ghamu, 'W', 1.0_wp, & + & ghamv, 'W', 1.0_wp ) + DO jk = 2, jpkm1 + DO jj = Njs0, Nje0 + DO ji = Nis0, Nie0 + ghamu(ji,jj,jk) = ( ghamu(ji,jj,jk) + ghamu(ji+1,jj,jk) ) / & + & MAX( 1.0_wp, tmask(ji,jj,jk) + tmask (ji+1,jj,jk) ) * umask(ji,jj,jk) + ghamv(ji,jj,jk) = ( ghamv(ji,jj,jk) + ghamv(ji,jj+1,jk) ) / & + & MAX( 1.0_wp, tmask(ji,jj,jk) + tmask (ji,jj+1,jk) ) * vmask(ji,jj,jk) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) * tmask(ji,jj,jk) + ghams(ji,jj,jk) = ghams(ji,jj,jk) * tmask(ji,jj,jk) + END DO + END DO + END DO + ! Lateral boundary conditions on final outputs for hbl, on T-grid (sign unchanged) + CALL lbc_lnk( 'zdfosm', hbl, 'T', 1.0_wp, & + & hmle, 'T', 1.0_wp ) + ! + CALL zdf_osm_iomput( "ghamt", tmask * ghamt ) ! + CALL zdf_osm_iomput( "ghams", tmask * ghams ) ! + CALL zdf_osm_iomput( "ghamu", umask * ghamu ) ! + CALL zdf_osm_iomput( "ghamv", vmask * ghamv ) ! + CALL zdf_osm_iomput( "hbl", tmask(:,:,1) * hbl ) ! Boundary-layer depth + CALL zdf_osm_iomput( "hmle", tmask(:,:,1) * hmle ) ! FK layer depth + END IF + ! + END SUBROUTINE zdf_osm + + SUBROUTINE zdf_osm_vertical_average( Kbb, Kmm, knlev, pt, ps, & + & pb, pu, pv, kp_ext, pdt, & + & pds, pdb, pdu, pdv ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_vertical_average *** + !! + !! ** Purpose : Determines vertical averages from surface to knlev, + !! and optionally the differences between these vertical + !! averages and values at an external level + !! + !! ** Method : Averages are calculated from the surface to knlev. + !! The external level used to calculate differences is + !! knlev+kp_ext + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kbb, Kmm ! Ocean time-level indices + INTEGER, DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: knlev ! Number of levels to average over. + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pt, ps ! Average temperature and salinity + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pb ! Average buoyancy + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pu, pv ! Average current components + INTEGER, DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ), OPTIONAL :: kp_ext ! External-level offsets + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdt ! Difference between average temperature, + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pds ! salinity, + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdb ! buoyancy, and + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdu, pdv ! velocity components and the OSBL + !! + INTEGER :: jk, jkflt, jkmax, ji, jj ! Loop indices + INTEGER :: ibld_ext ! External-layer index + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zthick ! Layer thickness + REAL(wp) :: zthermal ! Thermal expansion coefficient + REAL(wp) :: zbeta ! Haline contraction coefficient + !!---------------------------------------------------------------------- + ! + ! Averages over depth of boundary layer + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + pt(ji,jj) = 0.0_wp + ps(ji,jj) = 0.0_wp + pu(ji,jj) = 0.0_wp + pv(ji,jj) = 0.0_wp + END DO ; END DO + zthick(:,:) = epsln + jkflt = jpk + jkmax = 0 + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( knlev(ji,jj) < jkflt ) jkflt = knlev(ji,jj) + IF ( knlev(ji,jj) > jkmax ) jkmax = knlev(ji,jj) + END DO ; END DO + DO jk = 2, jkflt ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! Upper, flat part of layer + zthick(ji,jj) = zthick(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + pt(ji,jj) = pt(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * ts(ji,jj,jk,jp_tem,Kmm) + ps(ji,jj) = ps(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * ts(ji,jj,jk,jp_sal,Kmm) + pu(ji,jj) = pu(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * & + & ( uu(ji,jj,jk,Kbb) + uu(ji - 1,jj,jk,Kbb) ) / & + & MAX( 1.0_wp , umask(ji,jj,jk) + umask(ji - 1,jj,jk) ) + pv(ji,jj) = pv(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * & + & ( vv(ji,jj,jk,Kbb) + vv(ji,jj - 1,jk,Kbb) ) / & + & MAX( 1.0_wp , vmask(ji,jj,jk) + vmask(ji,jj - 1,jk) ) + END DO ; END DO ; END DO + DO jk = jkflt+1, jkmax ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! Lower, non-flat part of layer + IF ( knlev(ji,jj) >= jk ) THEN + zthick(ji,jj) = zthick(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + pt(ji,jj) = pt(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * ts(ji,jj,jk,jp_tem,Kmm) + ps(ji,jj) = ps(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * ts(ji,jj,jk,jp_sal,Kmm) + pu(ji,jj) = pu(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * & + & ( uu(ji,jj,jk,Kbb) + uu(ji - 1,jj,jk,Kbb) ) / & + & MAX( 1.0_wp , umask(ji,jj,jk) + umask(ji - 1,jj,jk) ) + pv(ji,jj) = pv(ji,jj) + (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * & + & ( vv(ji,jj,jk,Kbb) + vv(ji,jj - 1,jk,Kbb) ) / & + & MAX( 1.0_wp , vmask(ji,jj,jk) + vmask(ji,jj - 1,jk) ) + END IF + END DO ; END DO ; END DO + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + pt(ji,jj) = pt(ji,jj) / zthick(ji,jj) + ps(ji,jj) = ps(ji,jj) / zthick(ji,jj) + pu(ji,jj) = pu(ji,jj) / zthick(ji,jj) + pv(ji,jj) = pv(ji,jj) / zthick(ji,jj) + zthermal = rab_n(ji,jj,1,jp_tem) ! ideally use nbld not 1?? + zbeta = rab_n(ji,jj,1,jp_sal) + pb(ji,jj) = grav * zthermal * pt(ji,jj) - grav * zbeta * ps(ji,jj) + END DO ; END DO + ! + ! Differences between vertical averages and values at an external layer + IF ( PRESENT( kp_ext ) ) THEN + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ibld_ext = knlev(ji,jj) + kp_ext(ji,jj) + IF ( ibld_ext <= mbkt(ji,jj)-1 ) THEN ! ag 09/03 + ! Two external levels are available + pdt(ji,jj) = pt(ji,jj) - ts(ji,jj,ibld_ext,jp_tem,Kmm) + pds(ji,jj) = ps(ji,jj) - ts(ji,jj,ibld_ext,jp_sal,Kmm) + pdu(ji,jj) = pu(ji,jj) - ( uu(ji,jj,ibld_ext,Kbb) + uu(ji-1,jj,ibld_ext,Kbb ) ) / & + & MAX(1.0_wp , umask(ji,jj,ibld_ext ) + umask(ji-1,jj,ibld_ext ) ) + pdv(ji,jj) = pv(ji,jj) - ( vv(ji,jj,ibld_ext,Kbb) + vv(ji,jj-1,ibld_ext,Kbb ) ) / & + & MAX(1.0_wp , vmask(ji,jj,ibld_ext ) + vmask(ji,jj-1,ibld_ext ) ) + zthermal = rab_n(ji,jj,1,jp_tem) ! ideally use nbld not 1?? + zbeta = rab_n(ji,jj,1,jp_sal) + pdb(ji,jj) = grav * zthermal * pdt(ji,jj) - grav * zbeta * pds(ji,jj) + ELSE + pdt(ji,jj) = 0.0_wp + pds(ji,jj) = 0.0_wp + pdu(ji,jj) = 0.0_wp + pdv(ji,jj) = 0.0_wp + pdb(ji,jj) = 0.0_wp + ENDIF + END DO ; END DO + END IF + ! + END SUBROUTINE zdf_osm_vertical_average + + SUBROUTINE zdf_osm_velocity_rotation_2d( pu, pv, fwd ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_velocity_rotation_2d *** + !! + !! ** Purpose : Rotates frame of reference of velocity components pu and + !! pv (2d) + !! + !! ** Method : The velocity components are rotated into (fwd=.TRUE.) or + !! from (fwd=.FALSE.) the frame specified by scos_wind and + !! ssin_wind + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: pu, pv ! Components of current + LOGICAL, OPTIONAL, INTENT(in ) :: fwd ! Forward (default) or reverse rotation + !! + INTEGER :: ji, jj ! Loop indices + REAL(wp) :: ztmp, zfwd ! Auxiliary variables + !!---------------------------------------------------------------------- + ! + zfwd = 1.0_wp + IF( PRESENT(fwd) .AND. ( .NOT. fwd ) ) zfwd = -1.0_wp + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ztmp = pu(ji,jj) + pu(ji,jj) = pu(ji,jj) * scos_wind(ji,jj) + zfwd * pv(ji,jj) * ssin_wind(ji,jj) + pv(ji,jj) = pv(ji,jj) * scos_wind(ji,jj) - zfwd * ztmp * ssin_wind(ji,jj) + END DO ; END DO + ! + END SUBROUTINE zdf_osm_velocity_rotation_2d + + SUBROUTINE zdf_osm_velocity_rotation_3d( pu, pv, fwd, ktop, knlev ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_velocity_rotation_3d *** + !! + !! ** Purpose : Rotates frame of reference of velocity components pu and + !! pv (3d) + !! + !! ** Method : The velocity components are rotated into (fwd=.TRUE.) or + !! from (fwd=.FALSE.) the frame specified by scos_wind and + !! ssin_wind; optionally, the rotation can be restricted at + !! each water column to span from the a minimum index ktop to + !! the depth index specified in array knlev + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pu, pv ! Components of current + LOGICAL, OPTIONAL, INTENT(in ) :: fwd ! Forward (default) or reverse rotation + INTEGER, OPTIONAL, INTENT(in ) :: ktop ! Minimum depth index + INTEGER, OPTIONAL, INTENT(in ), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: knlev ! Array of maximum depth indices + !! + INTEGER :: ji, jj, jk, jktop, jkmax ! Loop indices + REAL(wp) :: ztmp, zfwd ! Auxiliary variables + LOGICAL :: llkbot ! Auxiliary variable + !!---------------------------------------------------------------------- + ! + zfwd = 1.0_wp + IF( PRESENT(fwd) .AND. ( .NOT. fwd ) ) zfwd = -1.0_wp + jktop = 1 + IF( PRESENT(ktop) ) jktop = ktop + IF( PRESENT(knlev) ) THEN + jkmax = 0 + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( knlev(ji,jj) > jkmax ) jkmax = knlev(ji,jj) + END DO ; END DO + llkbot = .FALSE. + ELSE + jkmax = jpk + llkbot = .TRUE. + END IF + DO jk = jktop, jkmax ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( llkbot .OR. knlev(ji,jj) >= jk ) THEN + ztmp = pu(ji,jj,jk) + pu(ji,jj,jk) = pu(ji,jj,jk) * scos_wind(ji,jj) + zfwd * pv(ji,jj,jk) * ssin_wind(ji,jj) + pv(ji,jj,jk) = pv(ji,jj,jk) * scos_wind(ji,jj) - zfwd * ztmp * ssin_wind(ji,jj) + END IF + END DO ; END DO ; END DO + ! + END SUBROUTINE zdf_osm_velocity_rotation_3d + + SUBROUTINE zdf_osm_osbl_state( Kmm, pwb_ent, pwb_min, pshear, phbl, & + & phml, pdh ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_osbl_state *** + !! + !! ** Purpose : Determines the state of the OSBL, stable/unstable, + !! shear/ noshear. Also determines shear production, + !! entrainment buoyancy flux and interfacial Richardson + !! number + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT( out) :: pwb_ent ! Buoyancy fluxes at base + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT( out) :: pwb_min ! of well-mixed layer + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT( out) :: pshear ! Production of TKE due to shear across the pycnocline + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + !! + INTEGER :: jj, ji ! Loop indices + !! + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zekman + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zri_p, zri_b ! Richardson numbers + REAL(wp) :: zshear_u, zshear_v, zwb_shr + REAL(wp) :: zwcor, zrf_conv, zrf_shear, zrf_langmuir, zr_stokes + !! + REAL(wp), PARAMETER :: pp_a_shr = 0.4_wp, pp_b_shr = 6.5_wp, pp_a_wb_s = 0.8_wp + REAL(wp), PARAMETER :: pp_alpha_c = 0.2_wp, pp_alpha_lc = 0.03_wp + REAL(wp), PARAMETER :: pp_alpha_ls = 0.06_wp, pp_alpha_s = 0.15_wp + REAL(wp), PARAMETER :: pp_ri_p_thresh = 27.0_wp + REAL(wp), PARAMETER :: pp_ri_c = 0.25_wp + REAL(wp), PARAMETER :: pp_ek = 4.0_wp + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !!---------------------------------------------------------------------- + ! + ! Initialise arrays + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + l_conv(ji,jj) = .FALSE. + l_shear(ji,jj) = .FALSE. + n_ddh(ji,jj) = 1 + END DO ; END DO + ! Initialise INTENT( out) arrays + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + pwb_ent(ji,jj) = pp_large + pwb_min(ji,jj) = pp_large + END DO ; END DO + ! + ! Determins stability and set flag l_conv + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( shol(ji,jj) < 0.0_wp ) THEN + l_conv(ji,jj) = .TRUE. + ELSE + l_conv(ji,jj) = .FALSE. + ENDIF + END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + pshear(ji,jj) = 0.0_wp + END DO ; END DO + zekman(:,:) = EXP( -1.0_wp * pp_ek * ABS( ff_t(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) * phbl(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / & + & MAX( sustar(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), 1.e-8 ) ) + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) ) THEN + IF ( av_db_bl(ji,jj) > 0.0_wp ) THEN + zri_p(ji,jj) = MAX ( SQRT( av_db_bl(ji,jj) * pdh(ji,jj) / MAX( av_du_bl(ji,jj)**2 + av_dv_bl(ji,jj)**2, & + & 1e-8_wp ) ) * ( phbl(ji,jj) / pdh(ji,jj) ) * & + & ( svstr(ji,jj) / MAX( sustar(ji,jj), 1e-6_wp ) )**2 / & + & MAX( zekman(ji,jj), 1.0e-6_wp ), 5.0_wp ) + IF ( ff_t(ji,jj) >= 0.0_wp ) THEN ! Northern hemisphere + zri_b(ji,jj) = av_db_ml(ji,jj) * pdh(ji,jj) / ( MAX( av_du_ml(ji,jj), 1e-5_wp )**2 + & + & MAX( -1.0_wp * av_dv_ml(ji,jj), 1e-5_wp)**2 ) + ELSE ! Southern hemisphere + zri_b(ji,jj) = av_db_ml(ji,jj) * pdh(ji,jj) / ( MAX( av_du_ml(ji,jj), 1e-5_wp )**2 + & + & MAX( av_dv_ml(ji,jj), 1e-5_wp)**2 ) + END IF + pshear(ji,jj) = pp_a_shr * zekman(ji,jj) * & + & ( MAX( sustar(ji,jj)**2 * av_du_ml(ji,jj) / phbl(ji,jj), 0.0_wp ) + & + & pp_b_shr * MAX( -1.0_wp * ff_t(ji,jj) * sustke(ji,jj) * dstokes(ji,jj) * & + & av_dv_ml(ji,jj) / phbl(ji,jj), 0.0_wp ) ) + ! Stability dependence + pshear(ji,jj) = pshear(ji,jj) * EXP( -0.75_wp * MAX( 0.0_wp, ( zri_b(ji,jj) - pp_ri_c ) / pp_ri_c ) ) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Test ensures n_ddh=0 is not selected. Change to zri_p<27 when ! + ! full code available ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF ( pshear(ji,jj) > 1e-10 ) THEN + IF ( zri_p(ji,jj) < pp_ri_p_thresh .AND. & + & MIN( (hu_0(ji,jj)*(1._wp+r3u(ji,jj,Kmm))), (hu_0(ji-1,jj)*(1._wp+r3u(ji-1,jj,Kmm))), (hv_0(ji,jj)*(1._wp+r3v(ji,jj,Kmm))), (hv_0(ji,jj-1)*(1._wp+r3v(ji,jj-1,Kmm))) ) > 100.0_wp ) THEN + ! Growing shear layer + n_ddh(ji,jj) = 0 + l_shear(ji,jj) = .TRUE. + ELSE + n_ddh(ji,jj) = 1 + ! IF ( zri_b <= 1.5 .and. pshear(ji,jj) > 0._wp ) THEN + ! Shear production large enough to determine layer charcteristics, but can't maintain a shear layer + l_shear(ji,jj) = .TRUE. + ! ELSE + END IF + ELSE + n_ddh(ji,jj) = 2 + l_shear(ji,jj) = .FALSE. + END IF + ! Shear production may not be zero, but is small and doesn't determine characteristics of pycnocline + ! pshear(ji,jj) = 0.5 * pshear(ji,jj) + ! l_shear(ji,jj) = .FALSE. + ! ENDIF + ELSE ! av_db_bl test, note pshear set to zero + n_ddh(ji,jj) = 2 + l_shear(ji,jj) = .FALSE. + ENDIF + ENDIF + END DO ; END DO + ! + ! Calculate entrainment buoyancy flux due to surface fluxes. + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) ) THEN + zwcor = ABS( ff_t(ji,jj) ) * phbl(ji,jj) + epsln + zrf_conv = TANH( ( swstrc(ji,jj) / zwcor )**0.69_wp ) + zrf_shear = TANH( ( sustar(ji,jj) / zwcor )**0.69_wp ) + zrf_langmuir = TANH( ( swstrl(ji,jj) / zwcor )**0.69_wp ) + IF ( nn_osm_SD_reduce > 0 ) THEN + ! Effective Stokes drift already reduced from surface value + zr_stokes = 1.0_wp + ELSE + ! Effective Stokes drift only reduced by factor rn_zdfodm_adjust_sd, + ! requires further reduction where BL is deep + zr_stokes = 1.0 - EXP( -25.0_wp * dstokes(ji,jj) / hbl(ji,jj) * ( 1.0_wp + 4.0_wp * dstokes(ji,jj) / hbl(ji,jj) ) ) + END IF + pwb_ent(ji,jj) = -2.0_wp * pp_alpha_c * zrf_conv * swbav(ji,jj) - & + & pp_alpha_s * zrf_shear * sustar(ji,jj)**3 / phml(ji,jj) + & + & zr_stokes * ( pp_alpha_s * EXP( -1.5_wp * sla(ji,jj) ) * zrf_shear * sustar(ji,jj)**3 - & + & zrf_langmuir * pp_alpha_lc * swstrl(ji,jj)**3 ) / phml(ji,jj) + ENDIF + END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_shear(ji,jj) ) THEN + IF ( l_conv(ji,jj) ) THEN + ! Unstable OSBL + zwb_shr = -1.0_wp * pp_a_wb_s * zri_b(ji,jj) * pshear(ji,jj) + IF ( n_ddh(ji,jj) == 0 ) THEN + ! Developing shear layer, additional shear production possible. + + ! pshear_u = MAX( zustar(ji,jj)**2 * MAX( av_du_ml(ji,jj), 0._wp ) / phbl(ji,jj), 0._wp ) + ! pshear(ji,jj) = pshear(ji,jj) + pshear_u * ( 1.0 - MIN( zri_p(ji,jj) / pp_ri_p_thresh, 1.d0 )**2 ) + ! pshear(ji,jj) = MIN( pshear(ji,jj), pshear_u ) + + ! zwb_shr = zwb_shr - 0.25 * MAX ( pshear_u, 0._wp) * ( 1.0 - MIN( zri_p(ji,jj) / pp_ri_p_thresh, 1._wp )**2 ) + ! zwb_shr = MAX( zwb_shr, -0.25 * pshear_u ) + ENDIF + pwb_ent(ji,jj) = pwb_ent(ji,jj) + zwb_shr + ! pwb_min(ji,jj) = pwb_ent(ji,jj) + pdh(ji,jj) / phbl(ji,jj) * zwb0(ji,jj) + ELSE ! IF ( l_conv ) THEN - ENDIF + ! Stable OSBL - shear production not coded for first attempt. + ENDIF ! l_conv + END IF ! l_shear + IF ( l_conv(ji,jj) ) THEN + ! Unstable OSBL + pwb_min(ji,jj) = pwb_ent(ji,jj) + pdh(ji,jj) / phbl(ji,jj) * 2.0_wp * swbav(ji,jj) + END IF ! l_conv + END DO ; END DO + ! + END SUBROUTINE zdf_osm_osbl_state + + SUBROUTINE zdf_osm_external_gradients( Kmm, kbase, pdtdz, pdsdz, pdbdz ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_external_gradients *** + !! + !! ** Purpose : Calculates the gradients below the OSBL + !! + !! ** Method : Uses nbld and ibld_ext to determine levels to calculate the gradient. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index + INTEGER, DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: kbase ! OSBL base layer index + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT( out) :: pdtdz, pdsdz ! External gradients of temperature, salinity + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT( out) :: pdbdz ! and buoyancy + !! + INTEGER :: ji, jj, jkb, jkb1 + REAL(wp) :: zthermal, zbeta + !! + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !!---------------------------------------------------------------------- + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + pdtdz(ji,jj) = pp_large + pdsdz(ji,jj) = pp_large + pdbdz(ji,jj) = pp_large + END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( kbase(ji,jj)+1 < mbkt(ji,jj) ) THEN + zthermal = rab_n(ji,jj,1,jp_tem) ! Ideally use nbld not 1?? + zbeta = rab_n(ji,jj,1,jp_sal) + jkb = kbase(ji,jj) + jkb1 = MIN( jkb + 1, mbkt(ji,jj) ) + pdtdz(ji,jj) = -1.0_wp * ( ts(ji,jj,jkb1,jp_tem,Kmm) - ts(ji,jj,jkb,jp_tem,Kmm ) ) / (e3w_0(ji,jj,jkb1)*(1._wp+r3t(ji,jj,Kmm))) + pdsdz(ji,jj) = -1.0_wp * ( ts(ji,jj,jkb1,jp_sal,Kmm) - ts(ji,jj,jkb,jp_sal,Kmm ) ) / (e3w_0(ji,jj,jkb1)*(1._wp+r3t(ji,jj,Kmm))) + pdbdz(ji,jj) = grav * zthermal * pdtdz(ji,jj) - grav * zbeta * pdsdz(ji,jj) + ELSE + pdtdz(ji,jj) = 0.0_wp + pdsdz(ji,jj) = 0.0_wp + pdbdz(ji,jj) = 0.0_wp + END IF + END DO ; END DO + ! + END SUBROUTINE zdf_osm_external_gradients + + SUBROUTINE zdf_osm_calculate_dhdt( pdhdt, phbl, pdh, pwb_ent, pwb_min, & + & pdbdz_bl_ext, pwb_fk_b, pwb_fk, pvel_mle ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_calculate_dhdt *** + !! + !! ** Purpose : Calculates the rate at which hbl changes. + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT( out) :: pdhdt ! Rate of change of hbl + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pwb_min + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT( out) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pwb_fk ! Max MLE buoyancy flux + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pvel_mle ! Vvelocity scale for dhdt with stable ML and FK + !! + INTEGER :: jj, ji + REAL(wp) :: zgamma_b_nd, zgamma_dh_nd, zpert, zpsi, zari + REAL(wp) :: zvel_max, zddhdt + !! + REAL(wp), PARAMETER :: pp_alpha_b = 0.3_wp + REAL(wp), PARAMETER :: pp_ddh = 2.5_wp, pp_ddh_2 = 3.5_wp ! Also in pycnocline_depth + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !!---------------------------------------------------------------------- + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + pdhdt(ji,jj) = pp_large + pwb_fk_b(ji,jj) = pp_large + END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! + IF ( l_shear(ji,jj) ) THEN + ! + IF ( l_conv(ji,jj) ) THEN ! Convective + ! + IF ( ln_osm_mle ) THEN + IF ( hmle(ji,jj) > hbl(ji,jj) ) THEN ! Fox-Kemper buoyancy flux average over OSBL + pwb_fk_b(ji,jj) = pwb_fk(ji,jj) * ( 1.0_wp + hmle(ji,jj) / ( 6.0_wp * hbl(ji,jj) ) * & + & ( -1.0_wp + ( 1.0_wp - 2.0_wp * hbl(ji,jj) / hmle(ji,jj) )**3 ) ) + ELSE + pwb_fk_b(ji,jj) = 0.5_wp * pwb_fk(ji,jj) * hmle(ji,jj) / hbl(ji,jj) + ENDIF + zvel_max = ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**p2third / hbl(ji,jj) + IF ( ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) < 0.0_wp ) THEN ! OSBL is deepening, + ! ! entrainment > restratification + IF ( av_db_bl(ji,jj) > 1e-15_wp ) THEN + zgamma_b_nd = MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) * pdh(ji,jj) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + zpsi = ( 1.0_wp - 0.5_wp * pdh(ji,jj) / phbl(ji,jj) ) * & + & ( swb0(ji,jj) - MIN( ( pwb_min(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ), 0.0_wp ) ) * pdh(ji,jj) / & + & phbl(ji,jj) + zpsi = zpsi + 1.75_wp * ( 1.0_wp - 0.5_wp * pdh(ji,jj) / phbl(ji,jj) ) * & + & ( pdh(ji,jj) / phbl(ji,jj) + zgamma_b_nd ) * & + & MIN( ( pwb_min(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ), 0.0_wp ) + zpsi = pp_alpha_b * MAX( zpsi, 0.0_wp ) + pdhdt(ji,jj) = -1.0_wp * ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + & + & zpsi / ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + IF ( n_ddh(ji,jj) == 1 ) THEN + IF ( ( swstrc(ji,jj) / svstr(ji,jj) )**3 <= 0.5_wp ) THEN + zari = MIN( 1.5_wp * av_db_bl(ji,jj) / & + & ( phbl(ji,jj) * ( MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) + & + & av_db_bl(ji,jj)**2 / MAX( 4.5_wp * svstr(ji,jj)**2, & + & 1e-12_wp ) ) ), 0.2_wp ) + ELSE + zari = MIN( 1.5_wp * av_db_bl(ji,jj) / & + & ( phbl(ji,jj) * ( MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) + & + & av_db_bl(ji,jj)**2 / MAX( 4.5_wp * swstrc(ji,jj)**2, & + & 1e-12_wp ) ) ), 0.2_wp ) + ENDIF + ! Relaxation to dh_ref = zari * hbl + zddhdt = -1.0_wp * pp_ddh_2 * ( 1.0_wp - pdh(ji,jj) / ( zari * phbl(ji,jj) ) ) * pwb_ent(ji,jj) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + ELSE IF ( n_ddh(ji,jj) == 0 ) THEN ! Growing shear layer + zddhdt = -1.0_wp * pp_ddh * ( 1.0_wp - 1.6_wp * pdh(ji,jj) / phbl(ji,jj) ) * pwb_ent(ji,jj) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + zddhdt = EXP( -4.0_wp * ABS( ff_t(ji,jj) ) * phbl(ji,jj) / MAX( sustar(ji,jj), 1e-8_wp ) ) * zddhdt + ELSE + zddhdt = 0.0_wp + ENDIF ! n_ddh + pdhdt(ji,jj) = pdhdt(ji,jj) + pp_alpha_b * ( 1.0_wp - 0.5_wp * pdh(ji,jj) / phbl(ji,jj) ) * & + & av_db_ml(ji,jj) * MAX( zddhdt, 0.0_wp ) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + ELSE ! av_db_bl >0 + pdhdt(ji,jj) = -1.0_wp * ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) / MAX( zvel_max, 1e-15_wp ) + ENDIF + ELSE ! pwb_min + 2*pwb_fk_b < 0 + ! OSBL shoaling due to restratification flux. This is the velocity defined in Fox-Kemper et al (2008) + pdhdt(ji,jj) = -1.0_wp * MIN( pvel_mle(ji,jj), hbl(ji,jj) / 10800.0_wp ) + ENDIF + ELSE ! Fox-Kemper not used. + zvel_max = -1.0_wp * ( 1.0_wp + 1.0_wp * ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird * & + & rn_Dt / hbl(ji,jj) ) * pwb_ent(ji,jj) / & + & MAX( ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird, epsln ) + pdhdt(ji,jj) = -1.0_wp * pwb_ent(ji,jj) / ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + ! added ajgn 23 July as temporay fix + ENDIF ! ln_osm_mle + ! + ELSE ! l_conv - Stable + ! + pdhdt(ji,jj) = ( 0.06_wp + 0.52_wp * shol(ji,jj) / 2.0_wp ) * svstr(ji,jj)**3 / hbl(ji,jj) + swbav(ji,jj) + IF ( pdhdt(ji,jj) < 0.0_wp ) THEN ! For long timsteps factor in brackets slows the rapid collapse of the OSBL + zpert = 2.0_wp * ( 1.0_wp + 0.0_wp * 2.0_wp * svstr(ji,jj) * rn_Dt / hbl(ji,jj) ) * svstr(ji,jj)**2 / hbl(ji,jj) + ELSE + zpert = MAX( svstr(ji,jj)**2 / hbl(ji,jj), av_db_bl(ji,jj) ) + ENDIF + pdhdt(ji,jj) = 2.0_wp * pdhdt(ji,jj) / MAX( zpert, epsln ) + pdhdt(ji,jj) = MAX( pdhdt(ji,jj), -1.0_wp * hbl(ji,jj) / 5400.0_wp ) + ! + ENDIF ! l_conv + ! + ELSE ! l_shear + ! + IF ( l_conv(ji,jj) ) THEN ! Convective + ! + IF ( ln_osm_mle ) THEN + IF ( hmle(ji,jj) > hbl(ji,jj) ) THEN ! Fox-Kemper buoyancy flux average over OSBL + pwb_fk_b(ji,jj) = pwb_fk(ji,jj) * & + ( 1.0_wp + hmle(ji,jj) / ( 6.0_wp * hbl(ji,jj) ) * & + & ( -1.0_wp + ( 1.0_wp - 2.0_wp * hbl(ji,jj) / hmle(ji,jj))**3) ) + ELSE + pwb_fk_b(ji,jj) = 0.5_wp * pwb_fk(ji,jj) * hmle(ji,jj) / hbl(ji,jj) + ENDIF + zvel_max = ( swstrl(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**p2third / hbl(ji,jj) + IF ( ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) < 0.0_wp ) THEN ! OSBL is deepening, + ! ! entrainment > restratification + IF ( av_db_bl(ji,jj) > 0.0_wp .AND. pdbdz_bl_ext(ji,jj) > 0.0_wp ) THEN + pdhdt(ji,jj) = -1.0_wp * ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + ELSE + pdhdt(ji,jj) = -1.0_wp * ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) / MAX( zvel_max, 1e-15_wp ) + ENDIF + ELSE ! OSBL shoaling due to restratification flux. This is the velocity defined in Fox-Kemper et al (2008) + pdhdt(ji,jj) = -1.0_wp * MIN( pvel_mle(ji,jj), hbl(ji,jj) / 10800.0_wp ) + ENDIF + ELSE ! Fox-Kemper not used + zvel_max = -1.0_wp * pwb_ent(ji,jj) / MAX( ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird, epsln ) + pdhdt(ji,jj) = -1.0_wp * pwb_ent(ji,jj) / ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + ! added ajgn 23 July as temporay fix + ENDIF ! ln_osm_mle + ! + ELSE ! Stable + ! + pdhdt(ji,jj) = ( 0.06_wp + 0.52_wp * shol(ji,jj) / 2.0_wp ) * svstr(ji,jj)**3 / hbl(ji,jj) + swbav(ji,jj) + IF ( pdhdt(ji,jj) < 0.0_wp ) THEN + ! For long timsteps factor in brackets slows the rapid collapse of the OSBL + zpert = 2.0_wp * svstr(ji,jj)**2 / hbl(ji,jj) + ELSE + zpert = MAX( svstr(ji,jj)**2 / hbl(ji,jj), av_db_bl(ji,jj) ) + ENDIF + pdhdt(ji,jj) = 2.0_wp * pdhdt(ji,jj) / MAX(zpert, epsln) + pdhdt(ji,jj) = MAX( pdhdt(ji,jj), -1.0_wp * hbl(ji,jj) / 5400.0_wp ) + ! + ENDIF ! l_conv + ! + ENDIF ! l_shear + ! + END DO ; END DO + ! + END SUBROUTINE zdf_osm_calculate_dhdt + + SUBROUTINE zdf_osm_timestep_hbl( Kmm, pdhdt, phbl, phbl_t, pwb_ent, & + & pwb_fk_b ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_timestep_hbl *** + !! + !! ** Purpose : Increments hbl. + !! + !! ** Method : If the change in hbl exceeds one model level the change is + !! is calculated by moving down the grid, changing the + !! buoyancy jump. This is to ensure that the change in hbl + !! does not overshoot a stable layer. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(inout) :: pdhdt ! Rates of change of hbl + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(inout) :: phbl ! BL depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phbl_t ! BL depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL + !! + INTEGER :: jk, jj, ji, jm + REAL(wp) :: zhbl_s, zvel_max, zdb + REAL(wp) :: zthermal, zbeta + !!---------------------------------------------------------------------- + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( nbld(ji,jj) - nmld(ji,jj) > 1 ) THEN + ! + ! If boundary layer changes by more than one level, need to check for stable layers between initial and final depths. + ! + zhbl_s = hbl(ji,jj) + jm = nmld(ji,jj) + zthermal = rab_n(ji,jj,1,jp_tem) + zbeta = rab_n(ji,jj,1,jp_sal) + ! + IF ( l_conv(ji,jj) ) THEN ! Unstable + ! + IF( ln_osm_mle ) THEN + zvel_max = ( swstrl(ji,jj)**3 + swstrc(ji,jj)**3 )**p2third / hbl(ji,jj) + ELSE + zvel_max = -1.0_wp * ( 1.0_wp + 1.0_wp * ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird * rn_Dt / & + & hbl(ji,jj) ) * pwb_ent(ji,jj) / & + & ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird + ENDIF + DO jk = nmld(ji,jj), nbld(ji,jj) + zdb = MAX( grav * ( zthermal * ( av_t_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) ) - & + & zbeta * ( av_s_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), 0.0_wp ) + zvel_max + ! + IF ( ln_osm_mle ) THEN + zhbl_s = zhbl_s + MIN( rn_Dt * ( ( -1.0_wp * pwb_ent(ji,jj) - 2.0_wp * pwb_fk_b(ji,jj) ) / zdb ) / & + & REAL( nbld(ji,jj) - nmld(ji,jj), KIND=wp ), (e3w_0(ji,jj,jm)*(1._wp+r3t(ji,jj,Kmm))) ) + ELSE + zhbl_s = zhbl_s + MIN( rn_Dt * ( -1.0_wp * pwb_ent(ji,jj) / zdb ) / & + & REAL( nbld(ji,jj) - nmld(ji,jj), KIND=wp ), (e3w_0(ji,jj,jm)*(1._wp+r3t(ji,jj,Kmm))) ) + ENDIF + ! zhbl_s = MIN(zhbl_s, (gdepw_0(ji,jj, mbkt(ji,jj) + 1)*(1._wp+r3t(ji,jj,Kmm))) - depth_tol) + IF ( zhbl_s >= (gdepw_0(ji,jj,mbkt(ji,jj) + 1)*(1._wp+r3t(ji,jj,Kmm))) ) THEN + zhbl_s = MIN( zhbl_s, (gdepw_0(ji,jj, mbkt(ji,jj) + 1)*(1._wp+r3t(ji,jj, Kmm ))) - depth_tol ) + l_pyc(ji,jj) = .FALSE. + ENDIF + IF ( zhbl_s >= (gdepw_0(ji,jj,jm+1)*(1._wp+r3t(ji,jj,Kmm))) ) jm = jm + 1 + END DO + hbl(ji,jj) = zhbl_s + nbld(ji,jj) = jm + ELSE ! Stable + DO jk = nmld(ji,jj), nbld(ji,jj) + zdb = MAX( grav * ( zthermal * ( av_t_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) ) - & + & zbeta * ( av_s_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), 0.0_wp ) + & + & 2.0_wp * svstr(ji,jj)**2 / zhbl_s + ! + ! Alan is thuis right? I have simply changed hbli to hbl + shol(ji,jj) = -1.0_wp * zhbl_s / ( ( svstr(ji,jj)**3 + epsln ) / swbav(ji,jj) ) + pdhdt(ji,jj) = -1.0_wp * ( swbav(ji,jj) - 0.04_wp / 2.0_wp * swstrl(ji,jj)**3 / zhbl_s - & + & 0.15_wp / 2.0_wp * ( 1.0_wp - EXP( -1.5_wp * sla(ji,jj) ) ) * & + & sustar(ji,jj)**3 / zhbl_s ) * & + & ( 0.725_wp + 0.225_wp * EXP( -7.5_wp * shol(ji,jj) ) ) + pdhdt(ji,jj) = pdhdt(ji,jj) + swbav(ji,jj) + zhbl_s = zhbl_s + MIN( pdhdt(ji,jj) / zdb * rn_Dt / REAL( nbld(ji,jj) - nmld(ji,jj), KIND=wp ), & + & (e3w_0(ji,jj,jm)*(1._wp+r3t(ji,jj,Kmm))) ) + + ! zhbl_s = MIN(zhbl_s, (gdepw_0(ji,jj, mbkt(ji,jj) + 1)*(1._wp+r3t(ji,jj,Kmm))) - depth_tol) + IF ( zhbl_s >= mbkt(ji,jj) + 1 ) THEN + zhbl_s = MIN( zhbl_s, (gdepw_0(ji,jj,mbkt(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))) - depth_tol ) + l_pyc(ji,jj) = .FALSE. + ENDIF + IF ( zhbl_s >= (gdepw_0(ji,jj,jm)*(1._wp+r3t(ji,jj,Kmm))) ) jm = jm + 1 + END DO + ENDIF ! IF ( l_conv ) + hbl(ji,jj) = MAX( zhbl_s, (gdepw_0(ji,jj,4)*(1._wp+r3t(ji,jj,Kmm))) ) + nbld(ji,jj) = MAX( jm, 4 ) + ELSE + ! change zero or one model level. + hbl(ji,jj) = MAX( phbl_t(ji,jj), (gdepw_0(ji,jj,4)*(1._wp+r3t(ji,jj,Kmm))) ) + ENDIF + phbl(ji,jj) = (gdepw_0(ji,jj,nbld(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + ! + END SUBROUTINE zdf_osm_timestep_hbl + + SUBROUTINE zdf_osm_pycnocline_thickness( Kmm, pdh, phml, pdhdt, phbl, & + & pwb_ent, pdbdz_bl_ext, pwb_fk_b ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_pycnocline_thickness *** + !! + !! ** Purpose : Calculates thickness of the pycnocline + !! + !! ** Method : The thickness is calculated from a prognostic equation + !! that relaxes the pycnocine thickness to a diagnostic + !! value. The time change is calculated assuming the + !! thickness relaxes exponentially. This is done to deal + !! with large timesteps. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(inout) :: pdh ! Pycnocline thickness + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(inout) :: phml ! ML depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL + !! + INTEGER :: jj, ji + INTEGER :: inhml + REAL(wp) :: zari, ztau, zdh_ref, zddhdt, zvel_max + REAL(wp) :: ztmp ! Auxiliary variable + !! + REAL(wp), PARAMETER :: pp_ddh = 2.5_wp, pp_ddh_2 = 3.5_wp ! Also in pycnocline_depth + !!---------------------------------------------------------------------- + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! + IF ( l_shear(ji,jj) ) THEN + ! + IF ( l_conv(ji,jj) ) THEN + ! + IF ( av_db_bl(ji,jj) > 1e-15_wp ) THEN + IF ( n_ddh(ji,jj) == 0 ) THEN + zvel_max = ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**p2third / hbl(ji,jj) + ! ddhdt for pycnocline determined in osm_calculate_dhdt + zddhdt = -1.0_wp * pp_ddh * ( 1.0_wp - 1.6_wp * pdh(ji,jj) / phbl(ji,jj) ) * pwb_ent(ji,jj) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15 ) ) + zddhdt = EXP( -4.0_wp * ABS( ff_t(ji,jj) ) * phbl(ji,jj) / MAX( sustar(ji,jj), 1e-8 ) ) * zddhdt + ! Maximum limit for how thick the shear layer can grow relative to the thickness of the boundary layer + dh(ji,jj) = MIN( dh(ji,jj) + zddhdt * rn_Dt, 0.625_wp * hbl(ji,jj) ) + ELSE ! Need to recalculate because hbl has been updated + IF ( ( swstrc(ji,jj) / svstr(ji,jj) )**3 <= 0.5_wp ) THEN + ztmp = svstr(ji,jj) + ELSE + ztmp = swstrc(ji,jj) + END IF + zari = MIN( 1.5_wp * av_db_bl(ji,jj) / ( phbl(ji,jj) * ( MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) + & + & av_db_bl(ji,jj)**2 / MAX( 4.5_wp * ztmp**2, & + & 1e-12_wp ) ) ), 0.2_wp ) + ztau = MAX( av_db_bl(ji,jj) * ( zari * hbl(ji,jj) ) / & + & ( pp_ddh_2 * MAX( -1.0_wp * pwb_ent(ji,jj), 1e-12_wp ) ), 2.0_wp * rn_Dt ) + dh(ji,jj) = dh(ji,jj) * EXP( -1.0_wp * rn_Dt / ztau ) + & + & zari * phbl(ji,jj) * ( 1.0_wp - EXP( -1.0_wp * rn_Dt / ztau ) ) + IF ( dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zari * phbl(ji,jj) + END IF + ELSE + ztau = MAX( MAX( hbl(ji,jj) / ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird, epsln), 2.0_wp * rn_Dt ) + dh(ji,jj) = dh(ji,jj) * EXP( -1.0_wp * rn_Dt / ztau ) + & + & 0.2_wp * phbl(ji,jj) * ( 1.0_wp - EXP( -1.0_wp * rn_Dt / ztau ) ) + IF ( dh(ji,jj) > hbl(ji,jj) ) dh(ji,jj) = 0.2_wp * hbl(ji,jj) + END IF + ! + ELSE ! l_conv + ! Initially shear only for entraining OSBL. Stable code will be needed if extended to stable OSBL + ztau = hbl(ji,jj) / MAX(svstr(ji,jj), epsln) + IF ( pdhdt(ji,jj) >= 0.0_wp ) THEN ! Probably shouldn't include wm here + ! Boundary layer deepening + IF ( av_db_bl(ji,jj) > 0.0_wp ) THEN + ! Pycnocline thickness set by stratification - use same relationship as for neutral conditions + zari = MIN( 4.5_wp * ( svstr(ji,jj)**2 ) / MAX( av_db_bl(ji,jj) * phbl(ji,jj), epsln ) + 0.01_wp, 0.2_wp ) + zdh_ref = MIN( zari, 0.2_wp ) * hbl(ji,jj) + ELSE + zdh_ref = 0.2_wp * hbl(ji,jj) + ENDIF + ELSE ! IF(dhdt < 0) + zdh_ref = 0.2_wp * hbl(ji,jj) + ENDIF ! IF (dhdt >= 0) + dh(ji,jj) = dh(ji,jj) * EXP( -1.0_wp * rn_Dt / ztau ) + zdh_ref * ( 1.0_wp - EXP( -1.0_wp * rn_Dt / ztau ) ) + IF ( pdhdt(ji,jj) < 0.0_wp .AND. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref ! Can be a problem with dh>hbl for + ! ! rapid collapse + ENDIF + ! + ELSE ! l_shear = .FALSE., calculate ddhdt here + ! + IF ( l_conv(ji,jj) ) THEN + ! + IF( ln_osm_mle ) THEN + IF ( ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) < 0.0_wp ) THEN ! OSBL is deepening. Note wb_fk_b is zero if + ! ! ln_osm_mle=F + IF ( av_db_bl(ji,jj) > 0.0_wp .AND. pdbdz_bl_ext(ji,jj) > 0.0_wp ) THEN + IF ( ( swstrc(ji,jj) / MAX( svstr(ji,jj), epsln) )**3 <= 0.5_wp ) THEN ! Near neutral stability + ztmp = svstr(ji,jj) + ELSE ! Unstable + ztmp = swstrc(ji,jj) + END IF + zari = MIN( 1.5_wp * av_db_bl(ji,jj) / & + & ( phbl(ji,jj) * ( MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) + & + & av_db_bl(ji,jj)**2 / MAX( 4.5_wp * ztmp**2 , 1e-12_wp ) ) ), 0.2_wp ) + ELSE + zari = 0.2_wp + END IF + ELSE + zari = 0.2_wp + END IF + ztau = 0.2_wp * hbl(ji,jj) / MAX( epsln, ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird ) + zdh_ref = zari * hbl(ji,jj) + ELSE ! ln_osm_mle + IF ( av_db_bl(ji,jj) > 0.0_wp .AND. pdbdz_bl_ext(ji,jj) > 0.0_wp ) THEN + IF ( ( swstrc(ji,jj) / MAX( svstr(ji,jj), epsln ) )**3 <= 0.5_wp ) THEN ! Near neutral stability + ztmp = svstr(ji,jj) + ELSE ! Unstable + ztmp = swstrc(ji,jj) + END IF + zari = MIN( 1.5_wp * av_db_bl(ji,jj) / & + & ( phbl(ji,jj) * ( MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) + & + & av_db_bl(ji,jj)**2 / MAX( 4.5_wp * ztmp**2 , 1e-12_wp ) ) ), 0.2_wp ) + ELSE + zari = 0.2_wp + END IF + ztau = hbl(ji,jj) / MAX( epsln, ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird ) + zdh_ref = zari * hbl(ji,jj) + END IF ! ln_osm_mle + dh(ji,jj) = dh(ji,jj) * EXP( -1.0_wp * rn_Dt / ztau ) + zdh_ref * ( 1.0_wp - EXP( -1.0_wp * rn_Dt / ztau ) ) + ! IF ( pdhdt(ji,jj) < 0._wp .and. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref + IF ( dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref + ! Alan: this hml is never defined or used + ELSE ! IF (l_conv) + ! + ztau = hbl(ji,jj) / MAX( svstr(ji,jj), epsln ) + IF ( pdhdt(ji,jj) >= 0.0_wp ) THEN ! Probably shouldn't include wm here + ! Boundary layer deepening + IF ( av_db_bl(ji,jj) > 0.0_wp ) THEN + ! Pycnocline thickness set by stratification - use same relationship as for neutral conditions. + zari = MIN( 4.5_wp * ( svstr(ji,jj)**2 ) / MAX( av_db_bl(ji,jj) * phbl(ji,jj), epsln ) + 0.01_wp , 0.2_wp ) + zdh_ref = MIN( zari, 0.2_wp ) * hbl(ji,jj) + ELSE + zdh_ref = 0.2_wp * hbl(ji,jj) + END IF + ELSE ! IF(dhdt < 0) + zdh_ref = 0.2_wp * hbl(ji,jj) + END IF ! IF (dhdt >= 0) + dh(ji,jj) = dh(ji,jj) * EXP( -1.0_wp * rn_Dt / ztau ) + zdh_ref * ( 1.0_wp - EXP( -1.0_wp * rn_Dt / ztau ) ) + IF ( pdhdt(ji,jj) < 0.0_wp .AND. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref ! Can be a problem with dh>hbl for + ! ! rapid collapse + END IF ! IF (l_conv) + ! + END IF ! l_shear + ! + hml(ji,jj) = hbl(ji,jj) - dh(ji,jj) + inhml = MAX( INT( dh(ji,jj) / MAX( (e3t_0(ji,jj,nbld(ji,jj)-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,nbld(ji,jj)-1))), 1e-3_wp ) ), 1 ) + nmld(ji,jj) = MAX( nbld(ji,jj) - inhml, 3 ) + phml(ji,jj) = (gdepw_0(ji,jj,nmld(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) + pdh(ji,jj) = phbl(ji,jj) - phml(ji,jj) + ! + END DO ; END DO + ! + END SUBROUTINE zdf_osm_pycnocline_thickness + + SUBROUTINE zdf_osm_pycnocline_buoyancy_profiles( Kmm, kp_ext, pdbdz, palpha, pdh, & + & phbl, pdbdz_bl_ext, phml, pdhdt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_pycnocline_buoyancy_profiles *** + !! + !! ** Purpose : calculate pycnocline buoyancy profiles + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index + INTEGER, DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: kp_ext ! External-level offsets + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1),jpk), INTENT( out) :: pdbdz ! Gradients in the pycnocline + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT( out) :: palpha + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline thickness + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdhdt ! Rates of change of hbl + !! + INTEGER :: jk, jj, ji + REAL(wp) :: zbgrad + REAL(wp) :: zgamma_b_nd, znd + REAL(wp) :: zzeta_m + REAL(wp) :: ztmp ! Auxiliary variable + !! + REAL(wp), PARAMETER :: pp_gamma_b = 2.25_wp + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !!---------------------------------------------------------------------- + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + pdbdz(ji,jj,:) = pp_large + palpha(ji,jj) = pp_large + END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! + IF ( nbld(ji,jj) + kp_ext(ji,jj) < mbkt(ji,jj) ) THEN + ! + IF ( l_conv(ji,jj) ) THEN ! Convective conditions + ! + IF ( l_pyc(ji,jj) ) THEN + ! + zzeta_m = 0.1_wp + 0.3_wp / ( 1.0_wp + EXP( -3.5_wp * LOG10( -1.0_wp * shol(ji,jj) ) ) ) + palpha(ji,jj) = 2.0_wp * ( 1.0_wp - ( 0.80_wp * zzeta_m + 0.5_wp * SQRT( 3.14159_wp / pp_gamma_b ) ) * & + & pdbdz_bl_ext(ji,jj) * pdh(ji,jj) / av_db_ml(ji,jj) ) / & + & ( 0.723_wp + SQRT( 3.14159_wp / pp_gamma_b ) ) + palpha(ji,jj) = MAX( palpha(ji,jj), 0.0_wp ) + ztmp = 1.0_wp / MAX( pdh(ji,jj), epsln ) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Commented lines in this section are not needed in new code, once tested ! + ! can be removed ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! ztgrad = zalpha * av_dt_ml(ji,jj) * ztmp + zdtdz_bl_ext(ji,jj) + ! zsgrad = zalpha * av_ds_ml(ji,jj) * ztmp + zdsdz_bl_ext(ji,jj) + zbgrad = palpha(ji,jj) * av_db_ml(ji,jj) * ztmp + pdbdz_bl_ext(ji,jj) + zgamma_b_nd = pdbdz_bl_ext(ji,jj) * pdh(ji,jj) / MAX( av_db_ml(ji,jj), epsln ) + DO jk = 2, nbld(ji,jj) + znd = -1.0_wp * ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - phbl(ji,jj) ) * ztmp + IF ( znd <= zzeta_m ) THEN + ! zdtdz(ji,jj,jk) = zdtdz_bl_ext(ji,jj) + zalpha * av_dt_ml(ji,jj) * ztmp * & + ! & EXP( -6.0 * ( znd -zzeta_m )**2 ) + ! zdsdz(ji,jj,jk) = zdsdz_bl_ext(ji,jj) + zalpha * av_ds_ml(ji,jj) * ztmp * & + ! & EXP( -6.0 * ( znd -zzeta_m )**2 ) + pdbdz(ji,jj,jk) = pdbdz_bl_ext(ji,jj) + palpha(ji,jj) * av_db_ml(ji,jj) * ztmp * & + & EXP( -6.0_wp * ( znd -zzeta_m )**2 ) + ELSE + ! zdtdz(ji,jj,jk) = ztgrad * EXP( -pp_gamma_b * ( znd - zzeta_m )**2 ) + ! zdsdz(ji,jj,jk) = zsgrad * EXP( -pp_gamma_b * ( znd - zzeta_m )**2 ) + pdbdz(ji,jj,jk) = zbgrad * EXP( -1.0_wp * pp_gamma_b * ( znd - zzeta_m )**2 ) + END IF + END DO + END IF ! If no pycnocline pycnocline gradients set to zero + ! + ELSE ! Stable conditions + ! If pycnocline profile only defined when depth steady of increasing. + IF ( pdhdt(ji,jj) > 0.0_wp ) THEN ! Depth increasing, or steady. + IF ( av_db_bl(ji,jj) > 0.0_wp ) THEN + IF ( shol(ji,jj) >= 0.5_wp ) THEN ! Very stable - 'thick' pycnocline + ztmp = 1.0_wp / MAX( phbl(ji,jj), epsln ) + zbgrad = av_db_bl(ji,jj) * ztmp + DO jk = 2, nbld(ji,jj) + znd = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * ztmp + pdbdz(ji,jj,jk) = zbgrad * EXP( -15.0_wp * ( znd - 0.9_wp )**2 ) + END DO + ELSE ! Slightly stable - 'thin' pycnoline - needed when stable layer begins to form. + ztmp = 1.0_wp / MAX( pdh(ji,jj), epsln ) + zbgrad = av_db_bl(ji,jj) * ztmp + DO jk = 2, nbld(ji,jj) + znd = -1.0_wp * ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - phml(ji,jj) ) * ztmp + pdbdz(ji,jj,jk) = zbgrad * EXP( -1.75_wp * ( znd + 0.75_wp )**2 ) + END DO + END IF ! IF (shol >=0.5) + END IF ! IF (av_db_bl> 0.) + END IF ! IF (pdhdt >= 0) pdhdt < 0 not considered since pycnocline profile is zero and profile arrays are + ! ! intialized to zero + ! + END IF ! IF (l_conv) + ! + END IF ! IF ( nbld(ji,jj) < mbkt(ji,jj) ) + ! + END DO ; END DO + ! + IF ( ln_dia_pyc_scl ) THEN ! Output of pycnocline gradient profiles + CALL zdf_osm_iomput( "zdbdz_pyc", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * pdbdz(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + END IF + ! + END SUBROUTINE zdf_osm_pycnocline_buoyancy_profiles + + SUBROUTINE zdf_osm_diffusivity_viscosity( Kbb, Kmm, pdiffut, pviscos, phbl, & + & phml, pdh, pdhdt, pshear, & + & pwb_ent, pwb_min ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_diffusivity_viscosity *** + !! + !! ** Purpose : Determines the eddy diffusivity and eddy viscosity + !! profiles in the mixed layer and the pycnocline. + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kbb, Kmm ! Ocean time-level indices + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1),jpk), INTENT(inout) :: pdiffut ! t-diffusivity + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1),jpk), INTENT(inout) :: pviscos ! Viscosity + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pshear ! Shear production + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pwb_min + !! + INTEGER :: ji, jj, jk ! Loop indices + !! Scales used to calculate eddy diffusivity and viscosity profiles + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zdifml_sc, zvisml_sc + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zdifpyc_n_sc, zdifpyc_s_sc + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zvispyc_n_sc, zvispyc_s_sc + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zbeta_d_sc, zbeta_v_sc + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zb_coup, zc_coup_vis, zc_coup_dif + !! + REAL(wp) :: zvel_sc_pyc, zvel_sc_ml, zstab_fac, zz_b + REAL(wp) :: za_cubic, zb_d_cubic, zc_d_cubic, zd_d_cubic, & ! Coefficients in cubic polynomial specifying diffusivity + & zb_v_cubic, zc_v_cubic, zd_v_cubic ! and viscosity in pycnocline + REAL(wp) :: zznd_ml, zznd_pyc, ztmp + REAL(wp) :: zmsku, zmskv + !! + REAL(wp), PARAMETER :: pp_dif_ml = 0.8_wp, pp_vis_ml = 0.375_wp + REAL(wp), PARAMETER :: pp_dif_pyc = 0.15_wp, pp_vis_pyc = 0.142_wp + REAL(wp), PARAMETER :: pp_vispyc_shr = 0.15_wp + !!---------------------------------------------------------------------- + ! + zb_coup(:,:) = 0.0_wp + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) ) THEN + ! + zvel_sc_pyc = ( 0.15_wp * svstr(ji,jj)**3 + swstrc(ji,jj)**3 + 4.25_wp * pshear(ji,jj) * phbl(ji,jj) )**pthird + zvel_sc_ml = ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird + zstab_fac = ( phml(ji,jj) / zvel_sc_ml * & + & ( 1.4_wp - 0.4_wp / ( 1.0_wp + EXP(-3.5_wp * LOG10( -1.0_wp * shol(ji,jj) ) ) )**1.25_wp ) )**2 + ! + zdifml_sc(ji,jj) = pp_dif_ml * phml(ji,jj) * zvel_sc_ml + zvisml_sc(ji,jj) = pp_vis_ml * zdifml_sc(ji,jj) + ! + IF ( l_pyc(ji,jj) ) THEN + zdifpyc_n_sc(ji,jj) = pp_dif_pyc * zvel_sc_ml * pdh(ji,jj) + zvispyc_n_sc(ji,jj) = 0.09_wp * zvel_sc_pyc * ( 1.0_wp - phbl(ji,jj) / pdh(ji,jj) )**2 * & + & ( 0.005_wp * ( av_u_ml(ji,jj) - av_u_bl(ji,jj) )**2 + & + & 0.0075_wp * ( av_v_ml(ji,jj) - av_v_bl(ji,jj) )**2 ) / & + & pdh(ji,jj) + zvispyc_n_sc(ji,jj) = pp_vis_pyc * zvel_sc_ml * pdh(ji,jj) + zvispyc_n_sc(ji,jj) * zstab_fac + ! + IF ( l_shear(ji,jj) .AND. n_ddh(ji,jj) /= 2 ) THEN + ztmp = pp_vispyc_shr * ( pshear(ji,jj) * phbl(ji,jj) )**pthird * phbl(ji,jj) + zdifpyc_n_sc(ji,jj) = zdifpyc_n_sc(ji,jj) + ztmp + zvispyc_n_sc(ji,jj) = zvispyc_n_sc(ji,jj) + ztmp + ENDIF + ! + zdifpyc_s_sc(ji,jj) = pwb_ent(ji,jj) + 0.0025_wp * zvel_sc_pyc * ( phbl(ji,jj) / pdh(ji,jj) - 1.0_wp ) * & + & ( av_b_ml(ji,jj) - av_b_bl(ji,jj) ) + zvispyc_s_sc(ji,jj) = 0.09_wp * ( pwb_min(ji,jj) + 0.0025_wp * zvel_sc_pyc * & + & ( phbl(ji,jj) / pdh(ji,jj) - 1.0_wp ) * & + & ( av_b_ml(ji,jj) - av_b_bl(ji,jj) ) ) + zdifpyc_s_sc(ji,jj) = 0.09_wp * zdifpyc_s_sc(ji,jj) * zstab_fac + zvispyc_s_sc(ji,jj) = zvispyc_s_sc(ji,jj) * zstab_fac + ! + zdifpyc_s_sc(ji,jj) = MAX( zdifpyc_s_sc(ji,jj), -0.5_wp * zdifpyc_n_sc(ji,jj) ) + zvispyc_s_sc(ji,jj) = MAX( zvispyc_s_sc(ji,jj), -0.5_wp * zvispyc_n_sc(ji,jj) ) + + zbeta_d_sc(ji,jj) = 1.0_wp - ( ( zdifpyc_n_sc(ji,jj) + 1.4_wp * zdifpyc_s_sc(ji,jj) ) / & + & ( zdifml_sc(ji,jj) + epsln ) )**p2third + zbeta_v_sc(ji,jj) = 1.0_wp - 2.0_wp * ( zvispyc_n_sc(ji,jj) + zvispyc_s_sc(ji,jj) ) / ( zvisml_sc(ji,jj) + epsln ) + ELSE + zdifpyc_n_sc(ji,jj) = pp_dif_pyc * zvel_sc_ml * pdh(ji,jj) ! ag 19/03 + zdifpyc_s_sc(ji,jj) = 0.0_wp ! ag 19/03 + zvispyc_n_sc(ji,jj) = pp_vis_pyc * zvel_sc_ml * pdh(ji,jj) ! ag 19/03 + zvispyc_s_sc(ji,jj) = 0.0_wp ! ag 19/03 + IF(l_coup(ji,jj) ) THEN ! ag 19/03 + ! code from SUBROUTINE tke_tke zdftke.F90; uses bottom drag velocity rCdU_bot(ji,jj) = -Cd|ub| + ! already calculated at T-points in SUBROUTINE zdf_drg from zdfdrg.F90 + ! Gives friction velocity sqrt bottom drag/rho_0 i.e. u* = SQRT(rCdU_bot*ub) + ! wet-cell averaging .. + zmsku = 0.5_wp * ( 2.0_wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) + zmskv = 0.5_wp * ( 2.0_wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) + zb_coup(ji,jj) = 0.4_wp * SQRT(-1.0_wp * rCdU_bot(ji,jj) * & + & SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 & + & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) ) + + zz_b = -1.0_wp * (gdepw_0(ji,jj,mbkt(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))) ! ag 19/03 + zc_coup_vis(ji,jj) = -0.5_wp * ( 0.5_wp * zvisml_sc(ji,jj) / phml(ji,jj) - zb_coup(ji,jj) ) / & + & ( phml(ji,jj) + zz_b ) ! ag 19/03 + zz_b = -1.0_wp * phml(ji,jj) + (gdepw_0(ji,jj,mbkt(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))) ! ag 19/03 + zbeta_v_sc(ji,jj) = 1.0_wp - 2.0_wp * ( zb_coup(ji,jj) * zz_b + zc_coup_vis(ji,jj) * zz_b**2 ) / & + & zvisml_sc(ji,jj) ! ag 19/03 + zbeta_d_sc(ji,jj) = 1.0_wp - ( ( zb_coup(ji,jj) * zz_b + zc_coup_vis(ji,jj) * zz_b**2 ) / & + & zdifml_sc(ji,jj) )**p2third + zc_coup_dif(ji,jj) = 0.5_wp * ( -zdifml_sc(ji,jj) / phml(ji,jj) * ( 1.0_wp - zbeta_d_sc(ji,jj) )**1.5_wp + & + & 1.5_wp * ( zdifml_sc(ji,jj) / phml(ji,jj) ) * zbeta_d_sc(ji,jj) * & + & SQRT( 1.0_wp - zbeta_d_sc(ji,jj) ) - zb_coup(ji,jj) ) / zz_b ! ag 19/03 + ELSE ! ag 19/03 + zbeta_d_sc(ji,jj) = 1.0_wp - ( ( zdifpyc_n_sc(ji,jj) + 1.4_wp * zdifpyc_s_sc(ji,jj) ) / & + & ( zdifml_sc(ji,jj) + epsln ) )**p2third ! ag 19/03 + zbeta_v_sc(ji,jj) = 1.0_wp - 2.0_wp * ( zvispyc_n_sc(ji,jj) + zvispyc_s_sc(ji,jj) ) / & + & ( zvisml_sc(ji,jj) + epsln ) ! ag 19/03 + ENDIF ! ag 19/03 + ENDIF ! ag 19/03 + ELSE + zdifml_sc(ji,jj) = svstr(ji,jj) * phbl(ji,jj) * MAX( EXP ( -1.0_wp * ( shol(ji,jj) / 0.6_wp )**2 ), 0.2_wp) + zvisml_sc(ji,jj) = zdifml_sc(ji,jj) + END IF + END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) ) THEN + DO jk = 2, nmld(ji,jj) ! Mixed layer diffusivity + zznd_ml = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / phml(ji,jj) + pdiffut(ji,jj,jk) = zdifml_sc(ji,jj) * zznd_ml * ( 1.0_wp - zbeta_d_sc(ji,jj) * zznd_ml )**1.5 + pviscos(ji,jj,jk) = zvisml_sc(ji,jj) * zznd_ml * ( 1.0_wp - zbeta_v_sc(ji,jj) * zznd_ml ) * & + & ( 1.0_wp - 0.5_wp * zznd_ml**2 ) + END DO + ! + ! Coupling to bottom + ! + IF ( l_coup(ji,jj) ) THEN ! ag 19/03 + DO jk = mbkt(ji,jj), nmld(ji,jj), -1 ! ag 19/03 + zz_b = -1.0_wp * ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - (gdepw_0(ji,jj,mbkt(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))) ) ! ag 19/03 + pviscos(ji,jj,jk) = zb_coup(ji,jj) * zz_b + zc_coup_vis(ji,jj) * zz_b**2 ! ag 19/03 + pdiffut(ji,jj,jk) = zb_coup(ji,jj) * zz_b + zc_coup_dif(ji,jj) * zz_b**2 ! ag 19/03 + END DO ! ag 19/03 + ENDIF ! ag 19/03 + ! Pycnocline + IF ( l_pyc(ji,jj) ) THEN + ! Diffusivity and viscosity profiles in the pycnocline given by + ! cubic polynomial. Note, if l_pyc TRUE can't be coupled to seabed. + za_cubic = 0.5_wp + zb_d_cubic = -1.75_wp * zdifpyc_s_sc(ji,jj) / zdifpyc_n_sc(ji,jj) + zd_d_cubic = ( pdh(ji,jj) * zdifml_sc(ji,jj) / phml(ji,jj) * SQRT( 1.0_wp - zbeta_d_sc(ji,jj) ) * & + & ( 2.5_wp * zbeta_d_sc(ji,jj) - 1.0_wp ) - 0.85_wp * zdifpyc_s_sc(ji,jj) ) / & + & MAX( zdifpyc_n_sc(ji,jj), 1.0e-8_wp ) + zd_d_cubic = zd_d_cubic - zb_d_cubic - 2.0_wp * ( 1.0_wp - za_cubic - zb_d_cubic ) + zc_d_cubic = 1.0_wp - za_cubic - zb_d_cubic - zd_d_cubic + zb_v_cubic = -1.75_wp * zvispyc_s_sc(ji,jj) / zvispyc_n_sc(ji,jj) + zd_v_cubic = ( 0.5_wp * zvisml_sc(ji,jj) * pdh(ji,jj) / phml(ji,jj) - 0.85_wp * zvispyc_s_sc(ji,jj) ) / & + & MAX( zvispyc_n_sc(ji,jj), 1.0e-8_wp ) + zd_v_cubic = zd_v_cubic - zb_v_cubic - 2.0_wp * ( 1.0_wp - za_cubic - zb_v_cubic ) + zc_v_cubic = 1.0_wp - za_cubic - zb_v_cubic - zd_v_cubic + DO jk = nmld(ji,jj) , nbld(ji,jj) + zznd_pyc = -1.0_wp * ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - phbl(ji,jj) ) / MAX(pdh(ji,jj), 1.0e-6_wp ) + ztmp = ( 1.75_wp * zznd_pyc - 0.15_wp * zznd_pyc**2 - 0.2_wp * zznd_pyc**3 ) + ! + pdiffut(ji,jj,jk) = zdifpyc_n_sc(ji,jj) * & + & ( za_cubic + zb_d_cubic * zznd_pyc + zc_d_cubic * zznd_pyc**2 + zd_d_cubic * zznd_pyc**3 ) + ! + pdiffut(ji,jj,jk) = pdiffut(ji,jj,jk) + zdifpyc_s_sc(ji,jj) * ztmp + pviscos(ji,jj,jk) = zvispyc_n_sc(ji,jj) * & + & ( za_cubic + zb_v_cubic * zznd_pyc + zc_v_cubic * zznd_pyc**2 + zd_v_cubic * zznd_pyc**3 ) + pviscos(ji,jj,jk) = pviscos(ji,jj,jk) + zvispyc_s_sc(ji,jj) * ztmp + END DO + ! IF ( pdhdt(ji,jj) > 0._wp ) THEN + ! zdiffut(ji,jj,nbld(ji,jj)+1) = MAX( 0.5 * pdhdt(ji,jj) * (e3w_0(ji,jj,nbld(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))), 1.0e-6 ) + ! zviscos(ji,jj,nbld(ji,jj)+1) = MAX( 0.5 * pdhdt(ji,jj) * (e3w_0(ji,jj,nbld(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))), 1.0e-6 ) + ! ELSE + ! zdiffut(ji,jj,nbld(ji,jj)) = 0._wp + ! zviscos(ji,jj,nbld(ji,jj)) = 0._wp + ! ENDIF + ENDIF + ELSE + ! Stable conditions + DO jk = 2, nbld(ji,jj) + zznd_ml = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / phbl(ji,jj) + pdiffut(ji,jj,jk) = 0.75_wp * zdifml_sc(ji,jj) * zznd_ml * ( 1.0_wp - zznd_ml )**1.5_wp + pviscos(ji,jj,jk) = 0.375_wp * zvisml_sc(ji,jj) * zznd_ml * ( 1.0_wp - zznd_ml ) * ( 1.0_wp - zznd_ml**2 ) + END DO + ! + IF ( pdhdt(ji,jj) > 0.0_wp ) THEN + pdiffut(ji,jj,nbld(ji,jj)) = MAX( pdhdt(ji,jj), 1.0e-6_wp) * (e3w_0(ji, jj, nbld(ji,jj))*(1._wp+r3t(ji, jj, Kmm))) + pviscos(ji,jj,nbld(ji,jj)) = pdiffut(ji,jj,nbld(ji,jj)) + ENDIF + ENDIF ! End if ( l_conv ) + ! + END DO ; END DO + CALL zdf_osm_iomput( "pb_coup", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zb_coup(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! BBL-coupling velocity scale + ! + END SUBROUTINE zdf_osm_diffusivity_viscosity + + SUBROUTINE zdf_osm_fgr_terms( Kmm, kp_ext, phbl, phml, pdh, & + & pdhdt, pshear, pdtdz_bl_ext, pdsdz_bl_ext, pdbdz_bl_ext, & + & pdiffut, pviscos ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_fgr_terms *** + !! + !! ** Purpose : Compute non-gradient terms in flux-gradient relationship + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Time-level index + INTEGER, DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: kp_ext ! Offset for external level + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pshear ! Shear production + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdtdz_bl_ext ! External temperature gradients + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdsdz_bl_ext ! External salinity gradients + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1),jpk), INTENT(in ) :: pdiffut ! t-diffusivity + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1),jpk), INTENT(in ) :: pviscos ! Viscosity + !! + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zalpha_pyc ! + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1),jpk) :: zdbdz_pyc ! Parametrised gradient of buoyancy in the pycnocline + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: z3ddz_pyc_1, z3ddz_pyc_2 ! Pycnocline gradient/shear profiles + !! + INTEGER :: ji, jj, jk, jkm_bld, jkf_mld, jkm_mld ! Loop indices + INTEGER :: istat ! Memory allocation status + REAL(wp) :: zznd_d, zznd_ml, zznd_pyc, znd ! Temporary non-dimensional depths + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zsc_wth_1,zsc_ws_1 ! Temporary scales + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zsc_uw_1, zsc_uw_2 ! Temporary scales + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zsc_vw_1, zsc_vw_2 ! Temporary scales + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: ztau_sc_u ! Dissipation timescale at base of WML + REAL(wp) :: zbuoy_pyc_sc, zdelta_pyc ! + REAL(wp) :: zl_c,zl_l,zl_eps ! Used to calculate turbulence length scale + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: za_cubic, zb_cubic ! Coefficients in cubic polynomial specifying + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zc_cubic, zd_cubic ! diffusivity in pycnocline + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zwt_pyc_sc_1, zws_pyc_sc_1 ! + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zzeta_pyc ! + REAL(wp) :: zomega, zvw_max ! + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zuw_bse,zvw_bse ! Momentum, heat, and salinity fluxes + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zwth_ent,zws_ent ! at the top of the pycnocline + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: zsc_wth_pyc, zsc_ws_pyc ! Scales for pycnocline transport term + REAL(wp) :: ztmp ! + REAL(wp) :: ztgrad, zsgrad, zbgrad ! Variables used to calculate pycnocline + !! ! gradients + REAL(wp) :: zugrad, zvgrad ! Variables for calculating pycnocline shear + REAL(wp) :: zdtdz_pyc ! Parametrized gradient of temperature in + !! ! pycnocline + REAL(wp) :: zdsdz_pyc ! Parametrised gradient of salinity in + !! ! pycnocline + REAL(wp) :: zdudz_pyc ! u-shear across the pycnocline + REAL(wp) :: zdvdz_pyc ! v-shear across the pycnocline + !!---------------------------------------------------------------------- + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Pycnocline gradients for scalars and velocity + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL zdf_osm_pycnocline_buoyancy_profiles( Kmm, kp_ext, zdbdz_pyc, zalpha_pyc, pdh, & + & phbl, pdbdz_bl_ext, phml, pdhdt ) + ! + ! Auxiliary indices + ! ----------------- + jkm_bld = 0 + jkf_mld = jpk + jkm_mld = 0 + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( nbld(ji,jj) > jkm_bld ) jkm_bld = nbld(ji,jj) + IF ( nmld(ji,jj) < jkf_mld ) jkf_mld = nmld(ji,jj) + IF ( nmld(ji,jj) > jkm_mld ) jkm_mld = nmld(ji,jj) + END DO ; END DO + ! + ! Stokes term in scalar flux, flux-gradient relationship + ! ------------------------------------------------------ + WHERE ( l_conv(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) + zsc_wth_1(:,:) = swstrl(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 * swth0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / & + & ( svstr(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + 0.5_wp * swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + epsln ) + zsc_ws_1(:,:) = swstrl(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 * sws0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / & + & ( svstr(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + 0.5_wp * swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + epsln ) + ELSEWHERE + zsc_wth_1(:,:) = 2.0_wp * swthav(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + zsc_ws_1(:,:) = 2.0_wp * swsav(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + ENDWHERE + DO jk = 2, MAX( jkm_mld, jkm_bld ) ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) ) THEN + IF ( jk <= nmld(ji,jj) ) THEN + zznd_d = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / dstokes(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 1.35_wp * EXP( -1.0_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -2.0_wp * zznd_d ) ) * zsc_wth_1(ji,jj) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 1.35_wp * EXP( -1.0_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -2.0_wp * zznd_d ) ) * zsc_ws_1(ji,jj) + END IF + ELSE ! Stable conditions + IF ( jk <= nbld(ji,jj) ) THEN + zznd_d = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / dstokes(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 2.15_wp * EXP( -0.85_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -4.0_wp * zznd_d ) ) * zsc_wth_1(ji,jj) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 2.15_wp * EXP( -0.85_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -4.0_wp * zznd_d ) ) * zsc_ws_1(ji,jj) + END IF + END IF ! Check on l_conv + END DO ; END DO ; END DO + ! + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "ghamu_00", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * ghamu(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + CALL zdf_osm_iomput( "ghamv_00", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * ghamv(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + END IF + ! + ! Stokes term in flux-gradient relationship (note in zsc_uw_n don't use + ! svstr since term needs to go to zero as swstrl goes to zero) + ! --------------------------------------------------------------------- + WHERE ( l_conv(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) + zsc_uw_1(:,:) = ( swstrl(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + & + & 0.5_wp * swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 )**pthird * sustke(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / & + & MAX( ( 1.0_wp - 1.0_wp * 6.5_wp * sla(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**( 8.0_wp / 3.0_wp ) ), 0.2_wp ) + zsc_uw_2(:,:) = ( swstrl(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + & + & 0.5_wp * swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 )**pthird * sustke(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / & + & MIN( sla(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**( 8.0_wp / 3.0_wp ) + epsln, 0.12_wp ) + zsc_vw_1(:,:) = ff_t(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * phml(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * sustke(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 * & + & MIN( sla(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**( 8.0_wp / 3.0_wp ), 0.12_wp ) / & + & ( ( svstr(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + 0.5_wp * swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 )**( 2.0_wp / 3.0_wp ) + epsln ) + ELSEWHERE + zsc_uw_1(:,:) = sustar(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**2 + zsc_vw_1(:,:) = ff_t(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * phbl(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * sustke(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 * & + & MIN( sla(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**( 8.0_wp / 3.0_wp ), 0.12_wp ) / ( svstr(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**2 + epsln ) + ENDWHERE + DO jk = 2, MAX( jkm_mld, jkm_bld ) ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) ) THEN + IF ( jk <= nmld(ji,jj) ) THEN + zznd_d = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + ( -0.05_wp * EXP( -0.4_wp * zznd_d ) * zsc_uw_1(ji,jj) + & + & 0.00125_wp * EXP( -1.0_wp * zznd_d ) * zsc_uw_2(ji,jj) ) * & + & ( 1.0_wp - EXP( -2.0_wp * zznd_d ) ) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) - 0.65_wp * 0.15_wp * EXP( -1.0_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -2.0_wp * zznd_d ) ) * zsc_vw_1(ji,jj) + END IF + ELSE ! Stable conditions + IF ( jk <= nbld(ji,jj) ) THEN ! Corrected to nbld + zznd_d = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) - 0.75_wp * 1.3_wp * EXP( -0.5_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -4.0_wp * zznd_d ) ) * zsc_uw_1(ji,jj) + END IF + END IF + END DO ; END DO ; END DO + ! + ! Buoyancy term in flux-gradient relationship [note : includes ROI ratio + ! (X0.3) and pressure (X0.5)] + ! ---------------------------------------------------------------------- + WHERE ( l_conv(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) + zsc_wth_1(:,:) = swbav(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * swth0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * ( 1.0_wp + EXP( 0.2_wp * shol(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) ) * & + & phml(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / ( svstr(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + 0.5_wp * swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + epsln ) + zsc_ws_1(:,:) = swbav(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * sws0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * ( 1.0_wp + EXP( 0.2_wp * shol(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) ) * & + & phml(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / ( svstr(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + 0.5_wp * swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + epsln ) + ELSEWHERE + zsc_wth_1(:,:) = 0.0_wp + zsc_ws_1(:,:) = 0.0_wp + ENDWHERE + DO jk = 2, MAX( jkm_mld, jkm_bld ) ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) ) THEN + IF ( jk <= nmld(ji,jj) ) THEN + zznd_ml = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / phml(ji,jj) + ! Calculate turbulent time scale + zl_c = 0.9_wp * ( 1.0_wp - EXP( -5.0_wp * ( zznd_ml + zznd_ml**3 / 3.0_wp ) ) ) * & + & ( 1.0_wp - EXP( -15.0_wp * ( 1.2_wp - zznd_ml ) ) ) + zl_l = 2.0_wp * ( 1.0_wp - EXP( -2.0_wp * ( zznd_ml + zznd_ml**3 / 3.0_wp ) ) ) * & + & ( 1.0_wp - EXP( -8.0_wp * ( 1.15_wp - zznd_ml ) ) ) * ( 1.0_wp + dstokes(ji,jj) / phml (ji,jj) ) + zl_eps = zl_l + ( zl_c - zl_l ) / ( 1.0_wp + EXP( -3.0_wp * LOG10( -1.0_wp * shol(ji,jj) ) ) )**( 3.0_wp / 2.0_wp ) + ! Non-gradient buoyancy terms + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3_wp * 0.4_wp * zsc_wth_1(ji,jj) * zl_eps / ( 0.15_wp + zznd_ml ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3_wp * 0.4_wp * zsc_ws_1(ji,jj) * zl_eps / ( 0.15_wp + zznd_ml ) + END IF + ELSE ! Stable conditions + IF ( jk <= nbld(ji,jj) ) THEN + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zsc_wth_1(ji,jj) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + zsc_ws_1(ji,jj) + END IF + END IF + END DO ; END DO ; END DO + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) .AND. l_pyc(ji,jj) ) THEN + ztau_sc_u(ji,jj) = phml(ji,jj) / ( svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird * & + & ( 1.4_wp - 0.4_wp / ( 1.0_wp + EXP( -3.5_wp * LOG10( -1.0_wp * shol(ji,jj) ) ) )**1.5_wp ) + zwth_ent(ji,jj) = -0.003_wp * ( 0.15_wp * svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird * & + & ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_dt_ml(ji,jj) + zws_ent(ji,jj) = -0.003_wp * ( 0.15_wp * svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird * & + & ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_ds_ml(ji,jj) + IF ( dh(ji,jj) < 0.2_wp * hbl(ji,jj) ) THEN + zbuoy_pyc_sc = 2.0_wp * MAX( av_db_ml(ji,jj), 0.0_wp ) / pdh(ji,jj) + zdelta_pyc = ( svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird / & + & SQRT( MAX( zbuoy_pyc_sc, ( svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**p2third / pdh(ji,jj)**2 ) ) + zwt_pyc_sc_1(ji,jj) = 0.325_wp * ( zalpha_pyc(ji,jj) * av_dt_ml(ji,jj) / pdh(ji,jj) + pdtdz_bl_ext(ji,jj) ) * & + & zdelta_pyc**2 / pdh(ji,jj) + zws_pyc_sc_1(ji,jj) = 0.325_wp * ( zalpha_pyc(ji,jj) * av_ds_ml(ji,jj) / pdh(ji,jj) + pdsdz_bl_ext(ji,jj) ) * & + & zdelta_pyc**2 / pdh(ji,jj) + zzeta_pyc(ji,jj) = 0.15_wp - 0.175_wp / ( 1.0_wp + EXP( -3.5_wp * LOG10( -1.0_wp * shol(ji,jj) ) ) ) + END IF + END IF + END DO ; END DO + DO jk = 2, jkm_bld ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) .AND. l_pyc(ji,jj) .AND. ( jk <= nbld(ji,jj) ) ) THEN + zznd_pyc = -1.0_wp * ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - phbl(ji,jj) ) / pdh(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) - & + & 0.045_wp * ( ( zwth_ent(ji,jj) * zdbdz_pyc(ji,jj,jk) ) * ztau_sc_u(ji,jj)**2 ) * & + & MAX( ( 1.75_wp * zznd_pyc -0.15_wp * zznd_pyc**2 - 0.2_wp * zznd_pyc**3 ), 0.0_wp ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) - & + & 0.045_wp * ( ( zws_ent(ji,jj) * zdbdz_pyc(ji,jj,jk) ) * ztau_sc_u(ji,jj)**2 ) * & + & MAX( ( 1.75_wp * zznd_pyc -0.15_wp * zznd_pyc**2 - 0.2_wp * zznd_pyc**3 ), 0.0_wp ) + IF ( dh(ji,jj) < 0.2_wp * hbl(ji,jj) .AND. nbld(ji,jj) - nmld(ji,jj) > 3 ) THEN + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.05_wp * zwt_pyc_sc_1(ji,jj) * & + & EXP( -0.25_wp * ( zznd_pyc / zzeta_pyc(ji,jj) )**2 ) * & + & pdh(ji,jj) / ( svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.05_wp * zws_pyc_sc_1(ji,jj) * & + & EXP( -0.25_wp * ( zznd_pyc / zzeta_pyc(ji,jj) )**2 ) * & + & pdh(ji,jj) / ( svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird + END IF + END IF ! End of pycnocline + END DO ; END DO ; END DO + ! + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "zwth_ent", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zwth_ent(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Upward turb. temperature entrainment flux + CALL zdf_osm_iomput( "zws_ent", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zws_ent(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) ! Upward turb. salinity entrainment flux + END IF + ! + zsc_vw_1(:,:) = 0.0_wp + WHERE ( l_conv(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) + zsc_uw_1(:,:) = -1.0_wp * swb0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * sustar(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**2 * phml(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / & + & ( svstr(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + 0.5_wp * swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + epsln ) + zsc_uw_2(:,:) = swb0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * sustke(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * phml(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / & + & ( svstr(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + 0.5_wp * swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**3 + epsln )**( 2.0_wp / 3.0_wp ) + ELSEWHERE + zsc_uw_1(:,:) = 0.0_wp + ENDWHERE + DO jk = 2, MAX( jkm_mld, jkm_bld ) ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) ) THEN + IF ( jk <= nmld(ji,jj) ) THEN + zznd_d = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + 0.3_wp * 0.5_wp * & + & ( zsc_uw_1(ji,jj) + 0.125_wp * EXP( -0.5_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -0.5_wp * zznd_d ) ) * zsc_uw_2(ji,jj) ) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zsc_vw_1(ji,jj) + END IF + ELSE ! Stable conditions + IF ( jk <= nbld(ji,jj) ) THEN + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zsc_uw_1(ji,jj) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zsc_vw_1(ji,jj) + END IF + ENDIF + END DO ; END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) .AND. l_pyc(ji,jj) ) THEN + IF ( n_ddh(ji,jj) == 0 ) THEN + ! Place holding code. Parametrization needs checking for these conditions. + zomega = ( 0.15_wp * swstrl(ji,jj)**3 + swstrc(ji,jj)**3 + 4.75_wp * ( pshear(ji,jj) * phbl(ji,jj) ) )**pthird + zuw_bse(ji,jj) = -0.0035_wp * zomega * ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_du_ml(ji,jj) + zvw_bse(ji,jj) = -0.0075_wp * zomega * ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_dv_ml(ji,jj) + ELSE + zomega = ( 0.15_wp * swstrl(ji,jj)**3 + swstrc(ji,jj)**3 + 4.75_wp * ( pshear(ji,jj) * phbl(ji,jj) ) )**pthird + zuw_bse(ji,jj) = -0.0035_wp * zomega * ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_du_ml(ji,jj) + zvw_bse(ji,jj) = -0.0075_wp * zomega * ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_dv_ml(ji,jj) + ENDIF + zb_cubic(ji,jj) = pdh(ji,jj) / phbl(ji,jj) * suw0(ji,jj) - ( 2.0_wp + pdh(ji,jj) / phml(ji,jj) ) * zuw_bse(ji,jj) + za_cubic(ji,jj) = zuw_bse(ji,jj) - zb_cubic(ji,jj) + zvw_max = 0.7_wp * ff_t(ji,jj) * ( sustke(ji,jj) * dstokes(ji,jj) + 0.7_wp * sustar(ji,jj) * phml(ji,jj) ) + zd_cubic(ji,jj) = zvw_max * pdh(ji,jj) / phml(ji,jj) - ( 2.0_wp + pdh(ji,jj) / phml(ji,jj) ) * zvw_bse(ji,jj) + zc_cubic(ji,jj) = zvw_bse(ji,jj) - zd_cubic(ji,jj) + END IF + END DO ; END DO + DO jk = jkf_mld, jkm_bld ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! Need ztau_sc_u to be available. Change to array. + IF ( l_conv(ji,jj) .AND. l_pyc(ji,jj) .AND. ( jk >= nmld(ji,jj) ) .AND. ( jk <= nbld(ji,jj) ) ) THEN + zznd_pyc = -1.0_wp * ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - phbl(ji,jj) ) / pdh(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) - 0.045_wp * ( ztau_sc_u(ji,jj)**2 ) * zuw_bse(ji,jj) * & + & ( za_cubic(ji,jj) * zznd_pyc**2 + zb_cubic(ji,jj) * zznd_pyc**3 ) * & + & ( 0.75_wp + 0.25_wp * zznd_pyc )**2 * zdbdz_pyc(ji,jj,jk) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) - 0.045_wp * ( ztau_sc_u(ji,jj)**2 ) * zvw_bse(ji,jj) * & + & ( zc_cubic(ji,jj) * zznd_pyc**2 + zd_cubic(ji,jj) * zznd_pyc**3 ) * & + & ( 0.75_wp + 0.25_wp * zznd_pyc )**2 * zdbdz_pyc(ji,jj,jk) + END IF ! l_conv .AND. l_pyc + END DO ; END DO ; END DO + ! + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "ghamu_0", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * ghamu(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + CALL zdf_osm_iomput( "zsc_uw_1_0", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zsc_uw_1(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) + END IF + ! + ! Transport term in flux-gradient relationship [note : includes ROI ratio + ! (X0.3) ] + ! ----------------------------------------------------------------------- + WHERE ( l_conv(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) + zsc_wth_1(:,:) = swth0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / ( 1.0_wp - 0.56_wp * EXP( shol(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) ) + zsc_ws_1(:,:) = sws0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / ( 1.0_wp - 0.56_wp * EXP( shol(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) ) + WHERE ( l_pyc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) ! Pycnocline scales + zsc_wth_pyc(:,:) = -0.003_wp * swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * ( 1.0_wp - pdh(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / phbl(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) * & + & av_dt_ml(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + zsc_ws_pyc(:,:) = -0.003_wp * swstrc(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * ( 1.0_wp - pdh(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) / phbl(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) * & + & av_ds_ml(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + END WHERE + ELSEWHERE + zsc_wth_1(:,:) = 2.0_wp * swthav(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + zsc_ws_1(:,:) = sws0(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + END WHERE + DO jk = 1, MAX( jkm_mld, jkm_bld ) ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) ) THEN + IF ( ( jk > 1 ) .AND. ( jk <= nmld(ji,jj) ) ) THEN + zznd_ml = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / phml(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3_wp * zsc_wth_1(ji,jj) * & + & ( -2.0_wp + 2.75_wp * ( ( 1.0_wp + 0.6_wp * zznd_ml**4 ) - & + & EXP( -6.0_wp * zznd_ml ) ) ) * & + & ( 1.0_wp - EXP( -15.0_wp * ( 1.0_wp - zznd_ml ) ) ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3_wp * zsc_ws_1(ji,jj) * & + & ( -2.0_wp + 2.75_wp * ( ( 1.0_wp + 0.6_wp * zznd_ml**4 ) - & + & EXP( -6.0_wp * zznd_ml ) ) ) * ( 1.0_wp - EXP( -15.0_wp * ( 1.0_wp - zznd_ml ) ) ) + END IF + ! + ! may need to comment out lpyc block + IF ( l_pyc(ji,jj) .AND. ( jk >= nmld(ji,jj) ) .AND. ( jk <= nbld(ji,jj) ) ) THEN ! Pycnocline + zznd_pyc = -1.0_wp * ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - phbl(ji,jj) ) / pdh(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 4.0_wp * zsc_wth_pyc(ji,jj) * & + & ( 0.48_wp - EXP( -1.5_wp * ( zznd_pyc - 0.3_wp )**2 ) ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 4.0_wp * zsc_ws_pyc(ji,jj) * & + & ( 0.48_wp - EXP( -1.5_wp * ( zznd_pyc - 0.3_wp )**2 ) ) + END IF + ELSE + IF( pdhdt(ji,jj) > 0. ) THEN + IF ( ( jk > 1 ) .AND. ( jk <= nbld(ji,jj) ) ) THEN + zznd_d = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / dstokes(ji,jj) + znd = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / phbl(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3_wp * ( -4.06_wp * EXP( -2.0_wp * zznd_d ) * ( 1.0_wp - EXP( -4.0_wp * zznd_d ) ) + & + 7.5_wp * EXP ( -10.0_wp * ( 0.95_wp - znd )**2 ) * ( 1.0_wp - znd ) ) * zsc_wth_1(ji,jj) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3_wp * ( -4.06_wp * EXP( -2.0_wp * zznd_d ) * ( 1.0_wp - EXP( -4.0_wp * zznd_d ) ) + & + 7.5_wp * EXP ( -10.0_wp * ( 0.95_wp - znd )**2 ) * ( 1.0_wp - znd ) ) * zsc_ws_1(ji,jj) + END IF + ENDIF + ENDIF + END DO ; END DO ; END DO + ! + WHERE ( l_conv(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) ) + zsc_uw_1(:,:) = sustar(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**2 + zsc_vw_1(:,:) = ff_t(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * sustke(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * phml(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + ELSEWHERE + zsc_uw_1(:,:) = sustar(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1))**2 + zsc_uw_2(:,:) = ( 2.25_wp - 3.0_wp * ( 1.0_wp - EXP( -1.25_wp * 2.0_wp ) ) ) * ( 1.0_wp - EXP( -4.0_wp * 2.0_wp ) ) * & + & zsc_uw_1(:,:) + zsc_vw_1(:,:) = ff_t(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * sustke(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) * phbl(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) + zsc_vw_2(:,:) = -0.11_wp * SIN( 3.14159_wp * ( 2.0_wp + 0.4_wp ) ) * EXP( -1.0_wp * ( 1.5_wp + 2.0_wp )**2 ) * & + & zsc_vw_1(:,:) + ENDWHERE + DO jk = 2, MAX( jkm_mld, jkm_bld ) ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) ) THEN + IF ( jk <= nmld(ji,jj) ) THEN + zznd_ml = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / phml(ji,jj) + zznd_d = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + & + & 0.3_wp * ( -2.0_wp + 2.5_wp * ( 1.0_wp + 0.1_wp * zznd_ml**4 ) - EXP( -8.0_wp * zznd_ml ) ) * & + & zsc_uw_1(ji,jj) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + & + & 0.3_wp * 0.1_wp * ( EXP( -1.0_wp * zznd_d ) + EXP( -5.0_wp * ( 1.0_wp - zznd_ml ) ) ) * & + & zsc_vw_1(ji,jj) + END IF + ELSE + IF ( jk <= nbld(ji,jj) ) THEN + znd = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / phbl(ji,jj) + zznd_d = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / dstokes(ji,jj) + IF ( zznd_d <= 2.0_wp ) THEN + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + 0.5_wp * 0.3_wp * & + & ( 2.25_wp - 3.0_wp * ( 1.0_wp - EXP( -1.25_wp * zznd_d ) ) * & + & ( 1.0_wp - EXP( -2.0_wp * zznd_d ) ) ) * zsc_uw_1(ji,jj) + ELSE + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + 0.5_wp * 0.3_wp * & + & ( 1.0_wp - EXP( -5.0_wp * ( 1.0_wp - znd ) ) ) * zsc_uw_2(ji,jj) + ENDIF + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + 0.3_wp * 0.15_wp * SIN( 3.14159_wp * ( 0.65_wp * zznd_d ) ) * & + & EXP( -0.25_wp * zznd_d**2 ) * zsc_vw_1(ji,jj) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + 0.3_wp * 0.15_wp * EXP( -5.0 * ( 1.0 - znd ) ) * & + & ( 1.0 - EXP( -20.0 * ( 1.0 - znd ) ) ) * zsc_vw_2(ji,jj) + END IF + END IF + END DO ; END DO ; END DO + ! + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "ghamu_f", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * ghamu(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + CALL zdf_osm_iomput( "ghamv_f", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * ghamv(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + CALL zdf_osm_iomput( "zsc_uw_1_f", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zsc_uw_1(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) + CALL zdf_osm_iomput( "zsc_vw_1_f", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zsc_vw_1(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) + CALL zdf_osm_iomput( "zsc_uw_2_f", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zsc_uw_2(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) + CALL zdf_osm_iomput( "zsc_vw_2_f", tmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),1) * zsc_vw_2(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) ) + END IF + ! + ! Make surface forced velocity non-gradient terms go to zero at the base + ! of the mixed layer. + ! + ! Make surface forced velocity non-gradient terms go to zero at the base + ! of the boundary layer. + DO jk = 2, jkm_bld ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( ( .NOT. l_conv(ji,jj) ) .AND. ( jk <= nbld(ji,jj) ) ) THEN + znd = -1.0_wp * ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - phbl(ji,jj) ) / phbl(ji,jj) ! ALMG to think about + IF ( znd >= 0.0_wp ) THEN + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * ( 1.0_wp - EXP( -10.0_wp * znd**2 ) ) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) * ( 1.0_wp - EXP( -10.0_wp * znd**2 ) ) + ELSE + ghamu(ji,jj,jk) = 0.0_wp + ghamv(ji,jj,jk) = 0.0_wp + ENDIF + END IF + END DO ; END DO ; END DO + ! + ! Pynocline contributions + ! + IF ( ln_dia_pyc_scl .OR. ln_dia_pyc_shr ) THEN ! Allocate arrays for output of pycnocline gradient/shear profiles + ALLOCATE( z3ddz_pyc_1(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), z3ddz_pyc_2(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), STAT=istat ) + IF ( istat /= 0 ) CALL ctl_stop( 'zdf_osm: failed to allocate temporary arrays' ) + z3ddz_pyc_1(:,:,:) = 0.0_wp + z3ddz_pyc_2(:,:,:) = 0.0_wp + END IF + DO jk = 2, jkm_bld ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv (ji,jj) ) THEN + ! Unstable conditions. Shouldn;t be needed with no pycnocline code. + ! zugrad = 0.7 * av_du_ml(ji,jj) / zdh(ji,jj) + 0.3 * zustar(ji,jj)*zustar(ji,jj) / & + ! & ( ( ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zhml(ji,jj) ) * & + ! & MIN(zla(ji,jj)**(8.0/3.0) + epsln, 0.12 )) + !Alan is this right? + ! zvgrad = ( 0.7 * av_dv_ml(ji,jj) + & + ! & 2.0 * ff_t(ji,jj) * zustke(ji,jj) * dstokes(ji,jj) / & + ! & ( ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird + epsln ) & + ! & )/ (zdh(ji,jj) + epsln ) + ! DO jk = 2, nbld(ji,jj) - 1 + ibld_ext + ! znd = -( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - zhbl(ji,jj) ) / (zdh(ji,jj) + epsln ) - zzeta_v + ! IF ( znd <= 0.0 ) THEN + ! zdudz(ji,jj,jk) = 1.25 * zugrad * EXP( 3.0 * znd ) + ! zdvdz(ji,jj,jk) = 1.25 * zvgrad * EXP( 3.0 * znd ) + ! ELSE + ! zdudz(ji,jj,jk) = 1.25 * zugrad * EXP( -2.0 * znd ) + ! zdvdz(ji,jj,jk) = 1.25 * zvgrad * EXP( -2.0 * znd ) + ! ENDIF + ! END DO + ELSE ! Stable conditions + IF ( nbld(ji,jj) + kp_ext(ji,jj) < mbkt(ji,jj) ) THEN + ! Pycnocline profile only defined when depth steady of increasing. + IF ( pdhdt(ji,jj) > 0.0_wp ) THEN ! Depth increasing, or steady. + IF ( av_db_bl(ji,jj) > 0.0_wp ) THEN + IF ( shol(ji,jj) >= 0.5_wp ) THEN ! Very stable - 'thick' pycnocline + ztmp = 1.0_wp / MAX( phbl(ji,jj), epsln ) + ztgrad = av_dt_bl(ji,jj) * ztmp + zsgrad = av_ds_bl(ji,jj) * ztmp + zbgrad = av_db_bl(ji,jj) * ztmp + IF ( jk <= nbld(ji,jj) ) THEN + znd = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * ztmp + zdtdz_pyc = ztgrad * EXP( -15.0_wp * ( znd - 0.9_wp )**2 ) + zdsdz_pyc = zsgrad * EXP( -15.0_wp * ( znd - 0.9_wp )**2 ) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + pdiffut(ji,jj,jk) * zdtdz_pyc + ghams(ji,jj,jk) = ghams(ji,jj,jk) + pdiffut(ji,jj,jk) * zdsdz_pyc + IF ( ln_dia_pyc_scl ) THEN + z3ddz_pyc_1(ji,jj,jk) = zdtdz_pyc + z3ddz_pyc_2(ji,jj,jk) = zdsdz_pyc + END IF + END IF + ELSE ! Slightly stable - 'thin' pycnoline - needed when stable layer begins to form. + ztmp = 1.0_wp / MAX( pdh(ji,jj), epsln ) + ztgrad = av_dt_bl(ji,jj) * ztmp + zsgrad = av_ds_bl(ji,jj) * ztmp + zbgrad = av_db_bl(ji,jj) * ztmp + IF ( jk <= nbld(ji,jj) ) THEN + znd = -1.0_wp * ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - phml(ji,jj) ) * ztmp + zdtdz_pyc = ztgrad * EXP( -1.75_wp * ( znd + 0.75_wp )**2 ) + zdsdz_pyc = zsgrad * EXP( -1.75_wp * ( znd + 0.75_wp )**2 ) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + pdiffut(ji,jj,jk) * zdtdz_pyc + ghams(ji,jj,jk) = ghams(ji,jj,jk) + pdiffut(ji,jj,jk) * zdsdz_pyc + IF ( ln_dia_pyc_scl ) THEN + z3ddz_pyc_1(ji,jj,jk) = zdtdz_pyc + z3ddz_pyc_2(ji,jj,jk) = zdsdz_pyc + END IF + END IF + ENDIF ! IF (shol >=0.5) + ENDIF ! IF (av_db_bl> 0.) + ENDIF ! IF (zdhdt >= 0) zdhdt < 0 not considered since pycnocline profile is zero and profile arrays are + ! ! intialized to zero + END IF + END IF + END DO ; END DO ; END DO + IF ( ln_dia_pyc_scl ) THEN ! Output of pycnocline gradient profiles + CALL zdf_osm_iomput( "zdtdz_pyc", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * z3ddz_pyc_1(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + CALL zdf_osm_iomput( "zdsdz_pyc", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * z3ddz_pyc_2(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + END IF + DO jk = 2, jkm_bld ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( .NOT. l_conv (ji,jj) ) THEN + IF ( nbld(ji,jj) + kp_ext(ji,jj) < mbkt(ji,jj) ) THEN + zugrad = 3.25_wp * av_du_bl(ji,jj) / phbl(ji,jj) + zvgrad = 2.75_wp * av_dv_bl(ji,jj) / phbl(ji,jj) + IF ( jk <= nbld(ji,jj) ) THEN + znd = (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / phbl(ji,jj) + IF ( znd < 1.0 ) THEN + zdudz_pyc = zugrad * EXP( -40.0_wp * ( znd - 1.0_wp )**2 ) + ELSE + zdudz_pyc = zugrad * EXP( -20.0_wp * ( znd - 1.0_wp )**2 ) + ENDIF + zdvdz_pyc = zvgrad * EXP( -20.0_wp * ( znd - 0.85_wp )**2 ) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + pviscos(ji,jj,jk) * zdudz_pyc + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + pviscos(ji,jj,jk) * zdvdz_pyc + IF ( ln_dia_pyc_shr ) THEN + z3ddz_pyc_1(ji,jj,jk) = zdudz_pyc + z3ddz_pyc_2(ji,jj,jk) = zdvdz_pyc + END IF + END IF + END IF + END IF + END DO ; END DO ; END DO + IF ( ln_dia_pyc_shr ) THEN ! Output of pycnocline shear profiles + CALL zdf_osm_iomput( "zdudz_pyc", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * z3ddz_pyc_1(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + CALL zdf_osm_iomput( "zdvdz_pyc", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * z3ddz_pyc_2(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + END IF + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "ghamu_b", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * ghamu(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + CALL zdf_osm_iomput( "ghamv_b", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * ghamv(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + END IF + IF ( ln_dia_pyc_scl .OR. ln_dia_pyc_shr ) THEN ! Deallocate arrays used for output of pycnocline gradient/shear profiles + DEALLOCATE( z3ddz_pyc_1, z3ddz_pyc_2 ) + END IF + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ghamt(ji,jj,nbld(ji,jj)) = 0.0_wp + ghams(ji,jj,nbld(ji,jj)) = 0.0_wp + ghamu(ji,jj,nbld(ji,jj)) = 0.0_wp + ghamv(ji,jj,nbld(ji,jj)) = 0.0_wp + END DO ; END DO + ! + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "ghamu_1", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * ghamu(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + CALL zdf_osm_iomput( "ghamv_1", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * ghamv(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + CALL zdf_osm_iomput( "zviscos", wmask(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) * pviscos(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) ) + END IF + ! + END SUBROUTINE zdf_osm_fgr_terms + + SUBROUTINE zdf_osm_zmld_horizontal_gradients( Kmm, pmld, pdtdx, pdtdy, pdsdx, & + & pdsdy, pdbds_mle ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_zmld_horizontal_gradients *** + !! + !! ** Purpose : Calculates horizontal gradients of buoyancy for use with + !! Fox-Kemper parametrization + !! + !! ** Method : + !! + !! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008 + !! Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Time-level index + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)), INTENT( out) :: pmld ! == Estimated FK BLD used for MLE horizontal gradients == ! + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)), INTENT(inout) :: pdtdx ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)), INTENT(inout) :: pdtdy ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)), INTENT(inout) :: pdsdx ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)), INTENT(inout) :: pdsdy ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(inout) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient + !! + INTEGER :: ji, jj, jk ! Dummy loop indices + INTEGER, DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: jk_mld_prof ! Base level of MLE layer + INTEGER :: ikt, ikmax ! Local integers + REAL(wp) :: zc + REAL(wp) :: zN2_c ! Local buoyancy difference from 10m value + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: ztm + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zsm + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpts) :: ztsm_midu + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpts) :: ztsm_midv + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpts) :: zabu + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpts) :: zabv + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zmld_midu + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zmld_midv + !!---------------------------------------------------------------------- + ! + ! == MLD used for MLE ==! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + jk_mld_prof(ji,jj) = nlb10 ! Initialization to the number of w ocean point + pmld(ji,jj) = 0.0_wp ! Here hmlp used as a dummy variable, integrating vertically N^2 + END DO ; END DO + zN2_c = grav * rn_osm_mle_rho_c * r1_rho0 ! Convert density criteria into N^2 criteria + DO jk = nlb10, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ikt = mbkt(ji,jj) + pmld(ji,jj) = pmld(ji,jj) + MAX( rn2b(ji,jj,jk), 0.0_wp ) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + IF( pmld(ji,jj) < zN2_c ) jk_mld_prof(ji,jj) = MIN( jk , ikt ) + 1 ! Mixed layer level + END DO ; END DO ; END DO + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + jk_mld_prof(ji,jj) = MAX( jk_mld_prof(ji,jj), nbld(ji,jj) ) ! Ensure jk_mld_prof .ge. nbld + pmld(ji,jj) = (gdepw_0(ji,jj,jk_mld_prof(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + mld_prof(ji,jj) = jk_mld_prof(ji,jj) + END DO ; END DO + ! + ikmax = MIN( MAXVAL( jk_mld_prof(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) ), jpkm1 ) ! Max level of the computation + ztm(:,:) = 0.0_wp + zsm(:,:) = 0.0_wp + DO jk = 1, ikmax ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + zc = (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) * REAL( MIN( MAX( 0, jk_mld_prof(ji,jj) - jk ), 1 ), KIND=wp ) ! zc being 0 outside the ML + ! ! t-points + ztm(ji,jj) = ztm(ji,jj) + zc * ts(ji,jj,jk,jp_tem,Kmm) + zsm(ji,jj) = zsm(ji,jj) + zc * ts(ji,jj,jk,jp_sal,Kmm) + END DO ; END DO ; END DO + ! Average temperature and salinity + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ztm(ji,jj) = ztm(ji,jj) / MAX( (e3t_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,1))), pmld(ji,jj) ) + zsm(ji,jj) = zsm(ji,jj) / MAX( (e3t_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,1))), pmld(ji,jj) ) + END DO ; END DO + ! Calculate horizontal gradients at u & v points + zmld_midu(:,:) = 0.0_wp + ztsm_midu(:,:,:) = 10.0_wp + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + pdtdx(ji,jj) = ( ztm(ji+1,jj) - ztm(ji,jj) ) * umask(ji,jj,1) / e1u(ji,jj) + pdsdx(ji,jj) = ( zsm(ji+1,jj) - zsm(ji,jj) ) * umask(ji,jj,1) / e1u(ji,jj) + zmld_midu(ji,jj) = 0.25_wp * ( pmld(ji+1,jj) + pmld(ji,jj)) + ztsm_midu(ji,jj,jp_tem) = 0.5_wp * ( ztm( ji+1,jj) + ztm( ji,jj) ) + ztsm_midu(ji,jj,jp_sal) = 0.5_wp * ( zsm( ji+1,jj) + zsm( ji,jj) ) + END DO ; END DO + zmld_midv(:,:) = 0.0_wp + ztsm_midv(:,:,:) = 10.0_wp + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + pdtdy(ji,jj) = ( ztm(ji,jj+1) - ztm(ji,jj) ) * vmask(ji,jj,1) / e1v(ji,jj) + pdsdy(ji,jj) = ( zsm(ji,jj+1) - zsm(ji,jj) ) * vmask(ji,jj,1) / e1v(ji,jj) + zmld_midv(ji,jj) = 0.25_wp * ( pmld(ji,jj+1) + pmld( ji,jj) ) + ztsm_midv(ji,jj,jp_tem) = 0.5_wp * ( ztm( ji,jj+1) + ztm( ji,jj) ) + ztsm_midv(ji,jj,jp_sal) = 0.5_wp * ( zsm( ji,jj+1) + zsm( ji,jj) ) + END DO ; END DO + CALL eos_rab( ztsm_midu, zmld_midu, zabu, Kmm ) + CALL eos_rab( ztsm_midv, zmld_midv, zabv, Kmm ) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-( nn_hls+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls)*nthr) + dbdx_mle(ji,jj) = grav * ( pdtdx(ji,jj) * zabu(ji,jj,jp_tem) - pdsdx(ji,jj) * zabu(ji,jj,jp_sal) ) + END DO ; END DO + DO jj = ntsj-( nn_hls-( nn_hls+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + dbdy_mle(ji,jj) = grav * ( pdtdy(ji,jj) * zabv(ji,jj,jp_tem) - pdsdy(ji,jj) * zabv(ji,jj,jp_sal) ) + END DO ; END DO + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + pdbds_mle(ji,jj) = SQRT( 0.5_wp * ( dbdx_mle(ji, jj) * dbdx_mle(ji, jj) + dbdy_mle(ji,jj ) * dbdy_mle(ji,jj ) + & + & dbdx_mle(ji-1,jj) * dbdx_mle(ji-1,jj) + dbdy_mle(ji,jj-1) * dbdy_mle(ji,jj-1) ) ) + END DO ; END DO + ! + END SUBROUTINE zdf_osm_zmld_horizontal_gradients + + SUBROUTINE zdf_osm_osbl_state_fk( Kmm, pwb_fk, phbl, phmle, pwb_ent, & + & pdbds_mle ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_osbl_state_fk *** + !! + !! ** Purpose : Determines the state of the OSBL and MLE layer. Info is + !! returned in the logicals l_pyc, l_flux and ldmle. Used + !! with Fox-Kemper scheme. + !! l_pyc :: determines whether pycnocline flux-grad + !! relationship needs to be determined + !! l_flux :: determines whether effects of surface flux + !! extend below the base of the OSBL + !! ldmle :: determines whether the layer with MLE is + !! increasing with time or if base is relaxing + !! towards hbl + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Time-level index + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(inout) :: pwb_fk + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phmle ! MLE depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient + !! + INTEGER :: ji, jj, jk ! Dummy loop indices + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)) :: znd_param + REAL(wp) :: zthermal, zbeta + REAL(wp) :: zbuoy + REAL(wp) :: ztmp + REAL(wp) :: zpe_mle_layer + REAL(wp) :: zpe_mle_ref + REAL(wp) :: zdbdz_mle_int + !!---------------------------------------------------------------------- + ! + znd_param(:,:) = 0.0_wp + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ztmp = r1_ft(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) / rn_osm_mle_lf + pwb_fk(ji,jj) = rn_osm_mle_ce * hmle(ji,jj) * hmle(ji,jj) * ztmp * pdbds_mle(ji,jj) * pdbds_mle(ji,jj) + END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! + IF ( l_conv(ji,jj) ) THEN + IF ( phmle(ji,jj) > 1.2_wp * phbl(ji,jj) ) THEN + av_t_mle(ji,jj) = ( av_t_mle(ji,jj) * phmle(ji,jj) - av_t_bl(ji,jj) * phbl(ji,jj) ) / ( phmle(ji,jj) - phbl(ji,jj) ) + av_s_mle(ji,jj) = ( av_s_mle(ji,jj) * phmle(ji,jj) - av_s_bl(ji,jj) * phbl(ji,jj) ) / ( phmle(ji,jj) - phbl(ji,jj) ) + av_b_mle(ji,jj) = ( av_b_mle(ji,jj) * phmle(ji,jj) - av_b_bl(ji,jj) * phbl(ji,jj) ) / ( phmle(ji,jj) - phbl(ji,jj) ) + zdbdz_mle_int = ( av_b_bl(ji,jj) - ( 2.0_wp * av_b_mle(ji,jj) - av_b_bl(ji,jj) ) ) / ( phmle(ji,jj) - phbl(ji,jj) ) + ! Calculate potential energies of actual profile and reference profile + zpe_mle_layer = 0.0_wp + zpe_mle_ref = 0.0_wp + zthermal = rab_n(ji,jj,1,jp_tem) + zbeta = rab_n(ji,jj,1,jp_sal) + DO jk = nbld(ji,jj), mld_prof(ji,jj) + zbuoy = grav * ( zthermal * ts(ji,jj,jk,jp_tem,Kmm) - zbeta * ts(ji,jj,jk,jp_sal,Kmm) ) + zpe_mle_layer = zpe_mle_layer + zbuoy * (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + zpe_mle_ref = zpe_mle_ref + ( av_b_bl(ji,jj) - zdbdz_mle_int * ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - phbl(ji,jj) ) ) * & + & (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + END DO + ! Non-dimensional parameter to diagnose the presence of thermocline + znd_param(ji,jj) = ( zpe_mle_layer - zpe_mle_ref ) * ABS( ff_t(ji,jj) ) / & + & ( MAX( pwb_fk(ji,jj), 1e-10 ) * phmle(ji,jj) ) + END IF + END IF + ! + END DO ; END DO + ! + ! Diagnosis + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! + IF ( l_conv(ji,jj) ) THEN + IF ( -2.0_wp * pwb_fk(ji,jj) / pwb_ent(ji,jj) > 0.5_wp ) THEN + IF ( phmle(ji,jj) > 1.2_wp * phbl(ji,jj) ) THEN ! MLE layer growing + IF ( znd_param (ji,jj) > 100.0_wp ) THEN ! Thermocline present + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + ELSE ! Thermocline not present + l_flux(ji,jj) = .TRUE. + l_mle(ji,jj) = .TRUE. + ENDIF ! znd_param > 100 + ! + IF ( av_db_bl(ji,jj) < rn_osm_bl_thresh ) THEN + l_pyc(ji,jj) = .FALSE. + ELSE + l_pyc(ji,jj) = .TRUE. + ENDIF + ELSE ! MLE layer restricted to OSBL or just below + IF ( av_db_bl(ji,jj) < rn_osm_bl_thresh ) THEN ! Weak stratification MLE layer can grow + l_pyc(ji,jj) = .FALSE. + l_flux(ji,jj) = .TRUE. + l_mle(ji,jj) = .TRUE. + ELSE ! Strong stratification + l_pyc(ji,jj) = .TRUE. + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + END IF ! av_db_bl < rn_mle_thresh_bl and + END IF ! phmle > 1.2 phbl + ELSE + l_pyc(ji,jj) = .TRUE. + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + IF ( av_db_bl(ji,jj) < rn_osm_bl_thresh ) l_pyc(ji,jj) = .FALSE. + END IF ! -2.0 * pwb_fk(ji,jj) / pwb_ent > 0.5 + ELSE ! Stable Boundary Layer + l_pyc(ji,jj) = .FALSE. + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + END IF ! l_conv + ! + END DO ; END DO + ! + END SUBROUTINE zdf_osm_osbl_state_fk + + SUBROUTINE zdf_osm_mle_parameters( Kmm, pmld, phmle, pvel_mle, pdiff_mle, & + & pdbds_mle, phbl, pwb0tot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_mle_parameters *** + !! + !! ** Purpose : Timesteps the mixed layer eddy depth, hmle and calculates + !! the mixed layer eddy fluxes for buoyancy, heat and + !! salinity. + !! + !! ** Method : + !! + !! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008 + !! Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Time-level index + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)), INTENT(in ) :: pmld ! == Estimated FK BLD used for MLE horiz gradients == ! + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(inout) :: phmle ! MLE depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(inout) :: pvel_mle ! Velocity scale for dhdt with stable ML and FK + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(inout) :: pdiff_mle ! Extra MLE vertical diff + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(ntsi-(nn_hls-1):ntei+(nn_hls-1),ntsj-(nn_hls-1):ntej+(nn_hls-1)), INTENT(in ) :: pwb0tot ! Total surface buoyancy flux including insolation + !! + INTEGER :: ji, jj, jk ! Dummy loop indices + REAL(wp) :: ztmp + REAL(wp) :: zdbdz + REAL(wp) :: zdtdz + REAL(wp) :: zdsdz + REAL(wp) :: zthermal + REAL(wp) :: zbeta + REAL(wp) :: zbuoy + REAL(wp) :: zdb_mle + !!---------------------------------------------------------------------- + ! + ! Calculate vertical buoyancy, heat and salinity fluxes due to MLE + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_conv(ji,jj) ) THEN + ztmp = r1_ft(ji,jj) * MIN( 111e3_wp, e1u(ji,jj) ) / rn_osm_mle_lf + ! This velocity scale, defined in Fox-Kemper et al (2008), is needed for calculating dhdt + pvel_mle(ji,jj) = pdbds_mle(ji,jj) * ztmp * hmle(ji,jj) * tmask(ji,jj,1) + pdiff_mle(ji,jj) = 5e-4_wp * rn_osm_mle_ce * ztmp * pdbds_mle(ji,jj) * phmle(ji,jj)**2 + END IF + END DO ; END DO + ! Timestep mixed layer eddy depth + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( l_mle(ji,jj) ) THEN ! MLE layer growing + ! Buoyancy gradient at base of MLE layer + zthermal = rab_n(ji,jj,1,jp_tem) + zbeta = rab_n(ji,jj,1,jp_sal) + zbuoy = grav * ( zthermal * ts(ji,jj,mld_prof(ji,jj)+2,jp_tem,Kmm) - & + & zbeta * ts(ji,jj,mld_prof(ji,jj)+2,jp_sal,Kmm) ) + zdb_mle = av_b_bl(ji,jj) - zbuoy + ! Timestep hmle + hmle(ji,jj) = hmle(ji,jj) + pwb0tot(ji,jj) * rn_Dt / zdb_mle + ELSE + IF ( phmle(ji,jj) > phbl(ji,jj) ) THEN + hmle(ji,jj) = hmle(ji,jj) - ( hmle(ji,jj) - hbl(ji,jj) ) * rn_Dt / rn_osm_mle_tau + ELSE + hmle(ji,jj) = hmle(ji,jj) - 10.0_wp * ( hmle(ji,jj) - hbl(ji,jj) ) * rn_Dt / rn_osm_mle_tau + END IF + END IF + hmle(ji,jj) = MAX( MIN( hmle(ji,jj), (ht_0(ji,jj)*(1._wp+r3t(ji,jj,Kmm))) ), (gdepw_0(ji,jj,4)*(1._wp+r3t(ji,jj,Kmm))) ) + IF ( ln_osm_hmle_limit ) hmle(ji,jj) = MIN( hmle(ji,jj), rn_osm_hmle_limit*hbl(ji,jj) ) + hmle(ji,jj) = pmld(ji,jj) ! For now try just set hmle to pmld + END DO ; END DO + ! + DO jk = 5, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( hmle(ji,jj) >= (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) mld_prof(ji,jj) = MIN( mbkt(ji,jj), jk ) + END DO ; END DO ; END DO + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + phmle(ji,jj) = (gdepw_0(ji,jj,mld_prof(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + ! + END SUBROUTINE zdf_osm_mle_parameters + + SUBROUTINE zdf_osm_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_init *** + !! + !! ** Purpose : Initialization of the vertical eddy diffivity and + !! viscosity when using a osm turbulent closure scheme + !! + !! ** Method : Read the namosm namelist and check the parameters + !! called at the first timestep (nit000) + !! + !! ** input : Namlists namzdf_osm and namosm_mle + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Time level + !! + INTEGER :: ios ! Local integer + INTEGER :: ji, jj, jk ! Dummy loop indices + REAL(wp) :: z1_t2 + !! + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !! + NAMELIST/namzdf_osm/ ln_use_osm_la, rn_osm_la, rn_osm_dstokes, nn_ave, nn_osm_wave, & + & ln_dia_osm, rn_osm_hbl0, rn_zdfosm_adjust_sd, ln_kpprimix, rn_riinfty, & + & rn_difri, ln_convmix, rn_difconv, nn_osm_wave, nn_osm_SD_reduce, & + & ln_osm_mle, rn_osm_hblfrac, rn_osm_bl_thresh, ln_zdfosm_ice_shelter + !! Namelist for Fox-Kemper parametrization + NAMELIST/namosm_mle/ nn_osm_mle, rn_osm_mle_ce, rn_osm_mle_lf, rn_osm_mle_time, rn_osm_mle_lat, & + & rn_osm_mle_rho_c, rn_osm_mle_thresh, rn_osm_mle_tau, ln_osm_hmle_limit, rn_osm_hmle_limit + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namzdf_osm, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist' ) + + READ ( numnam_cfg, namzdf_osm, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_osm in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_osm ) + + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_osm_init : OSMOSIS Parameterisation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_osm : set osm mixing parameters' + WRITE(numout,*) ' Use rn_osm_la ln_use_osm_la = ', ln_use_osm_la + WRITE(numout,*) ' Use MLE in OBL, i.e. Fox-Kemper param ln_osm_mle = ', ln_osm_mle + WRITE(numout,*) ' Turbulent Langmuir number rn_osm_la = ', rn_osm_la + WRITE(numout,*) ' Stokes drift reduction factor rn_zdfosm_adjust_sd = ', rn_zdfosm_adjust_sd + WRITE(numout,*) ' Initial hbl for 1D runs rn_osm_hbl0 = ', rn_osm_hbl0 + WRITE(numout,*) ' Depth scale of Stokes drift rn_osm_dstokes = ', rn_osm_dstokes + WRITE(numout,*) ' Horizontal average flag nn_ave = ', nn_ave + WRITE(numout,*) ' Stokes drift nn_osm_wave = ', nn_osm_wave + SELECT CASE (nn_osm_wave) + CASE(0) + WRITE(numout,*) ' Calculated assuming constant La#=0.3' + CASE(1) + WRITE(numout,*) ' Calculated from Pierson Moskowitz wind-waves' + CASE(2) + WRITE(numout,*) ' Calculated from ECMWF wave fields' + END SELECT + WRITE(numout,*) ' Stokes drift reduction nn_osm_SD_reduce = ', nn_osm_SD_reduce + WRITE(numout,*) ' Fraction of hbl to average SD over/fit' + WRITE(numout,*) ' Exponential with nn_osm_SD_reduce = 1 or 2 rn_osm_hblfrac = ', rn_osm_hblfrac + SELECT CASE (nn_osm_SD_reduce) + CASE(0) + WRITE(numout,*) ' No reduction' + CASE(1) + WRITE(numout,*) ' Average SD over upper rn_osm_hblfrac of BL' + CASE(2) + WRITE(numout,*) ' Fit exponential to slope rn_osm_hblfrac of BL' + END SELECT + WRITE(numout,*) ' Reduce surface SD and depth scale under ice ln_zdfosm_ice_shelter = ', ln_zdfosm_ice_shelter + WRITE(numout,*) ' Output osm diagnostics ln_dia_osm = ', ln_dia_osm + WRITE(numout,*) ' Threshold used to define BL rn_osm_bl_thresh = ', rn_osm_bl_thresh, & + & 'm^2/s' + WRITE(numout,*) ' Use KPP-style shear instability mixing ln_kpprimix = ', ln_kpprimix + WRITE(numout,*) ' Local Richardson Number limit for shear instability rn_riinfty = ', rn_riinfty + WRITE(numout,*) ' Maximum shear diffusivity at Rig = 0 (m2/s) rn_difri = ', rn_difri + WRITE(numout,*) ' Use large mixing below BL when unstable ln_convmix = ', ln_convmix + WRITE(numout,*) ' Diffusivity when unstable below BL (m2/s) rn_difconv = ', rn_difconv + ENDIF + ! + ! ! Check wave coupling settings ! + ! ! Further work needed - see ticket #2447 ! + IF ( nn_osm_wave == 2 ) THEN + IF (.NOT. ( ln_wave .AND. ln_sdw )) & + & CALL ctl_stop( 'zdf_osm_init : ln_zdfosm and nn_osm_wave=2, ln_wave and ln_sdw must be true' ) + END IF + ! + ! Flags associated with diagnostic output + IF ( ln_dia_osm .AND. ( iom_use("zdudz_pyc") .OR. iom_use("zdvdz_pyc") ) ) ln_dia_pyc_shr = .TRUE. + IF ( ln_dia_osm .AND. ( iom_use("zdtdz_pyc") .OR. iom_use("zdsdz_pyc") .OR. iom_use("zdbdz_pyc" ) ) ) ln_dia_pyc_scl = .TRUE. + ! + ! Allocate zdfosm arrays + IF( zdf_osm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_osm_init : unable to allocate arrays' ) + ! + IF( ln_osm_mle ) THEN ! Initialise Fox-Kemper parametrization + READ ( numnam_ref, namosm_mle, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam( ios, 'namosm_mle in reference namelist' ) + READ ( numnam_cfg, namosm_mle, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam( ios, 'namosm_mle in configuration namelist' ) + IF(lwm) WRITE ( numond, namosm_mle ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'zdf_osm_init : initialise mixed layer eddy (MLE)' + WRITE(numout,*) '~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namosm_mle : ' + WRITE(numout,*) ' MLE type: =0 standard Fox-Kemper ; =1 new formulation nn_osm_mle = ', nn_osm_mle + WRITE(numout,*) ' Magnitude of the MLE (typical value: 0.06 to 0.08) rn_osm_mle_ce = ', rn_osm_mle_ce + WRITE(numout,*) ' Scale of ML front (ML radius of deform.) (nn_osm_mle=0) rn_osm_mle_lf = ', rn_osm_mle_lf, & + & 'm' + WRITE(numout,*) ' Maximum time scale of MLE (nn_osm_mle=0) rn_osm_mle_time = ', & + & rn_osm_mle_time, 's' + WRITE(numout,*) ' Reference latitude (deg) of MLE coef. (nn_osm_mle=1) rn_osm_mle_lat = ', rn_osm_mle_lat, & + & 'deg' + WRITE(numout,*) ' Density difference used to define ML for FK rn_osm_mle_rho_c = ', rn_osm_mle_rho_c + WRITE(numout,*) ' Threshold used to define MLE for FK rn_osm_mle_thresh = ', & + & rn_osm_mle_thresh, 'm^2/s' + WRITE(numout,*) ' Timescale for OSM-FK rn_osm_mle_tau = ', rn_osm_mle_tau, 's' + WRITE(numout,*) ' Switch to limit hmle ln_osm_hmle_limit = ', ln_osm_hmle_limit + WRITE(numout,*) ' hmle limit (fraction of zmld) (ln_osm_hmle_limit = .T.) rn_osm_hmle_limit = ', rn_osm_hmle_limit + END IF + END IF + ! + IF(lwp) THEN + WRITE(numout,*) + IF ( ln_osm_mle ) THEN + WRITE(numout,*) ' ==>>> Mixed Layer Eddy induced transport added to OSMOSIS BL calculation' + IF( nn_osm_mle == 0 ) WRITE(numout,*) ' Fox-Kemper et al 2010 formulation' + IF( nn_osm_mle == 1 ) WRITE(numout,*) ' New formulation' + ELSE + WRITE(numout,*) ' ==>>> Mixed Layer induced transport NOT added to OSMOSIS BL calculation' + END IF + END IF + ! + IF( ln_osm_mle ) THEN ! MLE initialisation + ! + rb_c = grav * rn_osm_mle_rho_c / rho0 ! Mixed Layer buoyancy criteria + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ML buoyancy criteria = ', rb_c, ' m/s2 ' + IF(lwp) WRITE(numout,*) ' associated ML density criteria defined in zdfmxl = ', rn_osm_mle_rho_c, 'kg/m3' + ! + IF( nn_osm_mle == 1 ) THEN + rc_f = rn_osm_mle_ce / ( 5e3_wp * 2.0_wp * omega * SIN( rad * rn_osm_mle_lat ) ) + END IF + ! 1/(f^2+tau^2)^1/2 at t-point (needed in both nn_osm_mle case) + z1_t2 = 2e-5_wp + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + r1_ft(ji,jj) = MIN( 1.0_wp / ( ABS( ff_t(ji,jj)) + epsln ), ABS( ff_t(ji,jj) ) / z1_t2**2 ) + END DO ; END DO + ! z1_t2 = 1._wp / ( rn_osm_mle_time * rn_osm_mle_timeji,jj ) + ! r1_ft(:,:) = 1._wp / SQRT( ff_t(:,:) * ff_t(:,:) + z1_t2 ) + ! + END IF + ! + CALL osm_rst( nit000, Kmm, 'READ' ) ! Read or initialize hbl, dh, hmle + ! + IF ( ln_zdfddm ) THEN + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Double diffusion mixing on temperature and salinity ' + WRITE(numout,*) ' CAUTION : done in routine zdfosm, not in routine zdfddm ' + END IF + END IF + ! + ! Set constants not in namelist + ! ----------------------------- + IF(lwp) THEN + WRITE(numout,*) + END IF + ! + dstokes(:,:) = pp_large + IF (nn_osm_wave == 0) THEN + dstokes(:,:) = rn_osm_dstokes + END IF + ! + ! Horizontal average : initialization of weighting arrays + ! ------------------- + SELECT CASE ( nn_ave ) + CASE ( 0 ) ! no horizontal average + IF(lwp) WRITE(numout,*) ' no horizontal average on avt' + IF(lwp) WRITE(numout,*) ' only in very high horizontal resolution !' + ! Weighting mean arrays etmean + ! ( 1 1 ) + ! avt = 1/4 ( 1 1 ) + ! + etmean(:,:,:) = 0.0_wp + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + etmean(ji,jj,jk) = tmask(ji,jj,jk) / MAX( 1.0_wp, umask(ji-1,jj, jk) + umask(ji,jj,jk) + & + & vmask(ji, jj-1,jk) + vmask(ji,jj,jk) ) + END DO ; END DO ; END DO + CASE ( 1 ) ! horizontal average + IF(lwp) WRITE(numout,*) ' horizontal average on avt' + ! Weighting mean arrays etmean + ! ( 1/2 1 1/2 ) + ! avt = 1/8 ( 1 2 1 ) + ! ( 1/2 1 1/2 ) + etmean(:,:,:) = 0.0_wp + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + etmean(ji,jj,jk) = tmask(ji, jj,jk) / MAX( 1.0_wp, 2.0_wp * tmask(ji,jj,jk) + & + & 0.5_wp * ( tmask(ji-1,jj+1,jk) + tmask(ji-1,jj-1,jk) + & + & tmask(ji+1,jj+1,jk) + tmask(ji+1,jj-1,jk) ) + & + & 1.0_wp * ( tmask(ji-1,jj, jk) + tmask(ji, jj+1,jk) + & + & tmask(ji, jj-1,jk) + tmask(ji+1,jj, jk) ) ) + END DO ; END DO ; END DO + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for nn_ave = ', nn_ave + CALL ctl_stop( ctmp1 ) + END SELECT + ! + ! Initialization of vertical eddy coef. to the background value + ! ------------------------------------------------------------- + DO jk = 1, jpk + avt(:,:,jk) = avtb(jk) * tmask(:,:,jk) + END DO + ! + ! Zero the surface flux for non local term and osm mixed layer depth + ! ------------------------------------------------------------------ + ghamt(:,:,:) = 0.0_wp + ghams(:,:,:) = 0.0_wp + ghamu(:,:,:) = 0.0_wp + ghamv(:,:,:) = 0.0_wp + ! + IF ( ln_dia_osm ) THEN ! Initialise auxiliary arrays for diagnostic output + osmdia2d(:,:) = 0.0_wp + osmdia3d(:,:,:) = 0.0_wp + END IF + ! + END SUBROUTINE zdf_osm_init + + SUBROUTINE osm_rst( kt, Kmm, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE osm_rst *** + !! + !! ** Purpose : Read or write BL fields in restart file + !! + !! ** Method : use of IOM library. If the restart does not contain + !! required fields, they are recomputed from stratification + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! Ocean time step index + INTEGER , INTENT(in ) :: Kmm ! Ocean time level index (middle) + CHARACTER(len=*), INTENT(in ) :: cdrw ! "READ"/"WRITE" flag + !! + INTEGER :: id1, id2, id3 ! iom enquiry index + INTEGER :: ji, jj, jk ! Dummy loop indices + INTEGER :: iiki, ikt ! Local integer + REAL(wp) :: zhbf ! Tempory scalars + REAL(wp) :: zN2_c ! Local scalar + REAL(wp) :: rho_c = 0.01_wp ! Density criterion for mixed layer depth + INTEGER, DIMENSION(jpi,jpj) :: imld_rst ! Level of mixed-layer depth (pycnocline top) + !!---------------------------------------------------------------------- + ! + !!----------------------------------------------------------------------------- + ! If READ/WRITE Flag is 'READ', try to get hbl from restart file. If successful then return + !!----------------------------------------------------------------------------- + IF( TRIM(cdrw) == 'READ' .AND. ln_rstart) THEN + id1 = iom_varid( numror, 'wn', ldstop = .FALSE. ) + IF( id1 > 0 ) THEN ! 'wn' exists; read + CALL iom_get( numror, jpdom_auto, 'wn', ww ) + WRITE(numout,*) ' ===>>>> : wn read from restart file' + ELSE + ww(:,:,:) = 0.0_wp + WRITE(numout,*) ' ===>>>> : wn not in restart file, set to zero initially' + END IF + ! + id1 = iom_varid( numror, 'hbl', ldstop = .FALSE. ) + id2 = iom_varid( numror, 'dh', ldstop = .FALSE. ) + IF( id1 > 0 .AND. id2 > 0 ) THEN ! 'hbl' exists; read and return + CALL iom_get( numror, jpdom_auto, 'hbl', hbl ) + CALL iom_get( numror, jpdom_auto, 'dh', dh ) + hml(:,:) = hbl(:,:) - dh(:,:) ! Initialise ML depth + WRITE(numout,*) ' ===>>>> : hbl & dh read from restart file' + IF( ln_osm_mle ) THEN + id3 = iom_varid( numror, 'hmle', ldstop = .FALSE. ) + IF( id3 > 0 ) THEN + CALL iom_get( numror, jpdom_auto, 'hmle', hmle ) + WRITE(numout,*) ' ===>>>> : hmle read from restart file' + ELSE + WRITE(numout,*) ' ===>>>> : hmle not found, set to hbl' + hmle(:,:) = hbl(:,:) ! Initialise MLE depth + END IF + END IF + RETURN + ELSE ! 'hbl' & 'dh' not in restart file, recalculate + WRITE(numout,*) ' ===>>>> : previous run without osmosis scheme, hbl computed from stratification' + END IF + END IF + ! + !!----------------------------------------------------------------------------- + ! If READ/WRITE Flag is 'WRITE', write hbl into the restart file, then return + !!----------------------------------------------------------------------------- + IF ( TRIM(cdrw) == 'WRITE' ) THEN + IF(lwp) WRITE(numout,*) '---- osm-rst ----' + CALL iom_rstput( kt, nitrst, numrow, 'wn', ww ) + CALL iom_rstput( kt, nitrst, numrow, 'hbl', hbl ) + CALL iom_rstput( kt, nitrst, numrow, 'dh', dh ) + IF ( ln_osm_mle ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'hmle', hmle ) + END IF + RETURN + END IF + ! + !!----------------------------------------------------------------------------- + ! Getting hbl, no restart file with hbl, so calculate from surface stratification + !!----------------------------------------------------------------------------- + IF( lwp ) WRITE(numout,*) ' ===>>>> : calculating hbl computed from stratification' + ! w-level of the mixing and mixed layers + CALL eos_rab( ts(:,:,:,:,Kmm), rab_n, Kmm ) + CALL bn2( ts(:,:,:,:,Kmm), rab_n, rn2, Kmm ) + imld_rst(:,:) = nlb10 ! Initialization to the number of w ocean point + hbl(:,:) = 0.0_wp ! Here hbl used as a dummy variable, integrating vertically N^2 + zN2_c = grav * rho_c * r1_rho0 ! Convert density criteria into N^2 criteria + ! + hbl(:,:) = 0.0_wp ! Here hbl used as a dummy variable, integrating vertically N^2 + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls), ntej+( nn_hls) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + ikt = mbkt(ji,jj) + hbl(ji,jj) = hbl(ji,jj) + MAX( rn2(ji,jj,jk) , 0.0_wp ) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + IF ( hbl(ji,jj) < zN2_c ) imld_rst(ji,jj) = MIN( jk , ikt ) + 1 ! Mixed layer level + END DO ; END DO ; END DO + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls) + iiki = MAX( 4, imld_rst(ji,jj) ) + hbl(ji,jj) = (gdepw_0(ji,jj,iiki)*(1._wp+r3t(ji,jj,Kmm ))) ! Turbocline depth + dh(ji,jj) = (e3t_0(ji,jj,iiki-1)*(1._wp+r3t(ji,jj,Kmm )*tmask(ji,jj,iiki-1))) ! Turbocline depth + hml(ji,jj) = hbl(ji,jj) - dh(ji,jj) + END DO ; END DO + ! + WRITE(numout,*) ' ===>>>> : hbl computed from stratification' + ! + IF( ln_osm_mle ) THEN + hmle(:,:) = hbl(:,:) ! Initialise MLE depth. + WRITE(numout,*) ' ===>>>> : hmle set = to hbl' + END IF + ! + ww(:,:,:) = 0.0_wp + WRITE(numout,*) ' ===>>>> : wn not in restart file, set to zero initially' + ! + END SUBROUTINE osm_rst + + SUBROUTINE tra_osm( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_osm *** + !! + !! ** Purpose : compute and add to the tracer trend the non-local tracer flux + !! + !! ** Method : ??? + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! Time step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! Time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! Active tracers and RHS of tracer equation + !! + INTEGER :: ji, jj, jk + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF ( kt == nit000 ) THEN + IF ( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + END IF + END IF + ! + IF ( l_trdtra ) THEN ! Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) + END IF + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & + & - ( ghamt(ji,jj,jk ) & + & - ghamt(ji,jj,jk+1) ) /(e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) & + & - ( ghams(ji,jj,jk ) & + & - ghams(ji,jj,jk+1) ) / (e3t_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + IF ( l_trdtra ) THEN ! Save the non-local tracer flux trends for diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_osm, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_osm, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + END IF + ! + ! IF ( sn_cfctl%l_prtctl ) THEN + !CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' osm - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! END IF + ! + END SUBROUTINE tra_osm + + SUBROUTINE trc_osm( kt ) ! Dummy routine + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_osm *** + !! + !! ** Purpose : compute and add to the passive tracer trend the non-local + !! passive tracer flux + !! + !! + !! ** Method : ??? + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + !!---------------------------------------------------------------------- + ! + WRITE(*,*) 'trc_osm: Not written yet', kt + ! + END SUBROUTINE trc_osm + + SUBROUTINE dyn_osm( kt, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_osm *** + !! + !! ** Purpose : compute and add to the velocity trend the non-local flux + !! copied/modified from tra_osm + !! + !! ** Method : ??? + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! Ocean time step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! Ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! Ocean velocities and RHS of momentum equation + !! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF ( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_osm : OSM non-local velocity' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + END IF + ! + ! Code saving tracer trends removed, replace with trdmxl_oce + ! + DO jk = 1, jpkm1 ; DO jj = ntsj-( 0), ntej+( 0) ; DO ji = ntsi-( 0), ntei+( 0) ! Add non-local u and v fluxes + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( ghamu(ji,jj,jk ) - & + & ghamu(ji,jj,jk+1) ) / (e3u_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm)*umask(ji,jj,jk))) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( ghamv(ji,jj,jk ) - & + & ghamv(ji,jj,jk+1) ) / (e3v_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm)*vmask(ji,jj,jk))) + END DO ; END DO ; END DO + ! + ! Code for saving tracer trends removed + ! + END SUBROUTINE dyn_osm + + SUBROUTINE zdf_osm_iomput_2d( cdname, posmdia2d ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_iomput_2d *** + !! + !! ** Purpose : Wrapper for subroutine iom_put that accepts 2D arrays + !! with and without halo + !! + !!---------------------------------------------------------------------- + CHARACTER(LEN=*), INTENT(in ) :: cdname + REAL(wp), DIMENSION(:,:), INTENT(in ) :: posmdia2d + !!---------------------------------------------------------------------- + ! + IF ( ln_dia_osm .AND. iom_use( cdname ) ) THEN + IF ( SIZE( posmdia2d, 1 ) == ntei-ntsi+1 .AND. SIZE( posmdia2d, 2 ) == ntej-ntsj+1 ) THEN ! Halo absent + osmdia2d(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0)) = posmdia2d(:,:) + CALL iom_put( cdname, osmdia2d(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) ) + ELSE ! Halo present + CALL iom_put( cdname, osmdia2d ) + END IF + END IF + ! + END SUBROUTINE zdf_osm_iomput_2d + + SUBROUTINE zdf_osm_iomput_3d( cdname, posmdia3d ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_iomput_3d *** + !! + !! ** Purpose : Wrapper for subroutine iom_put that accepts 3D arrays + !! with and without halo + !! + !!---------------------------------------------------------------------- + CHARACTER(LEN=*), INTENT(in ) :: cdname + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: posmdia3d + !!---------------------------------------------------------------------- + ! + IF ( ln_dia_osm .AND. iom_use( cdname ) ) THEN + IF ( SIZE( posmdia3d, 1 ) == ntei-ntsi+1 .AND. SIZE( posmdia3d, 2 ) == ntej-ntsj+1 ) THEN ! Halo absent + osmdia3d(ntsi-(0):ntei+(0),ntsj-(0):ntej+(0),:) = posmdia3d(:,:,:) + CALL iom_put( cdname, osmdia3d(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),:) ) + ELSE ! Halo present + CALL iom_put( cdname, osmdia3d ) + END IF + END IF + ! + END SUBROUTINE zdf_osm_iomput_3d + + !!====================================================================== + +END MODULE zdfosm diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfphy.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfphy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0a169e7bf045bb218f48f95dc1c007263050f570 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfphy.f90 @@ -0,0 +1,399 @@ + + + + + + + + + + + + + +MODULE zdfphy + !!====================================================================== + !! *** MODULE zdfphy *** + !! Vertical ocean physics : manager of all vertical physics packages + !!====================================================================== + !! History : 4.0 ! 2017-04 (G. Madec) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_phy_init : initialization of all vertical physics packages + !! zdf_phy : upadate at each time-step the vertical mixing coeff. + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + ! TEMP: [tiling] This change not necessary after finalisation of zdf_osm (not yet tiled) + USE domtile + USE zdf_oce ! vertical physics: shared variables + USE zdfdrg ! vertical physics: top/bottom drag coef. + USE zdfsh2 ! vertical physics: shear production term of TKE + USE zdfric ! vertical physics: RIChardson dependent vertical mixing + USE zdftke ! vertical physics: TKE vertical mixing + USE zdfgls ! vertical physics: GLS vertical mixing + USE zdfosm ! vertical physics: OSMOSIS vertical mixing + USE zdfddm ! vertical physics: double diffusion mixing + USE zdfevd ! vertical physics: convection via enhanced vertical diffusion + USE zdfmfc ! vertical physics: Mass Flux Convection + USE zdfiwm ! vertical physics: internal wave-induced mixing + USE zdfswm ! vertical physics: surface wave-induced mixing + USE zdfmxl ! vertical physics: mixed layer + USE tranpc ! convection: non penetrative adjustment + USE trc_oce ! variables shared between passive tracer & ocean + USE sbc_oce ! surface module (only for nn_isf in the option compatibility test) + USE sbcrnf ! surface boundary condition: runoff variables + USE sbc_ice ! sea ice drag + ! + USE in_out_manager ! I/O manager + USE iom ! IOM library + USE lbclnk ! lateral boundary conditions + USE lib_mpp ! distribued memory computing + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_phy_init ! called by nemogcm.F90 + PUBLIC zdf_phy ! called by step.F90 + + INTEGER :: nzdf_phy ! type of vertical closure used + ! ! associated indicators + INTEGER, PARAMETER :: np_CST = 1 ! Constant Kz + INTEGER, PARAMETER :: np_RIC = 2 ! Richardson number dependent Kz + INTEGER, PARAMETER :: np_TKE = 3 ! Turbulente Kinetic Eenergy closure scheme for Kz + INTEGER, PARAMETER :: np_GLS = 4 ! Generic Length Scale closure scheme for Kz + INTEGER, PARAMETER :: np_OSM = 5 ! OSMOSIS-OBL closure scheme for Kz + + LOGICAL, PUBLIC :: l_zdfsh2 ! shear production term flag (=F for CST, =T otherwise (i.e. TKE, GLS, RIC)) + + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm_k_n !: "Now" avm_k used for calculation of zsh2 with tiling + + !! * Substitutions + + + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfphy.F90 15553 2021-11-29 11:36:23Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_phy_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_phy_init *** + !! + !! ** Purpose : initializations of the vertical ocean physics + !! + !! ** Method : Read namelist namzdf, control logicals + !! set horizontal shape and vertical profile of background mixing coef. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! time level index (middle) + ! + INTEGER :: jk ! dummy loop indices + INTEGER :: ioptio, ios ! local integers + !! + NAMELIST/namzdf/ ln_zdfcst, ln_zdfric, ln_zdftke, ln_zdfgls, & ! type of closure scheme + & ln_zdfosm, & ! type of closure scheme + & ln_zdfmfc, & ! convection : mass flux + & ln_zdfevd, nn_evdm, rn_evd , & ! convection : evd + & ln_zdfnpc, nn_npc , nn_npcp, & ! convection : npc + & ln_zdfddm, rn_avts, rn_hsbfr, & ! double diffusion + & ln_zdfswm, & ! surface wave-induced mixing + & ln_zdfiwm, & ! internal - - - + & ln_zad_Aimp, & ! apdative-implicit vertical advection + & rn_avm0, rn_avt0, nn_avb, nn_havtb ! coefficients + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'zdf_phy_init: ocean vertical physics' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + ! !== Namelist ==! + READ ( numnam_ref, namzdf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf in reference namelist' ) + ! + READ ( numnam_cfg, namzdf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf ) + ! + IF(lwp) THEN ! Parameter print + WRITE(numout,*) ' Namelist namzdf : set vertical mixing mixing parameters' + WRITE(numout,*) ' adaptive-implicit vertical advection' + WRITE(numout,*) ' Courant number targeted application ln_zad_Aimp = ', ln_zad_Aimp + WRITE(numout,*) ' vertical closure scheme' + WRITE(numout,*) ' constant vertical mixing coefficient ln_zdfcst = ', ln_zdfcst + WRITE(numout,*) ' Richardson number dependent closure ln_zdfric = ', ln_zdfric + WRITE(numout,*) ' Turbulent Kinetic Energy closure (TKE) ln_zdftke = ', ln_zdftke + WRITE(numout,*) ' Generic Length Scale closure (GLS) ln_zdfgls = ', ln_zdfgls + WRITE(numout,*) ' OSMOSIS-OBL closure (OSM) ln_zdfosm = ', ln_zdfosm + WRITE(numout,*) ' convection: ' + WRITE(numout,*) ' convection mass flux (mfc) ln_zdfmfc = ', ln_zdfmfc + WRITE(numout,*) ' enhanced vertical diffusion ln_zdfevd = ', ln_zdfevd + WRITE(numout,*) ' applied on momentum (=1/0) nn_evdm = ', nn_evdm + WRITE(numout,*) ' vertical coefficient for evd rn_evd = ', rn_evd + WRITE(numout,*) ' non-penetrative convection (npc) ln_zdfnpc = ', ln_zdfnpc + WRITE(numout,*) ' npc call frequency nn_npc = ', nn_npc + WRITE(numout,*) ' npc print frequency nn_npcp = ', nn_npcp + WRITE(numout,*) ' double diffusive mixing ln_zdfddm = ', ln_zdfddm + WRITE(numout,*) ' maximum avs for dd mixing rn_avts = ', rn_avts + WRITE(numout,*) ' heat/salt buoyancy flux ratio rn_hsbfr= ', rn_hsbfr + WRITE(numout,*) ' gravity wave-induced mixing' + WRITE(numout,*) ' surface wave (Qiao et al 2010) ln_zdfswm = ', ln_zdfswm ! surface wave induced mixing + WRITE(numout,*) ' internal wave (de Lavergne et al 2017) ln_zdfiwm = ', ln_zdfiwm + WRITE(numout,*) ' coefficients : ' + WRITE(numout,*) ' vertical eddy viscosity rn_avm0 = ', rn_avm0 + WRITE(numout,*) ' vertical eddy diffusivity rn_avt0 = ', rn_avt0 + WRITE(numout,*) ' constant background or profile nn_avb = ', nn_avb + WRITE(numout,*) ' horizontal variation for avtb nn_havtb = ', nn_havtb + ENDIF + + IF( ln_zad_Aimp ) THEN + IF( zdf_phy_alloc() /= 0 ) & + & CALL ctl_stop( 'STOP', 'zdf_phy_init : unable to allocate adaptive-implicit z-advection arrays' ) + Cu_adv(:,:,:) = 0._wp + wi (:,:,:) = 0._wp + ENDIF + ! ! Initialise zdf_mxl arrays (only hmld as not set everywhere when nn_hls > 1) + IF( zdf_mxl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_mxl : unable to allocate arrays' ) + hmld(:,:) = 0._wp + ! !== Background eddy viscosity and diffusivity ==! + IF( nn_avb == 0 ) THEN ! Define avmb, avtb from namelist parameter + avmb(:) = rn_avm0 + avtb(:) = rn_avt0 + ELSE ! Background profile of avt (fit a theoretical/observational profile (Krauss 1990) + avmb(:) = rn_avm0 + avtb(:) = rn_avt0 + ( 3.e-4_wp - 2._wp * rn_avt0 ) * 1.e-4_wp * gdepw_1d(:) ! m2/s + IF(ln_sco .AND. lwp) CALL ctl_warn( 'avtb profile not valid in sco' ) + ENDIF + ! ! 2D shape of the avtb + avtb_2d(:,:) = 1._wp ! uniform + ! + IF( nn_havtb == 1 ) THEN ! decrease avtb by a factor of ten in the equatorial band + ! ! -15S -5S : linear decrease from avt0 to avt0/10. + ! ! -5S +5N : cst value avt0/10. + ! ! 5N 15N : linear increase from avt0/10, to avt0 + WHERE(-15. <= gphit .AND. gphit < -5 ) avtb_2d = (1. - 0.09 * (gphit + 15.)) + WHERE( -5. <= gphit .AND. gphit < 5 ) avtb_2d = 0.1 + WHERE( 5. <= gphit .AND. gphit < 15 ) avtb_2d = (0.1 + 0.09 * (gphit - 5.)) + ENDIF + ! + DO jk = 1, jpk ! set turbulent closure Kz to the background value (avt_k, avm_k) + avt_k(:,:,jk) = avtb_2d(:,:) * avtb(jk) * wmask (:,:,jk) + avm_k(:,:,jk) = avmb(jk) * wmask (:,:,jk) + END DO +!!gm to be tested only the 1st & last levels +! avt (:,:, 1 ) = 0._wp ; avs(:,:, 1 ) = 0._wp ; avm (:,:, 1 ) = 0._wp +! avt (:,:,jpk) = 0._wp ; avs(:,:,jpk) = 0._wp ; avm (:,:,jpk) = 0._wp +!!gm + avt (:,:,:) = 0._wp ; avs(:,:,:) = 0._wp ; avm (:,:,:) = 0._wp + + ! !== Convection ==! + ! + IF( ln_zdfnpc .AND. ln_zdfevd ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfnpc and ln_zdfevd' ) + IF( ln_zdfosm .AND. ln_zdfevd ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfosm and ln_zdfevd' ) + IF( ln_zdfmfc .AND. ln_zdfevd ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfevd' ) + IF( ln_zdfmfc .AND. ln_zdfnpc ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfnpc' ) + IF( ln_zdfmfc .AND. ln_zdfosm ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfosm' ) + IF( lk_top .AND. ln_zdfnpc ) CALL ctl_stop( 'zdf_phy_init: npc scheme is not working with key_top' ) + IF( lk_top .AND. ln_zdfosm ) CALL ctl_warn( 'zdf_phy_init: osmosis gives no non-local fluxes for TOP tracers yet' ) + IF( lk_top .AND. ln_zdfmfc ) CALL ctl_stop( 'zdf_phy_init: Mass Flux scheme is not working with key_top' ) + IF(lwp) THEN + WRITE(numout,*) + IF ( ln_zdfnpc ) THEN ; WRITE(numout,*) ' ==>>> convection: use non penetrative convective scheme' + ELSEIF( ln_zdfevd ) THEN ; WRITE(numout,*) ' ==>>> convection: use enhanced vertical diffusion scheme' + ELSEIF( ln_zdfmfc ) THEN ; WRITE(numout,*) ' ==>>> convection: use Mass Flux scheme' + ELSE ; WRITE(numout,*) ' ==>>> convection: no specific scheme used' + ENDIF + ENDIF + + IF(lwp) THEN !== Double Diffusion Mixing parameterization ==! (ddm) + WRITE(numout,*) + IF( ln_zdfddm ) THEN ; WRITE(numout,*) ' ==>>> use double diffusive mixing: avs /= avt' + ELSE ; WRITE(numout,*) ' ==>>> No double diffusive mixing: avs = avt' + ENDIF + ENDIF + + ! !== type of vertical turbulent closure ==! (set nzdf_phy) + ioptio = 0 + IF( ln_zdfcst ) THEN ; ioptio = ioptio + 1 ; nzdf_phy = np_CST ; ENDIF + IF( ln_zdfric ) THEN ; ioptio = ioptio + 1 ; nzdf_phy = np_RIC ; CALL zdf_ric_init ; ENDIF + IF( ln_zdftke ) THEN ; ioptio = ioptio + 1 ; nzdf_phy = np_TKE ; CALL zdf_tke_init( Kmm ) ; ENDIF + IF( ln_zdfgls ) THEN ; ioptio = ioptio + 1 ; nzdf_phy = np_GLS ; CALL zdf_gls_init ; ENDIF + IF( ln_zdfosm ) THEN ; ioptio = ioptio + 1 ; nzdf_phy = np_OSM ; CALL zdf_osm_init( Kmm ) ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'zdf_phy_init: one and only one vertical diffusion option has to be defined ' ) + IF( ln_isfcav ) THEN + IF( ln_zdfric ) CALL ctl_stop( 'zdf_phy_init: zdfric never tested with ice shelves cavities ' ) + ENDIF + ! ! shear production term flag + IF( ln_zdfcst .OR. ln_zdfosm ) THEN ; l_zdfsh2 = .FALSE. + ELSE ; l_zdfsh2 = .TRUE. + ENDIF + IF( ln_tile .AND. l_zdfsh2 ) ALLOCATE( avm_k_n(jpi,jpj,jpk) ) + ! !== Mass Flux Convectiive algorithm ==! + IF( ln_zdfmfc ) CALL zdf_mfc_init ! Convection computed with eddy diffusivity mass flux + ! + ! !== gravity wave-driven mixing ==! + IF( ln_zdfiwm ) CALL zdf_iwm_init ! internal wave-driven mixing + IF( ln_zdfswm ) CALL zdf_swm_init ! surface wave-driven mixing + + ! !== top/bottom friction ==! + CALL zdf_drg_init + ! + ! !== time-stepping ==! + ! Check/update of time stepping done in dynzdf_init/trazdf_init + !!gm move it here ? + ! + END SUBROUTINE zdf_phy_init + + + SUBROUTINE zdf_phy( kt, Kbb, Kmm, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_phy *** + !! + !! ** Purpose : Update ocean physics at each time-step + !! + !! ** Method : + !! + !! ** Action : avm, avt vertical eddy viscosity and diffusivity at w-points + !! nmld ??? mixed layer depth in level and meters <<<<====verifier ! + !! bottom stress..... <<<<====verifier ! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kbb, Kmm, Krhs ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indice + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zsh2 ! shear production + !! --------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('zdf_phy') + ! + IF( l_zdfdrg ) THEN !== update top/bottom drag ==! (non-linear cases) + ! + ! !* bottom drag + CALL zdf_drg( kt, Kmm, mbkt , r_Cdmin_bot, r_Cdmax_bot, & ! <<== in + & r_z0_bot, r_ke0_bot, rCd0_bot, & + & rCdU_bot ) ! ==>> out : bottom drag [m/s] + IF( ln_isfcav ) THEN !* top drag (ocean cavities) + CALL zdf_drg( kt, Kmm, mikt , r_Cdmin_top, r_Cdmax_top, & ! <<== in + & r_z0_top, r_ke0_top, rCd0_top, & + & rCdU_top ) ! ==>> out : bottom drag [m/s] + ENDIF + ENDIF + ! + ! + CALL zdf_mxl( kt, Kmm ) !* mixed layer depth, and level + ! + ! !== Kz from chosen turbulent closure ==! (avm_k, avt_k) + ! + ! NOTE: [tiling] the closure schemes (zdf_tke etc) will update avm_k. With tiling, the calculation of zsh2 on adjacent tiles then uses both updated (next timestep) and non-updated (current timestep) values of avm_k. To preserve results, we save a read-only copy of the "now" avm_k to use in the calculation of zsh2. + IF( l_zdfsh2 ) THEN !* shear production at w-points (energy conserving form) + IF( ln_tile ) THEN + IF( ntile == 1 ) avm_k_n(:,:,:) = avm_k(:,:,:) ! Preserve "now" avm_k for calculation of zsh2 + CALL zdf_sh2( Kbb, Kmm, avm_k_n, & ! <<== in + & zsh2 ) ! ==>> out : shear production + ELSE + CALL zdf_sh2( Kbb, Kmm, avm_k, & ! <<== in + & zsh2 ) ! ==>> out : shear production + ENDIF + ENDIF + ! + SELECT CASE ( nzdf_phy ) !* Vertical eddy viscosity and diffusivity coefficients at w-points + CASE( np_RIC ) ; CALL zdf_ric( kt, Kmm, zsh2, avm_k, avt_k ) ! Richardson number dependent Kz + CASE( np_TKE ) ; CALL zdf_tke( kt, Kbb, Kmm, zsh2, avm_k, avt_k ) ! TKE closure scheme for Kz + CASE( np_GLS ) ; CALL zdf_gls( kt, Kbb, Kmm, zsh2, avm_k, avt_k ) ! GLS closure scheme for Kz + CASE( np_OSM ) ; CALL zdf_osm( kt, Kbb, Kmm, Krhs, avm_k, avt_k ) ! OSMOSIS closure scheme for Kz + ! CASE( np_CST ) ! Constant Kz (reset avt, avm to the background value) + ! ! avt_k and avm_k set one for all at initialisation phase +!!gm avt(2:jpim1,2:jpjm1,1:jpkm1) = rn_avt0 * wmask(2:jpim1,2:jpjm1,1:jpkm1) +!!gm avm(2:jpim1,2:jpjm1,1:jpkm1) = rn_avm0 * wmask(2:jpim1,2:jpjm1,1:jpkm1) + END SELECT + ! + ! !== ocean Kz ==! (avt, avs, avm) + ! + ! !* start from turbulent closure values + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + avt(ji,jj,jk) = avt_k(ji,jj,jk) + avm(ji,jj,jk) = avm_k(ji,jj,jk) + END DO ; END DO ; END DO + ! + IF( ln_rnf_mouth ) THEN !* increase diffusivity at rivers mouths + DO jk = 2, nkrnf ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + avt(ji,jj,jk) = avt(ji,jj,jk) + 2._wp * rn_avt_rnf * rnfmsk(ji,jj) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ! + IF( ln_zdfevd ) CALL zdf_evd( kt, Kmm, Krhs, avm, avt ) !* convection: enhanced vertical eddy diffusivity + ! + ! !* double diffusive mixing + IF( ln_zdfddm ) THEN ! update avt and compute avs + CALL zdf_ddm( kt, Kmm, avm, avt, avs ) + ELSE ! same mixing on all tracers + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + avs(ji,jj,jk) = avt(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ! + ! !* wave-induced mixing + IF( ln_zdfswm ) CALL zdf_swm( kt, Kmm, avm, avt, avs ) ! surface wave (Qiao et al. 2004) + IF( ln_zdfiwm ) CALL zdf_iwm( kt, Kmm, avm, avt, avs ) ! internal wave (de Lavergne et al 2017) + + ! !* Lateral boundary conditions (sign unchanged) + IF(nn_hls==1) THEN + IF( l_zdfsh2 ) THEN + CALL lbc_lnk( 'zdfphy', avm_k, 'W', 1.0_wp , avt_k, 'W', 1.0_wp, & + & avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) + ELSE + CALL lbc_lnk( 'zdfphy', avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) + ENDIF + ! + IF( l_zdfdrg ) THEN ! drag have been updated (non-linear cases) + IF( ln_isfcav ) THEN ; CALL lbc_lnk( 'zdfphy', rCdU_top, 'T', 1.0_wp , rCdU_bot, 'T', 1.0_wp ) ! top & bot drag + ELSE ; CALL lbc_lnk( 'zdfphy', rCdU_bot, 'T', 1.0_wp ) ! bottom drag only + ENDIF + ENDIF + ENDIF + ! + CALL zdf_mxl_turb( kt, Kmm ) !* turbocline depth + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF( lrst_oce ) THEN !* write TKE, GLS or RIC fields in the restart file + IF( ln_zdftke ) CALL tke_rst( kt, 'WRITE' ) + IF( ln_zdfgls ) CALL gls_rst( kt, 'WRITE' ) + IF( ln_zdfric ) CALL ric_rst( kt, 'WRITE' ) + ! NB. OSMOSIS restart (osm_rst) will be called in step.F90 after ww has been updated + ENDIF + ENDIF + ! + ! diagnostics of energy dissipation + IF( iom_use('avt_k') .OR. iom_use('avm_k') .OR. iom_use('eshear_k') .OR. iom_use('estrat_k') ) THEN + IF( l_zdfsh2 ) THEN + CALL iom_put( 'avt_k' , avt_k * wmask ) + CALL iom_put( 'avm_k' , avm_k * wmask ) + CALL iom_put( 'eshear_k', zsh2 * wmask ) + CALL iom_put( 'estrat_k', - avt_k * rn2 * wmask ) + ENDIF + ENDIF + ! + IF( ln_timing ) CALL timing_stop('zdf_phy') + ! + END SUBROUTINE zdf_phy + + + INTEGER FUNCTION zdf_phy_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_phy_alloc *** + !!---------------------------------------------------------------------- + ! Allocate wi array (declared in oce.F90) for use with the adaptive-implicit vertical velocity option + ALLOCATE( wi(jpi,jpj,jpk), Cu_adv(jpi,jpj,jpk), STAT= zdf_phy_alloc ) + IF( zdf_phy_alloc /= 0 ) CALL ctl_warn('zdf_phy_alloc: failed to allocate ln_zad_Aimp=T required arrays') + CALL mpp_sum ( 'zdfphy', zdf_phy_alloc ) + END FUNCTION zdf_phy_alloc + + !!====================================================================== +END MODULE zdfphy diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfric.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfric.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c0003b3667e3c6166aedf63fc84eca7b66f09cc8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfric.f90 @@ -0,0 +1,258 @@ + + + + + + + + + + + + + +MODULE zdfric + !!====================================================================== + !! *** MODULE zdfric *** + !! Ocean physics: vertical mixing coefficient compute from the local + !! Richardson number dependent formulation + !!====================================================================== + !! History : OPA ! 1987-09 (P. Andrich) Original code + !! 4.0 ! 1991-11 (G. Madec) + !! 7.0 ! 1996-01 (G. Madec) complete rewriting of multitasking suppression of common work arrays + !! 8.0 ! 1997-06 (G. Madec) complete rewriting of zdfmix + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.3.1! 2011-09 (P. Oddo) Mixed layer depth parameterization + !! 4.0 ! 2017-04 (G. Madec) remove CPP ddm key & avm at t-point only + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_ric_init : initialization, namelist read, & parameters control + !! zdf_ric : update momentum and tracer Kz from the Richardson number + !! ric_rst : read/write RIC restart in ocean restart file + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE zdf_oce ! vertical physics: variables + USE phycst ! physical constants + USE sbc_oce, ONLY : taum + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_ric ! called by zdfphy.F90 + PUBLIC ric_rst ! called by zdfphy.F90 + PUBLIC zdf_ric_init ! called by nemogcm.F90 + + ! !!* Namelist namzdf_ric : Richardson number dependent Kz * + INTEGER :: nn_ric ! coefficient of the parameterization + REAL(wp) :: rn_avmri ! maximum value of the vertical eddy viscosity + REAL(wp) :: rn_alp ! coefficient of the parameterization + REAL(wp) :: rn_ekmfc ! Ekman Factor Coeff + REAL(wp) :: rn_mldmin ! minimum mixed layer (ML) depth + REAL(wp) :: rn_mldmax ! maximum mixed layer depth + REAL(wp) :: rn_wtmix ! Vertical eddy Diff. in the ML + REAL(wp) :: rn_wvmix ! Vertical eddy Visc. in the ML + LOGICAL :: ln_mldw ! Use or not the MLD parameters + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfric.F90 15277 2021-09-22 13:19:40Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_ric_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_ric_init *** + !! + !! ** Purpose : Initialization of the vertical eddy diffusivity and + !! viscosity coef. for the Richardson number dependent formulation. + !! + !! ** Method : Read the namzdf_ric namelist and check the parameter values + !! + !! ** input : Namelist namzdf_ric + !! + !! ** Action : increase by 1 the nstop flag is setting problem encounter + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namzdf_ric/ rn_avmri, rn_alp , nn_ric , rn_ekmfc, & + & rn_mldmin, rn_mldmax, rn_wtmix, rn_wvmix, ln_mldw + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namzdf_ric, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_ric in reference namelist' ) + + READ ( numnam_cfg, namzdf_ric, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_ric in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_ric ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_ric_init : Ri depend vertical mixing scheme' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_ric : set Kz=F(Ri) parameters' + WRITE(numout,*) ' maximum vertical viscosity rn_avmri = ', rn_avmri + WRITE(numout,*) ' coefficient rn_alp = ', rn_alp + WRITE(numout,*) ' exponent nn_ric = ', nn_ric + WRITE(numout,*) ' Ekman layer enhanced mixing ln_mldw = ', ln_mldw + WRITE(numout,*) ' Ekman Factor Coeff rn_ekmfc = ', rn_ekmfc + WRITE(numout,*) ' minimum mixed layer depth rn_mldmin = ', rn_mldmin + WRITE(numout,*) ' maximum mixed layer depth rn_mldmax = ', rn_mldmax + WRITE(numout,*) ' Vertical eddy Diff. in the ML rn_wtmix = ', rn_wtmix + WRITE(numout,*) ' Vertical eddy Visc. in the ML rn_wvmix = ', rn_wvmix + ENDIF + ! + CALL ric_rst( nit000, 'READ' ) !* read or initialize all required files + ! + END SUBROUTINE zdf_ric_init + + + SUBROUTINE zdf_ric( kt, Kmm, p_sh2, p_avm, p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdfric *** + !! + !! ** Purpose : Compute the before eddy viscosity and diffusivity as + !! a function of the local richardson number. + !! + !! ** Method : Local richardson number dependent formulation of the + !! vertical eddy viscosity and diffusivity coefficients. + !! The eddy coefficients are given by: + !! avm = avm0 + avmb + !! avt = avm0 / (1 + rn_alp*ri) + !! with ri = N^2 / dz(u)**2 + !! = e3w**2 * rn2/[ mi( dk(uu(:,:,:,Kbb)) )+mj( dk(vv(:,:,:,Kbb)) ) ] + !! avm0= rn_avmri / (1 + rn_alp*Ri)**nn_ric + !! where ri is the before local Richardson number, + !! rn_avmri is the maximum value reaches by avm and avt + !! and rn_alp, nn_ric are adjustable parameters. + !! Typical values : rn_alp=5. and nn_ric=2. + !! + !! As second step compute Ekman depth from wind stress forcing + !! and apply namelist provided vertical coeff within this depth. + !! The Ekman depth is: + !! Ustar = SQRT(Taum/rho0) + !! ekd= rn_ekmfc * Ustar / f0 + !! Large et al. (1994, eq.24) suggest rn_ekmfc=0.7; however, the derivation + !! of the above equation indicates the value is somewhat arbitrary; therefore + !! we allow the freedom to increase or decrease this value, if the + !! Ekman depth estimate appears too shallow or too deep, respectively. + !! Ekd is then limited by rn_mldmin and rn_mldmax provided in the + !! namelist + !! N.B. the mask are required for implicit scheme, and surface + !! and bottom value already set in zdfphy.F90 + !! + !! ** Action : avm, avt mixing coeff (inner domain values only) + !! + !! References : Pacanowski & Philander 1981, JPO, 1441-1451. + !! PFJ Lermusiaux 2001. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcfRi, zav, zustar, zhek ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zh_ekm ! 2D workspace + !!---------------------------------------------------------------------- + ! + ! !== avm and avt = F(Richardson number) ==! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! coefficient = F(richardson number) (avm-weighted Ri) + zcfRi = 1._wp / ( 1._wp + rn_alp * MAX( 0._wp , avm(ji,jj,jk) * rn2(ji,jj,jk) / ( p_sh2(ji,jj,jk) + 1.e-20 ) ) ) + zav = rn_avmri * zcfRi**nn_ric + ! ! avm and avt coefficients + p_avm(ji,jj,jk) = MAX( zav , avmb(jk) ) * wmask(ji,jj,jk) + p_avt(ji,jj,jk) = MAX( zav * zcfRi , avtb(jk) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! +!!gm BUG <<<<==== This param can't work at low latitude +!!gm it provides there much to thick mixed layer ( summer 150m in GYRE configuration !!! ) + ! + IF( ln_mldw ) THEN !== set a minimum value in the Ekman layer ==! + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zustar = SQRT( taum(ji,jj) * r1_rho0 ) + zhek = rn_ekmfc * zustar / ( ABS( ff_t(ji,jj) ) + rsmall ) ! Ekman depth + zh_ekm(ji,jj) = MAX( rn_mldmin , MIN( zhek , rn_mldmax ) ) ! set allowed range + END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) !* minimum mixing coeff. within the Ekman layer + IF( (gdept_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) < zh_ekm(ji,jj) ) THEN + p_avm(ji,jj,jk) = MAX( p_avm(ji,jj,jk), rn_wvmix ) * wmask(ji,jj,jk) + p_avt(ji,jj,jk) = MAX( p_avt(ji,jj,jk), rn_wtmix ) * wmask(ji,jj,jk) + ENDIF + END DO ; END DO ; END DO + ENDIF + ! + END SUBROUTINE zdf_ric + + + SUBROUTINE ric_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE ric_rst *** + !! + !! ** Purpose : Read or write TKE file (en) in restart file + !! + !! ** Method : use of IOM library + !! if the restart does not contain TKE, en is either + !! set to rn_emin or recomputed + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + INTEGER :: jit, jk ! dummy loop indices + INTEGER :: id1, id2 ! local integers + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + ! ! --------------- + ! !* Read the restart file + IF( ln_rstart ) THEN + id1 = iom_varid( numror, 'avt_k', ldstop = .FALSE. ) + id2 = iom_varid( numror, 'avm_k', ldstop = .FALSE. ) + ! + IF( MIN( id1, id2 ) > 0 ) THEN ! restart exists => read it + CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k ) + CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k ) + ENDIF + ENDIF + ! !* otherwise Kz already set to the background value in zdf_phy_init + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) '---- ric-rst ----' + CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k ) + CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k) + ! + ENDIF + ! + END SUBROUTINE ric_rst + + !!====================================================================== +END MODULE zdfric diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfsh2.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfsh2.f90 new file mode 100644 index 0000000000000000000000000000000000000000..acfbcc1e62e845d927c6ffaa99aa9effccfea2ea --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfsh2.f90 @@ -0,0 +1,134 @@ + + + + + + + + + + + + + +MODULE zdfsh2 + !!====================================================================== + !! *** MODULE zdfsh2 *** + !! Ocean physics: shear production term of TKE + !!===================================================================== + !! History : - ! 2014-10 (A. Barthelemy, G. Madec) original code + !! NEMO 4.0 ! 2017-04 (G. Madec) remove u-,v-pts avm + !! NEMO 4.2 ! 2020-12 (G. Madec, E. Clementi) add Stokes Drift Shear + ! ! for wave coupling + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_sh2 : compute mixing the shear production term of TKE + !!---------------------------------------------------------------------- + USE oce + USE dom_oce ! domain: ocean + USE sbcwave ! Surface Waves (add Stokes shear) + USE sbc_oce , ONLY: ln_stshear !Stoked Drift shear contribution + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_sh2 ! called by zdftke, zdfglf, and zdfric + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfsh2.F90 15293 2021-09-27 15:43:00Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_sh2( Kbb, Kmm, p_avm, p_sh2 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_sh2 *** + !! + !! ** Purpose : Compute the shear production term of a TKE equation + !! + !! ** Method : - a stable discretization of this term is linked to the + !! time-space discretization of the vertical diffusion + !! of the OGCM. NEMO uses C-grid, a leap-frog environment + !! and an implicit computation of vertical mixing term, + !! so the shear production at w-point is given by: + !! sh2 = mi[ mi(avm) * dk[ub]/e3ub * dk[un]/e3un ] + !! + mj[ mj(avm) * dk[vb]/e3vb * dk[vn]/e3vn ] + !! NB: wet-point only horizontal averaging of shear + !! + !! ** Action : - p_sh2 shear prod. term at w-point (inner domain only) + !! ***** + !! References : Bruchard, OM 2002 + !! --------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm ! vertical eddy viscosity (w-points) + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) , INTENT( out) :: p_sh2 ! shear production of TKE (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zsh2u, zsh2v ! 2D workspace + !!-------------------------------------------------------------------- + ! + DO jk = 2, jpkm1 !* Shear production at uw- and vw-points (energy conserving form) + IF ( cpl_sdrftx .AND. ln_stshear ) THEN ! Surface Stokes Drift available ===>>> shear + stokes drift contibution + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & + & * ( uu (ji,jj,jk-1,Kmm) - uu (ji,jj,jk,Kmm) & + & + usd(ji,jj,jk-1) - usd(ji,jj,jk) ) & + & * ( uu (ji,jj,jk-1,Kbb) - uu (ji,jj,jk,Kbb) ) & + & / ( (e3uw_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kmm))) * (e3uw_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kbb))) ) * wumask(ji,jj,jk) + zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & + & * ( vv (ji,jj,jk-1,Kmm) - vv (ji,jj,jk,Kmm) & + & + vsd(ji,jj,jk-1) - vsd(ji,jj,jk) ) & + & * ( vv (ji,jj,jk-1,Kbb) - vv (ji,jj,jk,Kbb) ) & + &/ ( (e3vw_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kmm))) * (e3vw_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kbb))) ) * wvmask(ji,jj,jk) + END DO ; END DO + ELSE + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) !* 2 x shear production at uw- and vw-points (energy conserving form) + zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & + & * ( uu(ji,jj,jk-1,Kmm) - uu(ji,jj,jk,Kmm) ) & + & * ( uu(ji,jj,jk-1,Kbb) - uu(ji,jj,jk,Kbb) ) & + & / ( (e3uw_0(ji,jj,jk )*(1._wp+r3u(ji,jj,Kmm))) * (e3uw_0(ji,jj,jk)*(1._wp+r3u(ji,jj,Kbb))) ) & + & * wumask(ji,jj,jk) + zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & + & * ( vv(ji,jj,jk-1,Kmm) - vv(ji,jj,jk,Kmm) ) & + & * ( vv(ji,jj,jk-1,Kbb) - vv(ji,jj,jk,Kbb) ) & + & / ( (e3vw_0(ji,jj,jk )*(1._wp+r3v(ji,jj,Kmm))) * (e3vw_0(ji,jj,jk)*(1._wp+r3v(ji,jj,Kbb))) ) & + & * wvmask(ji,jj,jk) + END DO ; END DO + ENDIF + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) !* shear production at w-point ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked) + p_sh2(ji,jj,jk) = 0.25 * ( ( zsh2u(ji-1,jj) + zsh2u(ji,jj) ) * ( 2. - umask(ji-1,jj,jk) * umask(ji,jj,jk) ) & + & + ( zsh2v(ji,jj-1) + zsh2v(ji,jj) ) * ( 2. - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) ) ) + END DO ; END DO + END DO + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! set p_sh2 to 0 at the surface and bottom for output purpose + p_sh2(ji,jj,1) = 0._wp + p_sh2(ji,jj,jpk) = 0._wp + END DO ; END DO + ! + END SUBROUTINE zdf_sh2 + + !!====================================================================== +END MODULE zdfsh2 diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfswm.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfswm.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c282da1f7c016c7b4a88d81ce2509cca7b9dfc64 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdfswm.f90 @@ -0,0 +1,125 @@ + + + + + + + + + + + + + +MODULE zdfswm + !!====================================================================== + !! *** MODULE zdfswm *** + !! vertical physics : surface wave-induced mixing + !!====================================================================== + !! History : 3.6 ! 2014-10 (E. Clementi) Original code + !! 4.0 ! 2017-04 (G. Madec) debug + simplifications + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_swm : update Kz due to surface wave-induced mixing + !! zdf_swm_init : initilisation + !!---------------------------------------------------------------------- + USE dom_oce ! ocean domain variable + USE zdf_oce ! vertical physics: mixing coefficients + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbcwave ! wave module + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_swm ! routine called in zdp_phy + PUBLIC zdf_swm_init ! routine called in zdf_phy_init + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfswm.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_swm( kt, Kmm, p_avm, p_avt, p_avs ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_swm *** + !! + !! ** Purpose :Compute the swm term (qbv) to be added to + !! vertical viscosity and diffusivity coeffs. + !! + !! ** Method : Compute the swm term Bv (zqb) and added it to + !! vertical viscosity and diffusivity coefficients + !! zqb = alpha * A * Us(0) * exp (3 * k * z) + !! where alpha is set here to 1 + !! + !! ** action : avt, avs, avm updated by the surface wave-induced mixing + !! (inner domain only) + !! + !! reference : Qiao et al. GRL, 2004 + !!--------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp):: zcoef, zqb ! local scalar + !!--------------------------------------------------------------------- + ! + zcoef = 1._wp * 0.353553_wp + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zqb = zcoef * hsw(ji,jj) * tsd2d(ji,jj) * EXP( -3. * wnum(ji,jj) * (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) * wmask(ji,jj,jk) + ! + p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zqb + p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zqb + p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + zqb + END DO ; END DO ; END DO + ! + END SUBROUTINE zdf_swm + + + SUBROUTINE zdf_swm_init + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_swm_init *** + !! + !! ** Purpose : surface wave-induced mixing initialisation + !! + !! ** Method : check the availability of surface wave fields + !!--------------------------------------------------------------------- + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_swm_init : surface wave-driven mixing' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + IF( .NOT.ln_wave .OR. & + & .NOT.ln_sdw ) CALL ctl_stop ( 'zdf_swm_init: ln_zdfswm=T but ln_wave and ln_sdw /= T') + ! + END SUBROUTINE zdf_swm_init + + !!====================================================================== +END MODULE zdfswm diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdftke.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdftke.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9746a7db468f471f8cb1b5382d97b059d4f621cf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zdftke.f90 @@ -0,0 +1,875 @@ + + + + + + + + + + + + + +MODULE zdftke + !!====================================================================== + !! *** MODULE zdftke *** + !! Ocean physics: vertical mixing coefficient computed from the tke + !! turbulent closure parameterization + !!===================================================================== + !! History : OPA ! 1991-03 (b. blanke) Original code + !! 7.0 ! 1991-11 (G. Madec) bug fix + !! 7.1 ! 1992-10 (G. Madec) new mixing length and eav + !! 7.2 ! 1993-03 (M. Guyon) symetrical conditions + !! 7.3 ! 1994-08 (G. Madec, M. Imbard) nn_pdl flag + !! 7.5 ! 1996-01 (G. Madec) s-coordinates + !! 8.0 ! 1997-07 (G. Madec) lbc + !! 8.1 ! 1999-01 (E. Stretta) new option for the mixing length + !! NEMO 1.0 ! 2002-06 (G. Madec) add tke_init routine + !! - ! 2004-10 (C. Ethe ) 1D configuration + !! 2.0 ! 2006-07 (S. Masson) distributed restart using iom + !! 3.0 ! 2008-05 (C. Ethe, G.Madec) : update TKE physics: + !! ! - tke penetration (wind steering) + !! ! - suface condition for tke & mixing length + !! ! - Langmuir cells + !! - ! 2008-05 (J.-M. Molines, G. Madec) 2D form of avtb + !! - ! 2008-06 (G. Madec) style + DOCTOR name for namelist parameters + !! - ! 2008-12 (G. Reffray) stable discretization of the production term + !! 3.2 ! 2009-06 (G. Madec, S. Masson) TKE restart compatible with key_cpl + !! ! + cleaning of the parameters + bugs correction + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability + !! 4.0 ! 2017-04 (G. Madec) remove CPP ddm key & avm at t-point only + !! - ! 2017-05 (G. Madec) add top/bottom friction as boundary condition + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) add wave coupling + ! ! following Couvelard et al., 2019 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_tke : update momentum and tracer Kz from a tke scheme + !! tke_tke : tke time stepping: update tke at now time step (en) + !! tke_avn : compute mixing length scale and deduce avm and avt + !! zdf_tke_init : initialization, namelist read, and parameters control + !! tke_rst : read/write tke restart in ocean restart file + !!---------------------------------------------------------------------- + USE oce ! ocean: dynamics and active tracers variables + USE phycst ! physical constants + USE dom_oce ! domain: ocean + USE domvvl ! domain: variable volume layer + USE sbc_oce ! surface boundary condition: ocean + USE zdfdrg ! vertical physics: top/bottom drag coef. + USE zdfmxl ! vertical physics: mixed layer + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE sbcwave ! Surface boundary waves + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_tke ! routine called in step module + PUBLIC zdf_tke_init ! routine called in opa module + PUBLIC tke_rst ! routine called in step module + + ! !!** Namelist namzdf_tke ** + LOGICAL :: ln_mxl0 ! mixing length scale surface value as function of wind stress or not + LOGICAL :: ln_mxhsw ! mixing length scale surface value as a fonction of wave height + INTEGER :: nn_mxlice ! type of scaling under sea-ice (=0/1/2/3) + REAL(wp) :: rn_mxlice ! ice thickness value when scaling under sea-ice + INTEGER :: nn_mxl ! type of mixing length (=0/1/2/3) + REAL(wp) :: rn_mxl0 ! surface min value of mixing length (kappa*z_o=0.4*0.1 m) [m] + INTEGER :: nn_pdl ! Prandtl number or not (ratio avt/avm) (=0/1) + REAL(wp) :: rn_ediff ! coefficient for avt: avt=rn_ediff*mxl*sqrt(e) + REAL(wp) :: rn_ediss ! coefficient of the Kolmogoroff dissipation + REAL(wp) :: rn_ebb ! coefficient of the surface input of tke + REAL(wp) :: rn_emin ! minimum value of tke [m2/s2] + REAL(wp) :: rn_emin0 ! surface minimum value of tke [m2/s2] + REAL(wp) :: rn_bshear ! background shear (>0) currently a numerical threshold (do not change it) + INTEGER :: nn_etau ! type of depth penetration of surface tke (=0/1/2/3) + INTEGER :: nn_htau ! type of tke profile of penetration (=0/1) + INTEGER :: nn_bc_surf! surface condition (0/1=Dir/Neum) ! Only applicable for wave coupling + INTEGER :: nn_bc_bot ! surface condition (0/1=Dir/Neum) ! Only applicable for wave coupling + REAL(wp) :: rn_efr ! fraction of TKE surface value which penetrates in the ocean + LOGICAL :: ln_lc ! Langmuir cells (LC) as a source term of TKE or not + REAL(wp) :: rn_lc ! coef to compute vertical velocity of Langmuir cells + INTEGER :: nn_eice ! attenutaion of langmuir & surface wave breaking under ice (=0/1/2/3) + + REAL(wp) :: ri_cri ! critic Richardson number (deduced from rn_ediff and rn_ediss values) + REAL(wp) :: rmxl_min ! minimum mixing length value (deduced from rn_ediff and rn_emin values) [m] + REAL(wp) :: rhftau_add = 1.e-3_wp ! add offset applied to HF part of taum (nn_etau=3) + REAL(wp) :: rhftau_scl = 1.0_wp ! scale factor applied to HF part of taum (nn_etau=3) + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htau ! depth of tke penetration (nn_htau) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dissl ! now mixing lenght of dissipation + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: apdlr ! now mixing lenght of dissipation + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdftke.F90 15071 2021-07-02 13:12:08Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_tke_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_tke_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( htau(jpi,jpj) , dissl(jpi,jpj,jpk) , apdlr(jpi,jpj,jpk) , STAT= zdf_tke_alloc ) + ! + CALL mpp_sum ( 'zdftke', zdf_tke_alloc ) + IF( zdf_tke_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_tke_alloc: failed to allocate arrays' ) + ! + END FUNCTION zdf_tke_alloc + + + SUBROUTINE zdf_tke( kt, Kbb, Kmm, p_sh2, p_avm, p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_tke *** + !! + !! ** Purpose : Compute the vertical eddy viscosity and diffusivity + !! coefficients using a turbulent closure scheme (TKE). + !! + !! ** Method : The time evolution of the turbulent kinetic energy (tke) + !! is computed from a prognostic equation : + !! d(en)/dt = avm (d(u)/dz)**2 ! shear production + !! + d( avm d(en)/dz )/dz ! diffusion of tke + !! + avt N^2 ! stratif. destruc. + !! - rn_ediss / emxl en**(2/3) ! Kolmogoroff dissipation + !! with the boundary conditions: + !! surface: en = max( rn_emin0, rn_ebb * taum ) + !! bottom : en = rn_emin + !! The associated critical Richardson number is: ri_cri = 2/(2+rn_ediss/rn_ediff) + !! + !! The now Turbulent kinetic energy is computed using the following + !! time stepping: implicit for vertical diffusion term, linearized semi + !! implicit for kolmogoroff dissipation term, and explicit forward for + !! both buoyancy and shear production terms. Therefore a tridiagonal + !! linear system is solved. Note that buoyancy and shear terms are + !! discretized in a energy conserving form (Bruchard 2002). + !! + !! The dissipative and mixing length scale are computed from en and + !! the stratification (see tke_avn) + !! + !! The now vertical eddy vicosity and diffusivity coefficients are + !! given by: + !! avm = max( avtb, rn_ediff * zmxlm * en^1/2 ) + !! avt = max( avmb, pdl * avm ) + !! eav = max( avmb, avm ) + !! where pdl, the inverse of the Prandtl number is 1 if nn_pdl=0 and + !! given by an empirical funtion of the localRichardson number if nn_pdl=1 + !! + !! ** Action : compute en (now turbulent kinetic energy) + !! update avt, avm (before vertical eddy coef.) + !! + !! References : Gaspar et al., JGR, 1990, + !! Blanke and Delecluse, JPO, 1991 + !! Mellor and Blumberg, JPO 2004 + !! Axell, JGR, 2002 + !! Bruchard OM 2002 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + !!---------------------------------------------------------------------- + ! + CALL tke_tke( Kbb, Kmm, p_sh2, p_avm, p_avt ) ! now tke (en) + ! + CALL tke_avn( Kbb, Kmm, p_avm, p_avt ) ! now avt, avm, dissl + ! + END SUBROUTINE zdf_tke + + + SUBROUTINE tke_tke( Kbb, Kmm, p_sh2, p_avm, p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tke_tke *** + !! + !! ** Purpose : Compute the now Turbulente Kinetic Energy (TKE) + !! + !! ** Method : - TKE surface boundary condition + !! - source term due to Langmuir cells (Axell JGR 2002) (ln_lc=T) + !! - source term due to shear (= Kz dz[Ub] * dz[Un] ) + !! - Now TKE : resolution of the TKE equation by inverting + !! a tridiagonal linear system by a "methode de chasse" + !! - increase TKE due to surface and internal wave breaking + !! NB: when sea-ice is present, both LC parameterization + !! and TKE penetration are turned off when the ice fraction + !! is smaller than 0.25 + !! + !! ** Action : - en : now turbulent kinetic energy) + !! --------------------------------------------------------------------- + USE zdf_oce , ONLY : en ! ocean vertical physics + !! + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) , INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp) :: zetop, zebot, zmsku, zmskv ! local scalars + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: zbbrau, zbbirau, zri ! local scalars + REAL(wp) :: zfact1, zfact2, zfact3 ! - - + REAL(wp) :: ztx2 , zty2 , zcof ! - - + REAL(wp) :: ztau , zdif ! - - + REAL(wp) :: zus , zwlc , zind ! - - + REAL(wp) :: zzd_up, zzd_lw ! - - + REAL(wp) :: ztaui, ztauj, z1_norm + INTEGER , DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: imlc + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zice_fra, zhlc, zus3, zWlc2 + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zpelc, zdiag, zd_up, zd_lw + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztmp ! for diags + !!-------------------------------------------------------------------- + ! + zbbrau = rn_ebb / rho0 ! Local constant initialisation + zbbirau = 3.75_wp / rho0 + zfact1 = -.5_wp * rn_Dt + zfact2 = 1.5_wp * rn_Dt * rn_ediss + zfact3 = 0.5_wp * rn_ediss + ! + zpelc(:,:,:) = 0._wp ! need to be initialised in case ln_lc is not used + ! + ! ice fraction considered for attenuation of langmuir & wave breaking + SELECT CASE ( nn_eice ) + CASE( 0 ) ; zice_fra(:,:) = 0._wp + CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) * 10._wp ) + CASE( 2 ) ; zice_fra(:,:) = fr_i(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) + CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) , 1._wp ) + END SELECT + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Surface/top/bottom boundary condition on tke + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) + zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) + zd_lw(ji,jj,1) = 1._wp + zd_up(ji,jj,1) = 0._wp + END DO ; END DO + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Bottom boundary condition on tke + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + ! en(bot) = (ebb0/rho0)*0.5*sqrt(u_botfr^2+v_botfr^2) (min value rn_emin) + ! where ebb0 does not includes surface wave enhancement (i.e. ebb0=3.75) + ! Note that stress averaged is done using an wet-only calculation of u and v at t-point like in zdfsh2 + ! + IF( .NOT.ln_drg_OFF ) THEN !== friction used as top/bottom boundary condition on TKE + ! + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! bottom friction + zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) + zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) + ! ! where 0.001875 = (rn_ebb0/rho0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) + zebot = - 0.001875_wp * rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 & + & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) + en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj) + END DO ; END DO + IF( ln_isfcav ) THEN + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! top friction + zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) + zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) + ! ! where 0.001875 = (rn_ebb0/rho0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) + zetop = - 0.001875_wp * rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 & + & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 ) + ! (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj) = 1 where ice shelves are present + en(ji,jj,mikt(ji,jj)) = en(ji,jj,1) * tmask(ji,jj,1) & + & + MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj) + END DO ; END DO + ENDIF + ! + ENDIF + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_lc ) THEN ! Langmuir circulation source term added to tke (Axell JGR 2002) + ! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! + ! !* Langmuir velocity scale + ! + IF ( cpl_sdrftx ) THEN ! Surface Stokes Drift available + ! ! Craik-Leibovich velocity scale Wlc = ( u* u_s )^1/2 with u* = (taum/rho0)^1/2 + ! ! associated kinetic energy : 1/2 (Wlc)^2 = u* u_s + ! ! more precisely, it is the dot product that must be used : + ! ! 1/2 (W_lc)^2 = MAX( u* u_s + v* v_s , 0 ) only the positive part +!!gm ! PS: currently we don't have neither the 2 stress components at t-point !nor the angle between u* and u_s +!!gm ! so we will overestimate the LC velocity.... !!gm I will do the work if !LC have an effect ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) +!!XC zWlc2(ji,jj) = 0.5_wp * SQRT( taum(ji,jj) * r1_rho0 * ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 ) ) + zWlc2(ji,jj) = 0.5_wp * ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 ) + END DO ; END DO +! +! Projection of Stokes drift in the wind stress direction +! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ztaui = 0.5_wp * ( utau(ji,jj) + utau(ji-1,jj) ) + ztauj = 0.5_wp * ( vtau(ji,jj) + vtau(ji,jj-1) ) + z1_norm = 1._wp / MAX( SQRT(ztaui*ztaui+ztauj*ztauj), 1.e-12 ) * tmask(ji,jj,1) + zWlc2(ji,jj) = 0.5_wp * z1_norm * ( MAX( ut0sd(ji,jj)*ztaui + vt0sd(ji,jj)*ztauj, 0._wp ) )**2 + END DO ; END DO + ELSE ! Surface Stokes drift deduced from surface stress + ! ! Wlc = u_s with u_s = 0.016*U_10m, the surface stokes drift (Axell 2002, Eq.44) + ! ! using |tau| = rho_air Cd |U_10m|^2 , it comes: + ! ! Wlc = 0.016 * [|tau|/(rho_air Cdrag) ]^1/2 and thus: + ! ! 1/2 Wlc^2 = 0.5 * 0.016 * 0.016 |tau| /( rho_air Cdrag ) + zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) ! to convert stress in 10m wind using a constant drag + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zWlc2(ji,jj) = zcof * taum(ji,jj) + END DO ; END DO + ! + ENDIF + ! + ! !* Depth of the LC circulation (Axell 2002, Eq.47) + ! !- LHS of Eq.47 + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zpelc(ji,jj,1) = MAX( rn2b(ji,jj,1), 0._wp ) * (gdepw_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))) * (e3w_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + DO jk = 2, jpk ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zpelc(ji,jj,jk) = zpelc(ji,jj,jk-1) + & + & MAX( rn2b(ji,jj,jk), 0._wp ) * (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) * (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO ; END DO + ! + ! !- compare LHS to RHS of Eq.47 + imlc(:,:) = mbkt(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) + 1 ! Initialization to the number of w ocean point (=2 over land) + DO jk = jpkm1, 2, -1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + IF( zpelc(ji,jj,jk) > zWlc2(ji,jj) ) imlc(ji,jj) = jk + END DO ; END DO ; END DO + ! ! finite LC depth + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zhlc(ji,jj) = (gdepw_0(ji,jj,imlc(ji,jj))*(1._wp+r3t(ji,jj,Kmm))) + END DO ; END DO + ! + zcof = 0.016 / SQRT( zrhoa * zcdrag ) + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zus = SQRT( 2. * zWlc2(ji,jj) ) ! Stokes drift + zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok + END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) !* TKE Langmuir circulation source term added to en + IF ( zus3(ji,jj) /= 0._wp ) THEN + IF ( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN + ! ! vertical velocity due to LC + zwlc = rn_lc * SIN( rpi * (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / zhlc(ji,jj) ) + ! ! TKE Langmuir circulation source term + en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zus3(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) + ENDIF + ENDIF + END DO ; END DO ; END DO + ! + ENDIF + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Now Turbulent kinetic energy (output in en) + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Resolution of a tridiagonal linear system by a "methode de chasse" + ! ! computation from level 2 to jpkm1 (e(1) already computed and e(jpk)=0 ). + ! ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal + ! + IF( nn_pdl == 1 ) THEN !* Prandtl number = F( Ri ) + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ! ! local Richardson number + IF (rn2b(ji,jj,jk) <= 0.0_wp) then + zri = 0.0_wp + ELSE + zri = rn2b(ji,jj,jk) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear ) + ENDIF + ! ! inverse of Prandtl number + apdlr(ji,jj,jk) = MAX( 0.1_wp, ri_cri / MAX( ri_cri , zri ) ) + END DO ; END DO ; END DO + ENDIF + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) !* Matrix and right hand side in en + zcof = zfact1 * tmask(ji,jj,jk) + ! ! A minimum of 2.e-5 m2/s is imposed on TKE vertical + ! ! eddy coefficient (ensure numerical stability) + zzd_up = zcof * MAX( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) , 2.e-5_wp ) & ! upper diagonal + & / ( (e3t_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk ))) * (e3w_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm))) ) + zzd_lw = zcof * MAX( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) , 2.e-5_wp ) & ! lower diagonal + & / ( (e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1))) * (e3w_0(ji,jj,jk )*(1._wp+r3t(ji,jj,Kmm))) ) + ! + zd_up(ji,jj,jk) = zzd_up ! Matrix (zdiag, zd_up, zd_lw) + zd_lw(ji,jj,jk) = zzd_lw + zdiag(ji,jj,jk) = 1._wp - zzd_lw - zzd_up + zfact2 * dissl(ji,jj,jk) * wmask(ji,jj,jk) + ! + ! ! right hand side in en + en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * ( p_sh2(ji,jj,jk) & ! shear + & - p_avt(ji,jj,jk) * rn2(ji,jj,jk) & ! stratification + & + zfact3 * dissl(ji,jj,jk) * en(ji,jj,jk) & ! dissipation + & ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Surface boundary condition on tke if + ! ! coupling with waves + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + IF ( cpl_phioc .and. ln_phioc ) THEN + SELECT CASE (nn_bc_surf) ! Boundary Condition using surface TKE flux from waves + + CASE ( 0 ) ! Dirichlet BC + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! en(1) = rn_ebb taum / rho0 (min value rn_emin0) + IF ( phioc(ji,jj) < 0 ) phioc(ji,jj) = 0._wp + en(ji,jj,1) = MAX( rn_emin0, .5 * ( 15.8 * phioc(ji,jj) / rho0 )**(2./3.) ) * tmask(ji,jj,1) + zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) ! choose to keep coherence with former estimation of + END DO ; END DO + + CASE ( 1 ) ! Neumann BC + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + IF ( phioc(ji,jj) < 0 ) phioc(ji,jj) = 0._wp + en(ji,jj,2) = en(ji,jj,2) + ( rn_Dt * phioc(ji,jj) / rho0 ) /(e3w_0(ji,jj,2)*(1._wp+r3t(ji,jj,Kmm))) + en(ji,jj,1) = en(ji,jj,2) + (2 * (e3t_0(ji,jj,1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,1))) * phioc(ji,jj)/rho0) / ( p_avm(ji,jj,1) + p_avm(ji,jj,2) ) + zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) + zdiag(ji,jj,1) = 1._wp + zd_lw(ji,jj,2) = 0._wp + END DO ; END DO + + END SELECT + + ENDIF + ! + ! !* Matrix inversion from level 2 (tke prescribed at level 1) + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) + END DO ; END DO ; END DO +!XC : commented to allow for neumann boundary condition +! DO jj = ntsj-( 0), ntej+( 0 ) ; DO ji = ntsi-( 0), ntei+( 0) +! zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke +! END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) + END DO ; END DO ; END DO + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) + END DO ; END DO + DO jk = jpk-2, 2, -1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) + END DO ; END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) ! set the minimum value of tke + en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! Kolmogorov energy of dissipation (W/kg) + ! ediss = Ce*sqrt(en)/L*en + ! dissl = sqrt(en)/L + IF( iom_use('ediss_k') ) THEN + ALLOCATE( ztmp(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) ) + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ztmp(ji,jj,jk) = zfact3 * dissl(ji,jj,jk) * en(ji,jj,jk) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + ztmp(ji,jj,jpk) = 0._wp + END DO ; END DO + CALL iom_put( 'ediss_k', ztmp ) + DEALLOCATE( ztmp ) + ENDIF + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! TKE due to surface and internal wave breaking + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!!gm BUG : in the exp remove the depth of ssh !!! +!!gm i.e. use gde3w in argument ((gdepw_0(:,:,:)*(1._wp+r3t(:,:,Kmm)))) + ! + ! penetration is partly switched off below sea-ice if nn_eice/=0 + ! + IF( nn_etau == 1 ) THEN !* penetration below the mixed layer (rn_efr fraction) + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -(gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / htau(ji,jj) ) & + & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) + END DO ; END DO ; END DO + ELSEIF( nn_etau == 2 ) THEN !* act only at the base of the mixed layer (jk=nmln) (rn_efr fraction) + DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1 )*nthb), ntej+( nn_hls-1 -( nn_hls-1 + nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + jk = nmln(ji,jj) + en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -(gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / htau(ji,jj) ) & + & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) + END DO ; END DO + ELSEIF( nn_etau == 3 ) THEN !* penetration belox the mixed layer (HF variability) + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + ztx2 = utau(ji-1,jj ) + utau(ji,jj) + zty2 = vtau(ji ,jj-1) + vtau(ji,jj) + ztau = 0.5_wp * SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1) ! module of the mean stress + zdif = taum(ji,jj) - ztau ! mean of modulus - modulus of the mean + zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... + en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -(gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) / htau(ji,jj) ) & + & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) + END DO ; END DO ; END DO + ENDIF + ! + END SUBROUTINE tke_tke + + + SUBROUTINE tke_avn( Kbb, Kmm, p_avm, p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tke_avn *** + !! + !! ** Purpose : Compute the vertical eddy viscosity and diffusivity + !! + !! ** Method : At this stage, en, the now TKE, is known (computed in + !! the tke_tke routine). First, the now mixing lenth is + !! computed from en and the strafification (N^2), then the mixings + !! coefficients are computed. + !! - Mixing length : a first evaluation of the mixing lengh + !! scales is: + !! mxl = sqrt(2*en) / N + !! where N is the brunt-vaisala frequency, with a minimum value set + !! to rmxl_min (rn_mxl0) in the interior (surface) ocean. + !! The mixing and dissipative length scale are bound as follow : + !! nn_mxl=0 : mxl bounded by the distance to surface and bottom. + !! zmxld = zmxlm = mxl + !! nn_mxl=1 : mxl bounded by the e3w and zmxld = zmxlm = mxl + !! nn_mxl=2 : mxl bounded such that the vertical derivative of mxl is + !! less than 1 (|d/dz(mxl)|<1) and zmxld = zmxlm = mxl + !! nn_mxl=3 : mxl is bounded from the surface to the bottom usings + !! |d/dz(xml)|<1 to obtain lup, and from the bottom to + !! the surface to obtain ldown. the resulting length + !! scales are: + !! zmxld = sqrt( lup * ldown ) + !! zmxlm = min ( lup , ldown ) + !! - Vertical eddy viscosity and diffusivity: + !! avm = max( avtb, rn_ediff * zmxlm * en^1/2 ) + !! avt = max( avmb, pdlr * avm ) + !! with pdlr=1 if nn_pdl=0, pdlr=1/pdl=F(Ri) otherwise. + !! + !! ** Action : - avt, avm : now vertical eddy diffusivity and viscosity (w-point) + !!---------------------------------------------------------------------- + USE zdf_oce , ONLY : en, avtb, avmb, avtb_2d ! ocean vertical physics + !! + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zrn2, zraug, zcoef, zav ! local scalars + REAL(wp) :: zdku, zdkv, zsqen ! - - + REAL(wp) :: zemxl, zemlm, zemlp, zmaxice ! - - + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),jpk) :: zmxlm, zmxld ! 3D workspace + !!-------------------------------------------------------------------- + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Mixing length + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + ! !* Buoyancy length scale: l=sqrt(2*e/n**2) + ! + ! initialisation of interior minimum value (avoid a 2d loop with mikt) + zmxlm(:,:,:) = rmxl_min + zmxld(:,:,:) = rmxl_min + ! + IF(ln_sdw .AND. ln_mxhsw) THEN + zmxlm(:,:,1)= vkarmn * MAX ( 1.6 * hsw(:,:) , 0.02 ) ! surface mixing length = F(wave height) + ! from terray et al 1999 and mellor and blumberg 2004 it should be 0.85 and not 1.6 + zcoef = vkarmn * ( (rn_ediff*rn_ediss)**0.25 ) / rn_ediff + zmxlm(:,:,1)= zcoef * MAX ( 1.6 * hsw(:,:) , 0.02 ) ! surface mixing length = F(wave height) + ELSE + ! + IF( ln_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rho0*g) + ! + zraug = vkarmn * 2.e5_wp / ( rho0 * grav ) + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! No sea-ice + zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) + END DO ; END DO + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) + END DO ; END DO + ! + ELSE + zmxlm(:,:,1) = rn_mxl0 + ENDIF + ENDIF + ! + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zrn2 = MAX( rn2(ji,jj,jk), rsmall ) + zmxlm(ji,jj,jk) = MAX( rmxl_min, SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) ) + END DO ; END DO ; END DO + ! + ! !* Physical limits for the mixing length + ! + zmxld(:,:, 1 ) = zmxlm(:,:,1) ! surface set to the minimum value + zmxld(:,:,jpk) = rmxl_min ! last level set to the minimum value + ! + SELECT CASE ( nn_mxl ) + ! + !!gm Not sure of that coding for ISF.... + ! where wmask = 0 set zmxlm == (e3w_0(:,:,:)*(1._wp+r3t(:,:,Kmm))) + CASE ( 0 ) ! bounded by the distance to surface and bottom + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zemxl = MIN( (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) - (gdepw_0(ji,jj,mikt(ji,jj))*(1._wp+r3t(ji,jj,Kmm))), zmxlm(ji,jj,jk), & + & (gdepw_0(ji,jj,mbkt(ji,jj)+1)*(1._wp+r3t(ji,jj,Kmm))) - (gdepw_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) + ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) + zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) & + & + MIN( zmxlm(ji,jj,jk) , (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) * (1 - wmask(ji,jj,jk)) + zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) & + & + MIN( zmxlm(ji,jj,jk) , (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))) ) * (1 - wmask(ji,jj,jk)) + END DO ; END DO ; END DO + ! + CASE ( 1 ) ! bounded by the vertical scale factor + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zemxl = MIN( (e3w_0(ji,jj,jk)*(1._wp+r3t(ji,jj,Kmm))), zmxlm(ji,jj,jk) ) + zmxlm(ji,jj,jk) = zemxl + zmxld(ji,jj,jk) = zemxl + END DO ; END DO ; END DO + ! + CASE ( 2 ) ! |dk[xml]| bounded by e3t : + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! from the surface to the bottom : + zmxlm(ji,jj,jk) = & + & MIN( zmxlm(ji,jj,jk-1) + (e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1))), zmxlm(ji,jj,jk) ) + END DO ; END DO ; END DO + DO jk = jpkm1, 2, -1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! from the bottom to the surface : + zemxl = MIN( zmxlm(ji,jj,jk+1) + (e3t_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk+1))), zmxlm(ji,jj,jk) ) + zmxlm(ji,jj,jk) = zemxl + zmxld(ji,jj,jk) = zemxl + END DO ; END DO ; END DO + ! + CASE ( 3 ) ! lup and ldown, |dk[xml]| bounded by e3t : + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! from the surface to the bottom : lup + zmxld(ji,jj,jk) = & + & MIN( zmxld(ji,jj,jk-1) + (e3t_0(ji,jj,jk-1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk-1))), zmxlm(ji,jj,jk) ) + END DO ; END DO ; END DO + DO jk = jpkm1, 2, -1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! from the bottom to the surface : ldown + zmxlm(ji,jj,jk) = & + & MIN( zmxlm(ji,jj,jk+1) + (e3t_0(ji,jj,jk+1)*(1._wp+r3t(ji,jj,Kmm)*tmask(ji,jj,jk+1))), zmxlm(ji,jj,jk) ) + END DO ; END DO ; END DO + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + zemlm = MIN ( zmxld(ji,jj,jk), zmxlm(ji,jj,jk) ) + zemlp = SQRT( zmxld(ji,jj,jk) * zmxlm(ji,jj,jk) ) + zmxlm(ji,jj,jk) = zemlm + zmxld(ji,jj,jk) = zemlp + END DO ; END DO ; END DO + ! + END SELECT + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Vertical eddy viscosity and diffusivity (avm and avt) + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + DO jk = 1, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) !* vertical eddy viscosity & diffivity at w-points + zsqen = SQRT( en(ji,jj,jk) ) + zav = rn_ediff * zmxlm(ji,jj,jk) * zsqen + p_avm(ji,jj,jk) = MAX( zav, avmb(jk) ) * wmask(ji,jj,jk) + p_avt(ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) + dissl(ji,jj,jk) = zsqen / zmxld(ji,jj,jk) + END DO ; END DO ; END DO + ! + ! + IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt + DO jk = 2, jpkm1 ; DO jj = ntsj-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthb), ntej+( nn_hls-1-( nn_hls-1+ nn_hls-1)*ntht) ; DO ji = ntsi-( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthl), ntei+( nn_hls-1-( nn_hls-1+ nn_hls-1)*nthr) + p_avt(ji,jj,jk) = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) + END DO ; END DO ; END DO + ENDIF + ! + ! IF(sn_cfctl%l_prtctl) THEN + !CALL prt_ctl( tab3d_1=en , clinfo1=' tke - e: ', tab3d_2=p_avt, clinfo2=' t: ' ) + !CALL prt_ctl( tab3d_1=p_avm, clinfo1=' tke - m: ' ) + ! ENDIF + ! + END SUBROUTINE tke_avn + + + SUBROUTINE zdf_tke_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_tke_init *** + !! + !! ** Purpose : Initialization of the vertical eddy diffivity and + !! viscosity when using a tke turbulent closure scheme + !! + !! ** Method : Read the namzdf_tke namelist and check the parameters + !! called at the first timestep (nit000) + !! + !! ** input : Namlist namzdf_tke + !! + !! ** Action : Increase by 1 the nstop flag is setting problem encounter + !!---------------------------------------------------------------------- + USE zdf_oce , ONLY : ln_zdfiwm ! Internal Wave Mixing flag + !! + INTEGER, INTENT(in) :: Kmm ! time level index + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ios + !! + NAMELIST/namzdf_tke/ rn_ediff, rn_ediss , rn_ebb , rn_emin , & + & rn_emin0, rn_bshear, nn_mxl , ln_mxl0 , & + & rn_mxl0 , nn_mxlice, rn_mxlice, & + & nn_pdl , ln_lc , rn_lc , & + & nn_etau , nn_htau , rn_efr , nn_eice , & + & nn_bc_surf, nn_bc_bot, ln_mxhsw + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namzdf_tke, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tke in reference namelist' ) + + READ ( numnam_cfg, namzdf_tke, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_tke in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_tke ) + ! + ri_cri = 2._wp / ( 2._wp + rn_ediss / rn_ediff ) ! resulting critical Richardson number + ! + IF(lwp) THEN !* Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_tke_init : tke turbulent closure scheme - initialisation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_tke : set tke mixing parameters' + WRITE(numout,*) ' coef. to compute avt rn_ediff = ', rn_ediff + WRITE(numout,*) ' Kolmogoroff dissipation coef. rn_ediss = ', rn_ediss + WRITE(numout,*) ' tke surface input coef. rn_ebb = ', rn_ebb + WRITE(numout,*) ' minimum value of tke rn_emin = ', rn_emin + WRITE(numout,*) ' surface minimum value of tke rn_emin0 = ', rn_emin0 + WRITE(numout,*) ' prandl number flag nn_pdl = ', nn_pdl + WRITE(numout,*) ' background shear (>0) rn_bshear = ', rn_bshear + WRITE(numout,*) ' mixing length type nn_mxl = ', nn_mxl + WRITE(numout,*) ' surface mixing length = F(stress) or not ln_mxl0 = ', ln_mxl0 + WRITE(numout,*) ' surface mixing length minimum value rn_mxl0 = ', rn_mxl0 + IF( ln_mxl0 ) THEN + WRITE(numout,*) ' type of scaling under sea-ice nn_mxlice = ', nn_mxlice + IF( nn_mxlice == 1 ) & + WRITE(numout,*) ' ice thickness when scaling under sea-ice rn_mxlice = ', rn_mxlice + SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice + CASE( 0 ) ; WRITE(numout,*) ' ==>>> No scaling under sea-ice' + CASE( 1 ) ; WRITE(numout,*) ' ==>>> scaling with constant sea-ice thickness' + CASE( 2 ) ; WRITE(numout,*) ' ==>>> scaling with mean sea-ice thickness' + CASE( 3 ) ; WRITE(numout,*) ' ==>>> scaling with max sea-ice thickness' + CASE DEFAULT + CALL ctl_stop( 'zdf_tke_init: wrong value for nn_mxlice, should be 0,1,2,3 or 4') + END SELECT + ENDIF + WRITE(numout,*) ' Langmuir cells parametrization ln_lc = ', ln_lc + WRITE(numout,*) ' coef to compute vertical velocity of LC rn_lc = ', rn_lc + IF ( cpl_phioc .and. ln_phioc ) THEN + SELECT CASE( nn_bc_surf) ! Type of scaling under sea-ice + CASE( 0 ) ; WRITE(numout,*) ' nn_bc_surf=0 ==>>> DIRICHLET SBC using surface TKE flux from waves' + CASE( 1 ) ; WRITE(numout,*) ' nn_bc_surf=1 ==>>> NEUMANN SBC using surface TKE flux from waves' + END SELECT + ENDIF + WRITE(numout,*) ' test param. to add tke induced by wind nn_etau = ', nn_etau + WRITE(numout,*) ' type of tke penetration profile nn_htau = ', nn_htau + WRITE(numout,*) ' fraction of TKE that penetrates rn_efr = ', rn_efr + WRITE(numout,*) ' langmuir & surface wave breaking under ice nn_eice = ', nn_eice + SELECT CASE( nn_eice ) + CASE( 0 ) ; WRITE(numout,*) ' ==>>> no impact of ice cover on langmuir & surface wave breaking' + CASE( 1 ) ; WRITE(numout,*) ' ==>>> weigthed by 1-TANH( fr_i(:,:) * 10 )' + CASE( 2 ) ; WRITE(numout,*) ' ==>>> weighted by 1-fr_i(:,:)' + CASE( 3 ) ; WRITE(numout,*) ' ==>>> weighted by 1-MIN( 1, 4 * fr_i(:,:) )' + CASE DEFAULT + CALL ctl_stop( 'zdf_tke_init: wrong value for nn_eice, should be 0,1,2, or 3') + END SELECT + WRITE(numout,*) + WRITE(numout,*) ' ==>>> critical Richardson nb with your parameters ri_cri = ', ri_cri + WRITE(numout,*) + ENDIF + ! + IF( ln_zdfiwm ) THEN ! Internal wave-driven mixing + rn_emin = 1.e-10_wp ! specific values of rn_emin & rmxl_min are used + rmxl_min = 1.e-03_wp ! associated avt minimum = molecular salt diffusivity (10^-9 m2/s) + IF(lwp) WRITE(numout,*) ' ==>>> Internal wave-driven mixing case: force rn_emin = 1.e-10 and rmxl_min = 1.e-3' + ELSE ! standard case : associated avt minimum = molecular viscosity (10^-6 m2/s) + rmxl_min = 1.e-6_wp / ( rn_ediff * SQRT( rn_emin ) ) ! resulting minimum length to recover molecular viscosity + IF(lwp) WRITE(numout,*) ' ==>>> minimum mixing length with your parameters rmxl_min = ', rmxl_min + ENDIF + ! + ! ! allocate tke arrays + IF( zdf_tke_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_tke_init : unable to allocate arrays' ) + ! + ! !* Check of some namelist values + IF( nn_mxl < 0 .OR. nn_mxl > 3 ) CALL ctl_stop( 'bad flag: nn_mxl is 0, 1, 2 or 3' ) + IF( nn_pdl < 0 .OR. nn_pdl > 1 ) CALL ctl_stop( 'bad flag: nn_pdl is 0 or 1' ) + IF( nn_htau < 0 .OR. nn_htau > 1 ) CALL ctl_stop( 'bad flag: nn_htau is 0 or 1' ) + IF( nn_etau == 3 .AND. .NOT. ln_cpl ) CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' ) + ! + IF( ln_mxl0 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> use a surface mixing length = F(stress) : set rn_mxl0 = rmxl_min' + rn_mxl0 = rmxl_min + ENDIF + ! !* depth of penetration of surface tke + IF( nn_etau /= 0 ) THEN + SELECT CASE( nn_htau ) ! Choice of the depth of penetration + CASE( 0 ) ! constant depth penetration (here 10 meters) + htau(:,:) = 10._wp + CASE( 1 ) ! F(latitude) : 0.5m to 30m poleward of 40 degrees + htau(:,:) = MAX( 0.5_wp, MIN( 30._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(:,:) ) ) ) ) + END SELECT + ENDIF + ! !* read or initialize all required files + CALL tke_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, dissl) + ! + END SUBROUTINE zdf_tke_init + + + SUBROUTINE tke_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE tke_rst *** + !! + !! ** Purpose : Read or write TKE file (en) in restart file + !! + !! ** Method : use of IOM library + !! if the restart does not contain TKE, en is either + !! set to rn_emin or recomputed + !!---------------------------------------------------------------------- + USE zdf_oce , ONLY : en, avt_k, avm_k ! ocean vertical physics + !! + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + INTEGER :: jit, jk ! dummy loop indices + INTEGER :: id1, id2, id3, id4 ! local integers + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + ! ! --------------- + IF( ln_rstart ) THEN !* Read the restart file + id1 = iom_varid( numror, 'en' , ldstop = .FALSE. ) + id2 = iom_varid( numror, 'avt_k', ldstop = .FALSE. ) + id3 = iom_varid( numror, 'avm_k', ldstop = .FALSE. ) + id4 = iom_varid( numror, 'dissl', ldstop = .FALSE. ) + ! + IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! fields exist + CALL iom_get( numror, jpdom_auto, 'en' , en ) + CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k ) + CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k ) + CALL iom_get( numror, jpdom_auto, 'dissl', dissl ) + ELSE ! start TKE from rest + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> previous run without TKE scheme, set en to background values' + en (:,:,:) = rn_emin * wmask(:,:,:) + dissl(:,:,:) = 1.e-12_wp + ! avt_k, avm_k already set to the background value in zdf_phy_init + ENDIF + ELSE !* Start from rest + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> start from rest: set en to the background value' + en (:,:,:) = rn_emin * wmask(:,:,:) + dissl(:,:,:) = 1.e-12_wp + ! avt_k, avm_k already set to the background value in zdf_phy_init + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) '---- tke_rst ----' + CALL iom_rstput( kt, nitrst, numrow, 'en' , en ) + CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k ) + CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k ) + CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl ) + ! + ENDIF + ! + END SUBROUTINE tke_rst + + !!====================================================================== +END MODULE zdftke diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zpshde.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zpshde.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8c9f45c173264e67b56d66240e08ccba4a6ba456 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/nemo/zpshde.f90 @@ -0,0 +1,521 @@ + + + + + + + + + + + + + +MODULE zpshde + !!====================================================================== + !! *** MODULE zpshde *** + !! z-coordinate + partial step : Horizontal Derivative at ocean bottom level + !!====================================================================== + !! History : OPA ! 2002-04 (A. Bozec) Original code + !! NEMO 1.0 ! 2002-08 (G. Madec E. Durand) Optimization and Free form + !! - ! 2004-03 (C. Ethe) adapted for passive tracers + !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + !! 3.6 ! 2014-11 (P. Mathiot) Add zps_hde_isf (needed to open a cavity) + !!====================================================================== + + !!---------------------------------------------------------------------- + !! zps_hde : Horizontal DErivative of T, S and rd at the last + !! ocean level (Z-coord. with Partial Steps) + !!---------------------------------------------------------------------- + USE oce ! ocean: dynamics and tracers variables + USE dom_oce ! domain: ocean variables + USE domutl, ONLY : is_tile + USE phycst ! physical constants + USE eosbn2 ! ocean equation of state + USE in_out_manager ! I/O manager + USE lbclnk ! lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC zps_hde ! routine called by step.F90 + PUBLIC zps_hde_isf ! routine called by step.F90 + + !! * Substitutions + + + + +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +!!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zpshde.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zps_hde( kt, Kmm, kjpt, pta, pgtu, pgtv, & + & prd, pgru, pgrv ) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(:,:,:) , INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + ! + INTEGER :: itrd, itgr + !! + IF( PRESENT(prd) ) THEN ; itrd = is_tile(prd) ; ELSE ; itrd = 0 ; ENDIF + IF( PRESENT(pgru) ) THEN ; itgr = is_tile(pgru) ; ELSE ; itgr = 0 ; ENDIF + + CALL zps_hde_t( kt, Kmm, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), & + & prd, itrd, pgru, pgrv, itgr ) + END SUBROUTINE zps_hde + + + SUBROUTINE zps_hde_t( kt, Kmm, kjpt, pta, ktta, pgtu, pgtv, ktgt, & + & prd, ktrd, pgru, pgrv, ktgr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zps_hde *** + !! + !! ** Purpose : Compute the horizontal derivative of T, S and rho + !! at u- and v-points with a linear interpolation for z-coordinate + !! with partial steps. + !! + !! ** Method : In z-coord with partial steps, scale factors on last + !! levels are different for each grid point, so that T, S and rd + !! points are not at the same depth as in z-coord. To have horizontal + !! gradients again, we interpolate T and S at the good depth : + !! Linear interpolation of T, S + !! Computation of di(tb) and dj(tb) by vertical interpolation: + !! di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~ + !! dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~ + !! This formulation computes the two cases: + !! CASE 1 CASE 2 + !! k-1 ___ ___________ k-1 ___ ___________ + !! Ti T~ T~ Ti+1 + !! _____ _____ + !! k | |Ti+1 k Ti | | + !! | |____ ____| | + !! ___ | | | ___ | | | + !! + !! case 1-> (e3w_0(i+1,:,:)*(1._wp+r3t(i+1,:,Kmm))) >= (e3w_0(i,:,:)*(1._wp+r3t(i,:,Kmm))) ( and (e3w_0(:,j+1,:)*(1._wp+r3t(:,j+1,Kmm))) >= (e3w_0(:,j,:)*(1._wp+r3t(:,j,Kmm))) ) then + !! t~ = t(i+1,j ,k) + ((e3w_0(i+1,j,k)*(1._wp+r3t(i+1,j,Kmm))) - (e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm)))) * dk(Ti+1)/(e3w_0(i+1,j,k)*(1._wp+r3t(i+1,j,Kmm))) + !! ( t~ = t(i ,j+1,k) + ((e3w_0(i,j+1,k)*(1._wp+r3t(i,j+1,Kmm))) - (e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm)))) * dk(Tj+1)/(e3w_0(i,j+1,k)*(1._wp+r3t(i,j+1,Kmm))) ) + !! or + !! case 2-> (e3w_0(i+1,:,:)*(1._wp+r3t(i+1,:,Kmm))) <= (e3w_0(i,:,:)*(1._wp+r3t(i,:,Kmm))) ( and (e3w_0(:,j+1,:)*(1._wp+r3t(:,j+1,Kmm))) <= (e3w_0(:,j,:)*(1._wp+r3t(:,j,Kmm))) ) then + !! t~ = t(i,j,k) + ((e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) - (e3w_0(i+1,j,k)*(1._wp+r3t(i+1,j,Kmm)))) * dk(Ti)/(e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) + !! ( t~ = t(i,j,k) + ((e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) - (e3w_0(i,j+1,k)*(1._wp+r3t(i,j+1,Kmm)))) * dk(Tj)/(e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) ) + !! Idem for di(s) and dj(s) + !! + !! For rho, we call eos which will compute rd~(t~,s~) at the right + !! depth zh from interpolated T and S for the different formulations + !! of the equation of state (eos). + !! Gradient formulation for rho : + !! di(rho) = rd~ - rd(i,j,k) or rd(i+1,j,k) - rd~ + !! + !! ** Action : compute for top interfaces + !! - pgtu, pgtv: horizontal gradient of tracer at u- & v-points + !! - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: ktta, ktgt, ktrd, ktgr + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktta+1:,(ntsj-nn_hls-1)*ktta+1:,:,:), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktgt+1:,(ntsj-nn_hls-1)*ktgt+1: ,:), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktrd+1:,(ntsj-nn_hls-1)*ktrd+1:,: ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktgr+1:,(ntsj-nn_hls-1)*ktgr+1: ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + ! + INTEGER :: ji, jj, jn ! Dummy loop indices + INTEGER :: iku, ikv, ikum1, ikvm1 ! partial step level (ocean bottom level) at u- and v-points + REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! local scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),kjpt) :: zti, ztj ! + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'zps_hde') + ! + pgtu(:,:,:) = 0._wp ; zti (:,:,:) = 0._wp ; zhi (:,:) = 0._wp + pgtv(:,:,:) = 0._wp ; ztj (:,:,:) = 0._wp ; zhj (:,:) = 0._wp + ! + DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) ! Gradient of density at the last level + iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points + ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1 +!!gm BUG ? when applied to before fields, (e3w_0(:,:,k)*(1._wp+r3t(:,:,Kbb))) should be used.... + ze3wu = (e3w_0(ji+1,jj ,iku)*(1._wp+r3t(ji+1,jj ,Kmm))) - (e3w_0(ji,jj,iku)*(1._wp+r3t(ji,jj,Kmm))) + ze3wv = (e3w_0(ji ,jj+1,ikv)*(1._wp+r3t(ji ,jj+1,Kmm))) - (e3w_0(ji,jj,ikv)*(1._wp+r3t(ji,jj,Kmm))) + ! + ! i- direction + IF( ze3wu >= 0._wp ) THEN ! case 1 + zmaxu = ze3wu / (e3w_0(ji+1,jj,iku)*(1._wp+r3t(ji+1,jj,Kmm))) + ! interpolated values of tracers + zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) + ! gradient of tracers + pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) + ELSE ! case 2 + zmaxu = -ze3wu / (e3w_0(ji,jj,iku)*(1._wp+r3t(ji,jj,Kmm))) + ! interpolated values of tracers + zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) + ! gradient of tracers + pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) + ENDIF + ! + ! j- direction + IF( ze3wv >= 0._wp ) THEN ! case 1 + zmaxv = ze3wv / (e3w_0(ji,jj+1,ikv)*(1._wp+r3t(ji,jj+1,Kmm))) + ! interpolated values of tracers + ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) + ! gradient of tracers + pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) + ELSE ! case 2 + zmaxv = -ze3wv / (e3w_0(ji,jj,ikv)*(1._wp+r3t(ji,jj,Kmm))) + ! interpolated values of tracers + ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) + ! gradient of tracers + pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) + ENDIF + END DO ; END DO + END DO + ! + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + ! + IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) + pgru(:,:) = 0._wp + pgrv(:,:) = 0._wp ! depth of the partial step level + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = (e3w_0(ji+1,jj ,iku)*(1._wp+r3t(ji+1,jj ,Kmm))) - (e3w_0(ji,jj,iku)*(1._wp+r3t(ji,jj,Kmm))) + ze3wv = (e3w_0(ji ,jj+1,ikv)*(1._wp+r3t(ji ,jj+1,Kmm))) - (e3w_0(ji,jj,ikv)*(1._wp+r3t(ji,jj,Kmm))) + IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = (gdept_0(ji ,jj,iku)*(1._wp+r3t(ji ,jj,Kmm))) ! i-direction: case 1 + ELSE ; zhi(ji,jj) = (gdept_0(ji+1,jj,iku)*(1._wp+r3t(ji+1,jj,Kmm))) ! - - case 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = (gdept_0(ji,jj ,ikv)*(1._wp+r3t(ji,jj ,Kmm))) ! j-direction: case 1 + ELSE ; zhj(ji,jj) = (gdept_0(ji,jj+1,ikv)*(1._wp+r3t(ji,jj+1,Kmm))) ! - - case 2 + ENDIF + END DO ; END DO + ! + CALL eos( zti, zhi, zri ) ! interpolated density from zti, ztj + CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) ! Gradient of density at the last level + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = (e3w_0(ji+1,jj ,iku)*(1._wp+r3t(ji+1,jj ,Kmm))) - (e3w_0(ji,jj,iku)*(1._wp+r3t(ji,jj,Kmm))) + ze3wv = (e3w_0(ji ,jj+1,ikv)*(1._wp+r3t(ji ,jj+1,Kmm))) - (e3w_0(ji,jj,ikv)*(1._wp+r3t(ji,jj,Kmm))) + IF( ze3wu >= 0._wp ) THEN ; pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji ,jj ) - prd(ji,jj,iku) ) ! i: 1 + ELSE ; pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj ) ) ! i: 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1 + ELSE ; pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj ) ) ! j: 2 + ENDIF + END DO ; END DO + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + IF( ln_timing ) CALL timing_stop( 'zps_hde') + ! + END SUBROUTINE zps_hde_t + + + SUBROUTINE zps_hde_isf( kt, Kmm, kjpt, pta, pgtu, pgtv, pgtui, pgtvi, & + & prd, pgru, pgrv, pgrui, pgrvi ) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) + REAL(wp), DIMENSION(:,:,:) , INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) + ! + INTEGER :: itrd, itgr, itgri + !! + IF( PRESENT(prd) ) THEN ; itrd = is_tile(prd) ; ELSE ; itrd = 0 ; ENDIF + IF( PRESENT(pgru) ) THEN ; itgr = is_tile(pgru) ; ELSE ; itgr = 0 ; ENDIF + IF( PRESENT(pgrui) ) THEN ; itgri = is_tile(pgrui) ; ELSE ; itgri = 0 ; ENDIF + + CALL zps_hde_isf_t( kt, Kmm, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), pgtui, pgtvi, is_tile(pgtui), & + & prd, itrd, pgru, pgrv, itgr, pgrui, pgrvi, itgri ) + END SUBROUTINE zps_hde_isf + + + SUBROUTINE zps_hde_isf_t( kt, Kmm, kjpt, pta, ktta, pgtu, pgtv, ktgt, pgtui, pgtvi, ktgti, & + & prd, ktrd, pgru, pgrv, ktgr, pgrui, pgrvi, ktgri ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zps_hde_isf *** + !! + !! ** Purpose : Compute the horizontal derivative of T, S and rho + !! at u- and v-points with a linear interpolation for z-coordinate + !! with partial steps for top (ice shelf) and bottom. + !! + !! ** Method : In z-coord with partial steps, scale factors on last + !! levels are different for each grid point, so that T, S and rd + !! points are not at the same depth as in z-coord. To have horizontal + !! gradients again, we interpolate T and S at the good depth : + !! For the bottom case: + !! Linear interpolation of T, S + !! Computation of di(tb) and dj(tb) by vertical interpolation: + !! di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~ + !! dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~ + !! This formulation computes the two cases: + !! CASE 1 CASE 2 + !! k-1 ___ ___________ k-1 ___ ___________ + !! Ti T~ T~ Ti+1 + !! _____ _____ + !! k | |Ti+1 k Ti | | + !! | |____ ____| | + !! ___ | | | ___ | | | + !! + !! case 1-> (e3w_0(i+1,j,k)*(1._wp+r3t(i+1,j,Kmm))) >= (e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) ( and (e3w_0(i,j+1,k)*(1._wp+r3t(i,j+1,Kmm))) >= (e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) ) then + !! t~ = t(i+1,j ,k) + ((e3w_0(i+1,j ,k)*(1._wp+r3t(i+1,j ,Kmm))) - (e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm)))) * dk(Ti+1)/(e3w_0(i+1,j ,k)*(1._wp+r3t(i+1,j ,Kmm))) + !! ( t~ = t(i ,j+1,k) + ((e3w_0(i ,j+1,k)*(1._wp+r3t(i ,j+1,Kmm))) - (e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm)))) * dk(Tj+1)/(e3w_0(i ,j+1,k)*(1._wp+r3t(i ,j+1,Kmm))) ) + !! or + !! case 2-> (e3w_0(i+1,j,k)*(1._wp+r3t(i+1,j,Kmm))) <= (e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) ( and (e3w_0(i,j+1,k)*(1._wp+r3t(i,j+1,Kmm))) <= (e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) ) then + !! t~ = t(i,j,k) + ((e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) - (e3w_0(i+1,j ,k)*(1._wp+r3t(i+1,j ,Kmm)))) * dk(Ti)/(e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) + !! ( t~ = t(i,j,k) + ((e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) - (e3w_0(i ,j+1,k)*(1._wp+r3t(i ,j+1,Kmm)))) * dk(Tj)/(e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) ) + !! Idem for di(s) and dj(s) + !! + !! For rho, we call eos which will compute rd~(t~,s~) at the right + !! depth zh from interpolated T and S for the different formulations + !! of the equation of state (eos). + !! Gradient formulation for rho : + !! di(rho) = rd~ - rd(i,j,k) or rd(i+1,j,k) - rd~ + !! + !! For the top case (ice shelf): As for the bottom case but upside down + !! + !! ** Action : compute for top and bottom interfaces + !! - pgtu, pgtv, pgtui, pgtvi: horizontal gradient of tracer at u- & v-points + !! - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: ktta, ktgt, ktgti, ktrd, ktgr, ktgri + REAL(dp), DIMENSION((ntsi-nn_hls-1)*ktta+1:,(ntsj-nn_hls-1)*ktta+1:,:,:), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktgt+1:,(ntsj-nn_hls-1)*ktgt+1: ,:), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktgti+1:,(ntsj-nn_hls-1)*ktgti+1: ,:), INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktrd+1:,(ntsj-nn_hls-1)*ktrd+1:,: ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktgr+1:,(ntsj-nn_hls-1)*ktgr+1: ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + REAL(wp), DIMENSION((ntsi-nn_hls-1)*ktgri+1:,(ntsj-nn_hls-1)*ktgri+1: ), INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) + ! + INTEGER :: ji, jj, jn ! Dummy loop indices + INTEGER :: iku, ikv, ikum1, ikvm1,ikup1, ikvp1 ! partial step level (ocean bottom level) at u- and v-points + REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! temporary scalars + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos + REAL(wp), DIMENSION(ntsi-(nn_hls):ntei+(nn_hls),ntsj-(nn_hls):ntej+(nn_hls),kjpt) :: zti, ztj ! + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'zps_hde_isf') + ! + pgtu (:,:,:) = 0._wp ; pgtv (:,:,:) =0._wp + pgtui(:,:,:) = 0._wp ; pgtvi(:,:,:) =0._wp + zti (:,:,:) = 0._wp ; ztj (:,:,:) =0._wp + zhi (:,: ) = 0._wp ; zhj (:,: ) =0._wp + ! + DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! + ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + + iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points + ikv = mbkv(ji,jj); ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1 + ze3wu = (gdept_0(ji+1,jj,iku)*(1._wp+r3t(ji+1,jj,Kmm))) - (gdept_0(ji,jj,iku)*(1._wp+r3t(ji,jj,Kmm))) + ze3wv = (gdept_0(ji,jj+1,ikv)*(1._wp+r3t(ji,jj+1,Kmm))) - (gdept_0(ji,jj,ikv)*(1._wp+r3t(ji,jj,Kmm))) + ! + ! i- direction + IF( ze3wu >= 0._wp ) THEN ! case 1 + zmaxu = ze3wu / (e3w_0(ji+1,jj,iku)*(1._wp+r3t(ji+1,jj,Kmm))) + ! interpolated values of tracers + zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) + ! gradient of tracers + pgtu(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) + ELSE ! case 2 + zmaxu = -ze3wu / (e3w_0(ji,jj,iku)*(1._wp+r3t(ji,jj,Kmm))) + ! interpolated values of tracers + zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) + ! gradient of tracers + pgtu(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) + ENDIF + ! + ! j- direction + IF( ze3wv >= 0._wp ) THEN ! case 1 + zmaxv = ze3wv / (e3w_0(ji,jj+1,ikv)*(1._wp+r3t(ji,jj+1,Kmm))) + ! interpolated values of tracers + ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) + ! gradient of tracers + pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) + ELSE ! case 2 + zmaxv = -ze3wv / (e3w_0(ji,jj,ikv)*(1._wp+r3t(ji,jj,Kmm))) + ! interpolated values of tracers + ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) + ! gradient of tracers + pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) + ENDIF + + END DO ; END DO + END DO + ! + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + + ! horizontal derivative of density anomalies (rd) + IF( PRESENT( prd ) ) THEN ! depth of the partial step level + pgru(:,:)=0.0_wp ; pgrv(:,:)=0.0_wp ; + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = (gdept_0(ji+1,jj,iku)*(1._wp+r3t(ji+1,jj,Kmm))) - (gdept_0(ji,jj,iku)*(1._wp+r3t(ji,jj,Kmm))) + ze3wv = (gdept_0(ji,jj+1,ikv)*(1._wp+r3t(ji,jj+1,Kmm))) - (gdept_0(ji,jj,ikv)*(1._wp+r3t(ji,jj,Kmm))) + ! + IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = (gdept_0(ji ,jj,iku)*(1._wp+r3t(ji ,jj,Kmm))) ! i-direction: case 1 + ELSE ; zhi(ji,jj) = (gdept_0(ji+1,jj,iku)*(1._wp+r3t(ji+1,jj,Kmm))) ! - - case 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = (gdept_0(ji,jj ,ikv)*(1._wp+r3t(ji,jj ,Kmm))) ! j-direction: case 1 + ELSE ; zhj(ji,jj) = (gdept_0(ji,jj+1,ikv)*(1._wp+r3t(ji,jj+1,Kmm))) ! - - case 2 + ENDIF + + END DO ; END DO + + ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial + ! step and store it in zri, zrj for each case + CALL eos( zti, zhi, zri ) + CALL eos( ztj, zhj, zrj ) + + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = (gdept_0(ji+1,jj,iku)*(1._wp+r3t(ji+1,jj,Kmm))) - (gdept_0(ji,jj,iku)*(1._wp+r3t(ji,jj,Kmm))) + ze3wv = (gdept_0(ji,jj+1,ikv)*(1._wp+r3t(ji,jj+1,Kmm))) - (gdept_0(ji,jj,ikv)*(1._wp+r3t(ji,jj,Kmm))) + + IF( ze3wu >= 0._wp ) THEN ; pgru(ji,jj) = ssumask(ji,jj) * ( zri(ji ,jj ) - prd(ji,jj,iku) ) ! i: 1 + ELSE ; pgru(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj,iku) - zri(ji,jj ) ) ! i: 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; pgrv(ji,jj) = ssvmask(ji,jj) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1 + ELSE ; pgrv(ji,jj) = ssvmask(ji,jj) * ( prd(ji,jj+1,ikv) - zrj(ji,jj ) ) ! j: 2 + ENDIF + + END DO ; END DO + + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + ! !== (ISH) compute grui and gruvi ==! + ! + DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! ! + DO jj = ntsj-( nn_hls), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls), ntei+( nn_hls-1) + iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 + ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 + ! + ! (ISF) case partial step top and bottom in adjacent cell in vertical + ! cannot used e3w because if 2 cell water column, we have ps at top and bottom + ! in this case (e3w_0(i,j,k)*(1._wp+r3t(i,j,Kmm))) - (e3w_0(i,j+1,k)*(1._wp+r3t(i,j+1,Kmm))) is not the distance between Tj~ and Tj + ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 + ze3wu = (gdept_0(ji,jj,iku)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji+1,jj,iku)*(1._wp+r3t(ji+1,jj,Kmm))) + ze3wv = (gdept_0(ji,jj,ikv)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj+1,ikv)*(1._wp+r3t(ji,jj+1,Kmm))) + + ! i- direction + IF( ze3wu >= 0._wp ) THEN ! case 1 + zmaxu = ze3wu / (e3w_0(ji+1,jj,ikup1)*(1._wp+r3t(ji+1,jj,Kmm))) + ! interpolated values of tracers + zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikup1,jn) - pta(ji+1,jj,iku,jn) ) + ! gradient of tracers + pgtui(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) + ELSE ! case 2 + zmaxu = - ze3wu / (e3w_0(ji,jj,ikup1)*(1._wp+r3t(ji,jj,Kmm))) + ! interpolated values of tracers + zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikup1,jn) - pta(ji,jj,iku,jn) ) + ! gradient of tracers + pgtui(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) + ENDIF + ! + ! j- direction + IF( ze3wv >= 0._wp ) THEN ! case 1 + zmaxv = ze3wv / (e3w_0(ji,jj+1,ikvp1)*(1._wp+r3t(ji,jj+1,Kmm))) + ! interpolated values of tracers + ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvp1,jn) - pta(ji,jj+1,ikv,jn) ) + ! gradient of tracers + pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) + ELSE ! case 2 + zmaxv = - ze3wv / (e3w_0(ji,jj,ikvp1)*(1._wp+r3t(ji,jj,Kmm))) + ! interpolated values of tracers + ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvp1,jn) - pta(ji,jj,ikv,jn) ) + ! gradient of tracers + pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) + ENDIF + + END DO ; END DO + ! + END DO + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + + IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) + ! + pgrui(:,:) =0.0_wp; pgrvi(:,:) =0.0_wp; + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + + iku = miku(ji,jj) + ikv = mikv(ji,jj) + ze3wu = (gdept_0(ji,jj,iku)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji+1,jj,iku)*(1._wp+r3t(ji+1,jj,Kmm))) + ze3wv = (gdept_0(ji,jj,ikv)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj+1,ikv)*(1._wp+r3t(ji,jj+1,Kmm))) + ! + IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = (gdept_0(ji ,jj,iku)*(1._wp+r3t(ji ,jj,Kmm))) ! i-direction: case 1 + ELSE ; zhi(ji,jj) = (gdept_0(ji+1,jj,iku)*(1._wp+r3t(ji+1,jj,Kmm))) ! - - case 2 + ENDIF + + IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = (gdept_0(ji,jj ,ikv)*(1._wp+r3t(ji,jj ,Kmm))) ! j-direction: case 1 + ELSE ; zhj(ji,jj) = (gdept_0(ji,jj+1,ikv)*(1._wp+r3t(ji,jj+1,Kmm))) ! - - case 2 + ENDIF + + END DO ; END DO + ! + CALL eos( zti, zhi, zri ) ! interpolated density from zti, ztj + CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj + ! + DO jj = ntsj-( nn_hls-1), ntej+( nn_hls-1 ) ; DO ji = ntsi-( nn_hls-1), ntei+( nn_hls-1) + iku = miku(ji,jj) + ikv = mikv(ji,jj) + ze3wu = (gdept_0(ji,jj,iku)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji+1,jj,iku)*(1._wp+r3t(ji+1,jj,Kmm))) + ze3wv = (gdept_0(ji,jj,ikv)*(1._wp+r3t(ji,jj,Kmm))) - (gdept_0(ji,jj+1,ikv)*(1._wp+r3t(ji,jj+1,Kmm))) + + IF( ze3wu >= 0._wp ) THEN ; pgrui(ji,jj) = ssumask(ji,jj) * ( zri(ji ,jj ) - prd(ji,jj,iku) ) ! i: 1 + ELSE ; pgrui(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj ,iku) - zri(ji,jj ) ) ! i: 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( zrj(ji ,jj ) - prd(ji,jj,ikv) ) ! j: 1 + ELSE ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( prd(ji ,jj+1,ikv) - zrj(ji,jj ) ) ! j: 2 + ENDIF + + END DO ; END DO + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + IF( ln_timing ) CALL timing_stop( 'zps_hde_isf') + ! + END SUBROUTINE zps_hde_isf_t + + !!====================================================================== +END MODULE zpshde diff --git a/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/ppr_1d/ppr_1d.f90 b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/ppr_1d/ppr_1d.f90 new file mode 100644 index 0000000000000000000000000000000000000000..69f08ae1004e7365ab387e8c2c4f5137a79320e1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/BLD/ppsrc/ppr_1d/ppr_1d.f90 @@ -0,0 +1,6374 @@ + + + + + + + + + + + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + module ppr_1d + + ! + ! PPR-1D.F90: 1-d piecewise polynomial reconstructions. + ! + ! Darren Engwirda + ! 31-Mar-2019 + ! de2363 [at] columbia [dot] edu + ! + ! + + implicit none + + !------------------------------------ method selection ! + + integer, parameter :: p1e_method = +100 + integer, parameter :: p3e_method = +101 + integer, parameter :: p5e_method = +102 + + integer, parameter :: pcm_method = +200 + integer, parameter :: plm_method = +201 + integer, parameter :: ppm_method = +202 + integer, parameter :: pqm_method = +203 + + integer, parameter :: null_limit = +300 + integer, parameter :: mono_limit = +301 + integer, parameter :: weno_limit = +302 + + integer, parameter :: bcon_loose = +400 + integer, parameter :: bcon_value = +401 + integer, parameter :: bcon_slope = +402 + + type rmap_tics + !------------------------------- tCPU timer for RCON1D ! + integer :: rmap_time + integer :: edge_time + integer :: cell_time + integer :: oscl_time + end type rmap_tics + + type rcon_opts + !------------------------------- parameters for RCON1D ! + integer :: edge_meth + integer :: cell_meth + integer :: cell_lims + integer :: wall_lims + end type rcon_opts + + type rcon_ends + !------------------------------- end-conditions struct ! + integer :: bcopt + real*8 :: value + real*8 :: slope + end type rcon_ends + + type rcon_work + !------------------------------- work-space for RCON1D ! + real*8, allocatable :: edge_func(:,:) + real*8, allocatable :: edge_dfdx(:,:) + real*8, allocatable :: cell_oscl(:,:,:) + contains + procedure :: init => init_rcon_work + procedure :: free => free_rcon_work + end type rcon_work + + type, extends(rcon_opts) :: rmap_opts + !------------------------------- parameters for RMAP1D ! + end type rmap_opts + + type, extends(rcon_work) :: rmap_work + !------------------------------- work-space for RMAP1D ! + real*8, allocatable :: cell_spac(:) + real*8, allocatable :: cell_func(:,:,:) + contains + procedure :: init => init_rmap_work + procedure :: free => free_rmap_work + end type rmap_work + + contains + + !------------------------------------------------------! + ! INIT-RCON-WORK: init. work-space for RCON1D. ! + !------------------------------------------------------! + + subroutine init_rcon_work(this,npos,nvar,opts) + + ! + ! THIS work-space structure for RCON1D . + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! OPTS parameters structure for RCON1D . + ! + + implicit none + + !------------------------------------------- arguments ! + class(rcon_work) , intent(inout) :: this + integer, intent(in):: npos + integer, intent(in):: nvar + class(rcon_opts) , optional :: opts + + !------------------------------------------- variables ! + integer :: okay + + allocate(this% & + & edge_func( nvar,npos), & + & this% & + & edge_dfdx( nvar,npos), & + & this% & + & cell_oscl(2,nvar,npos), & + & stat=okay) + + end subroutine + + !------------------------------------------------------! + ! INIT-RMAP-WORK: init. work-space for RMAP1D. ! + !------------------------------------------------------! + + subroutine init_rmap_work(this,npos,nvar,opts) + + ! + ! THIS work-space structure for RMAP1D . + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! OPTS parameters structure for RMAP1D . + ! + + implicit none + + !------------------------------------------- arguments ! + class(rmap_work) , intent(inout) :: this + integer, intent(in) :: npos + integer, intent(in) :: nvar + class(rcon_opts) , optional :: opts + + !------------------------------------------- variables ! + integer :: okay,ndof + + ndof = ndof1d(opts%cell_meth) + + allocate(this% & + & edge_func( nvar,npos), & + & this% & + & edge_dfdx( nvar,npos), & + & this% & + & cell_oscl(2,nvar,npos), & + & this% & + & cell_spac( npos), & + & this% & + & cell_func(ndof,nvar,npos) , & + & stat=okay) + + end subroutine + + !------------------------------------------------------! + ! FREE-RCON-WORK: free work-space for RCON1D . ! + !------------------------------------------------------! + + subroutine free_rcon_work(this) + + implicit none + + !------------------------------------------- arguments ! + class(rcon_work), intent(inout) :: this + + deallocate(this%edge_func, & + & this%edge_dfdx, & + & this%cell_oscl) + + end subroutine + + !------------------------------------------------------! + ! FREE-RMAP-WORK: free work-space for RMAP1D . ! + !------------------------------------------------------! + + subroutine free_rmap_work(this) + + implicit none + + !------------------------------------------- arguments ! + class(rmap_work), intent(inout) :: this + + + deallocate(this%edge_func, & + & this%edge_dfdx, & + & this%cell_oscl, & + & this%cell_func, & + & this%cell_spac) + + end subroutine + + !------------------------------------------------------! + ! NDOF1D : no. degrees-of-freedom per polynomial . ! + !------------------------------------------------------! + + pure function ndof1d(meth) result(rdof) + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: meth + + !------------------------------------------- variables ! + integer :: rdof + + select case(meth) + !-------------------------------- edge reconstructions ! + case (p1e_method) + rdof = +2 + case (p3e_method) + rdof = +4 + case (p5e_method) + rdof = +6 + !-------------------------------- cell reconstructions ! + case (pcm_method) + rdof = +1 + case (plm_method) + rdof = +2 + case (ppm_method) + rdof = +3 + case (pqm_method) + rdof = +5 + + case default + rdof = +0 + + end select + + end function ndof1d + + !------------------------------------------------------! + ! BFUN1D : one-dimensional poly. basis-functions . ! + !------------------------------------------------------! + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! BFUN1D.h90: poly. basis-functions for reconstruction. + ! + ! Darren Engwirda + ! 07-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine bfun1d(isel,ndof,sval,bfun) + + ! + ! ISEL basis-function "order", -1 => integral-basis , + ! +0 => function-basis, +1 => 1st deriv.-basis , + ! +2 => 2nd deriv.-basis. + ! NDOF no. degrees-of-freedom in basis. + ! SVAL local coord. at which to evaluate basis-func., + ! such that -1.0 <= SVAL <= +1.0 . + ! BFUN basis-vector evaluated at SVAL . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: isel,ndof + real*8 , intent( in) :: sval + real*8 , intent(out) :: bfun(:) + + select case (isel) + case (-1) + !------------------------------------ -1th-order basis ! + select case (ndof) + case (+1) + bfun(1) = sval**1 / 1.e0 + + case (+2) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + + case (+3) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + bfun(3) = sval**3 / 3.e0 + + case (+4) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + bfun(3) = sval**3 / 3.e0 + bfun(4) = sval**4 / 4.e0 + + case (+5) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + bfun(3) = sval**3 / 3.e0 + bfun(4) = sval**4 / 4.e0 + bfun(5) = sval**5 / 5.e0 + + case (+6) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + bfun(3) = sval**3 / 3.e0 + bfun(4) = sval**4 / 4.e0 + bfun(5) = sval**5 / 5.e0 + bfun(6) = sval**6 / 6.e0 + + case (+7) + bfun(1) = sval**1 / 1.e0 + bfun(2) = sval**2 / 2.e0 + bfun(3) = sval**3 / 3.e0 + bfun(4) = sval**4 / 4.e0 + bfun(5) = sval**5 / 5.e0 + bfun(6) = sval**6 / 6.e0 + bfun(7) = sval**7 / 7.e0 + + end select + + case (+0) + !------------------------------------ +0th-order basis ! + select case (ndof) + case (+1) + bfun(1) = 1.e0 + + case (+2) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + + case (+3) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + bfun(3) = sval**2 * 1.e0 + + case (+4) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + bfun(3) = sval**2 * 1.e0 + bfun(4) = sval**3 * 1.e0 + + case (+5) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + bfun(3) = sval**2 * 1.e0 + bfun(4) = sval**3 * 1.e0 + bfun(5) = sval**4 * 1.e0 + + case (+6) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + bfun(3) = sval**2 * 1.e0 + bfun(4) = sval**3 * 1.e0 + bfun(5) = sval**4 * 1.e0 + bfun(6) = sval**5 * 1.e0 + + case (+7) + bfun(1) = 1.e0 + bfun(2) = sval**1 * 1.e0 + bfun(3) = sval**2 * 1.e0 + bfun(4) = sval**3 * 1.e0 + bfun(5) = sval**4 * 1.e0 + bfun(6) = sval**5 * 1.e0 + bfun(7) = sval**6 * 1.e0 + + end select + + case (+1) + !------------------------------------ +1st-order basis ! + select case (ndof) + case (+1) + bfun(1) = 0.e0 + + case (+2) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + + case (+3) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + bfun(3) = sval**1 * 2.e0 + + case (+4) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + bfun(3) = sval**1 * 2.e0 + bfun(4) = sval**2 * 3.e0 + + case (+5) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + bfun(3) = sval**1 * 2.e0 + bfun(4) = sval**2 * 3.e0 + bfun(5) = sval**3 * 4.e0 + + case (+6) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + bfun(3) = sval**1 * 2.e0 + bfun(4) = sval**2 * 3.e0 + bfun(5) = sval**3 * 4.e0 + bfun(6) = sval**4 * 5.e0 + + case (+7) + bfun(1) = 0.e0 + bfun(2) = 1.e0 + bfun(3) = sval**1 * 2.e0 + bfun(4) = sval**2 * 3.e0 + bfun(5) = sval**3 * 4.e0 + bfun(6) = sval**4 * 5.e0 + bfun(7) = sval**5 * 6.e0 + + end select + + case (+2) + !------------------------------------ +2nd-order basis ! + select case (ndof) + case (+1) + bfun(1) = 0.e0 + + case (+2) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + + case (+3) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + bfun(3) = 2.e0 + + case (+4) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + bfun(3) = 2.e0 + bfun(4) = sval**1 * 6.e0 + + case (+5) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + bfun(3) = 2.e0 + bfun(4) = sval**1 * 6.e0 + bfun(5) = sval**2 *12.e0 + + case (+6) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + bfun(3) = 2.e0 + bfun(4) = sval**1 * 6.e0 + bfun(5) = sval**2 *12.e0 + bfun(6) = sval**3 *20.e0 + + case (+7) + bfun(1) = 0.e0 + bfun(2) = 0.e0 + bfun(3) = 2.e0 + bfun(4) = sval**1 * 6.e0 + bfun(5) = sval**2 *12.e0 + bfun(6) = sval**3 *20.e0 + bfun(7) = sval**4 *30.e0 + + end select + + end select + + end subroutine + + + + + !------------------------------------------------------! + ! UTIL1D : one-dimensional grid manip. utilities . ! + !------------------------------------------------------! + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! UTIL1D.h90: util. func. for 1-dim. grid manipulation. + ! + ! Darren Engwirda + ! 31-Mar-2019 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine linspace(xxll,xxuu,npos,xpos) + + ! + ! XXLL lower-bound grid position. + ! NNEW upper-bound grid position. + ! NPOS no. edges in the grid. + ! XPOS array of grid edges. XPOS has length NPOS . + ! + + implicit none + + real*8 , intent(in) :: xxll,xxuu + integer, intent(in) :: npos + real*8 , intent(out) :: xpos(:) + + integer :: ipos + real*8 :: xdel + + xpos( 1) = xxll + xpos(npos) = xxuu + + xdel = (xxuu-xxll) / (npos - 1) + + do ipos = +2, npos-1 + + xpos(ipos) = (ipos-1) * xdel + + end do + + return + + end subroutine + + subroutine rndspace(xxll,xxuu,npos,xpos, & + & frac) + + ! + ! XXLL lower-bound grid position. + ! NNEW upper-bound grid position. + ! NPOS no. edges in the grid. + ! XPOS array of grid edges. XPOS has length NPOS . + ! FRAC fractional perturbation of cell, OPTIONAL . + ! + + implicit none + + real*8 , intent(in) :: xxll,xxuu + integer, intent(in) :: npos + real*8 , intent(out) :: xpos(:) + real*8 , intent(in), optional :: frac + + integer :: ipos + real*8 :: xdel,rand,move + + if (present(frac)) then + move = +frac + else + move = 0.33d0 + end if + + xpos( 1) = xxll + xpos(npos) = xxuu + + xdel = (xxuu-xxll) / (npos - 1) + + do ipos = +2, npos-1 + + xpos(ipos) = (ipos-1) * xdel + + end do + + do ipos = +2, npos-1 + + call random_number (rand) + + rand = 2.e0 * (rand-.5d0) + + move = rand * move + + xpos(ipos) = & + & xpos(ipos) + move * xdel + + end do + + return + + end subroutine + + + + + !------------------------------------------------------! + ! WENO1D : "essentially" non-oscillatory limiter . ! + !------------------------------------------------------! + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! WENO1D.h90: WENO-style slope-limiting for 1d reconst. + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine wenoi (npos,delx,oscl,ipos, & + & ivar,halo,& + & wlim,wval ) + + ! + ! NPOS no. edges over grid. + ! DELX grid-cell spacing array. SIZE(DELX) == +1 if + ! the grid is uniformly spaced . + ! OSCL cell-centred oscillation-detectors, where OSCL + ! has SIZE = +2-by-NVAR-by-NPOS-1. OSCL is given + ! by calls to OSCLI(). + ! IPOS grid-cell index for which to calc. weights . + ! IVAR state-var index for which to calc/ weights . + ! HALO width of recon. stencil, symmetric about IPOS . + ! WLIM limiter treatment at endpoints, monotonic or + ! otherwise . + ! WVAL WENO weights vector, such that FHAT = WVAL(1) * + ! UHAT + WVAL(2) * LHAT, where UHAT and LHAT are + ! the unlimited and monotonic grid-cell profiles + ! respectively . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,halo + integer, intent(in) :: ipos,ivar + integer, intent(in) :: wlim + real*8 , intent(in) :: delx(:) + real*8 , intent(in) :: oscl(:,:,:) + real*8 , intent(out) :: wval(2) + + !------------------------------------------- variables ! + real*8 :: omin,omax,wsum + + real*8 , parameter :: ZERO = +1.e-16 + + if (size(delx).gt.+1) then + + !------------------- use variable grid spacing variant ! + + call wenov(npos,delx,oscl, & + & ipos,ivar,halo, & + & wlim,omin,omax) + + else + + !------------------- use constant grid spacing variant ! + + call wenoc(npos,delx,oscl, & + & ipos,ivar,halo, & + & wlim,omin,omax) + + end if + + !------------------ compute WENO-style profile weights ! + + omax = omax + ZERO + omin = omin + ZERO + + if (halo .ge. +3) then + + wval(1) = +1.0d+7 / omax ** 3 + wval(2) = +1.0d+0 / omin ** 3 + + else & + & if (halo .le. +2) then + + wval(1) = +1.0d+5 / omax ** 3 + wval(2) = +1.0d+0 / omin ** 3 + + end if + + wsum = wval(1) + wval(2) + ZERO + wval(1) = wval(1) / wsum + ! wval(2) = wval(2) / wsum + wval(2) =-wval(1) + 1.e0 ! wval(2)/wsum but robust ! + + return + + end subroutine + + pure subroutine wenov (npos,delx,oscl,ipos, & + & ivar,halo,& + & wlim,omin,omax) + + ! + ! *this is the variable grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! DELX grid-cell spacing array. SIZE(DELX) == +1 if + ! the grid is uniformly spaced . + ! OSCL cell-centred oscillation-detectors, where OSCL + ! has SIZE = +2-by-NVAR-by-NPOS-1. OSCL is given + ! by calls to OSCLI(). + ! IPOS grid-cell index for which to calc. weights . + ! IVAR state-var index for which to calc/ weights . + ! HALO width of recon. stencil, symmetric about IPOS . + ! WLIM limiter treatment at endpoints, monotonic or + ! otherwise . + ! OMIN min. and max. oscillation indicators over the + ! OMAX local re-con. stencil . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,halo + integer, intent(in) :: ipos,ivar + integer, intent(in) :: wlim + real*8 , intent(in) :: delx(:) + real*8 , intent(in) :: oscl(:,:,:) + real*8 , intent(out) :: omin,omax + + !------------------------------------------- variables ! + integer :: hpos + integer :: head,tail + integer :: imin,imax + real*8 :: deli,delh + real*8 :: hh00,hsqr + real*8 :: dfx1,dfx2 + real*8 :: oval + + !------------------- calc. lower//upper stencil bounds ! + + head = 1; tail = npos - 1 + + if(wlim.eq.mono_limit) then + + !---------------------- deactivate WENO at boundaries ! + + if (ipos-halo.lt.head) then + + omax = 1.e0 + omin = 0.e0 ; return + + end if + + if (ipos+halo.gt.tail) then + + omax = 1.e0 + omin = 0.e0 ; return + + end if + + end if + + !---------------------- truncate stencil at boundaries ! + + imin = max(ipos-halo,head) + imax = min(ipos+halo,tail) + + !------------------ find min/max indicators on stencil ! + + dfx1 = oscl(1,ivar,ipos) + dfx2 = oscl(2,ivar,ipos) + + hh00 = delx(ipos+0)**1 + hsqr = delx(ipos+0)**2 + + oval =(hh00 * dfx1)**2 & + & +(hsqr * dfx2)**2 + + omin = oval + omax = oval + + !---------------------------------------- "lower" part ! + + delh = 0.e0 + + do hpos = ipos-1, imin, -1 + + !------------------ calc. derivatives centred on IPOS. ! + + deli = delx(hpos+0) & + & + delx(hpos+1) + + delh = delh + deli*.5d0 + + dfx1 = oscl(1,ivar,hpos) + dfx2 = oscl(2,ivar,hpos) + + dfx1 = dfx1 + dfx2*delh + + !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! + + oval = (hh00 * dfx1)**2 & + & + (hsqr * dfx2)**2 + + if (oval .lt. omin) then + omin = oval + else & + & if (oval .gt. omax) then + omax = oval + end if + + end do + + !---------------------------------------- "upper" part ! + + delh = 0.e0 + + do hpos = ipos+1, imax, +1 + + !------------------ calc. derivatives centred on IPOS. ! + + deli = delx(hpos+0) & + & + delx(hpos-1) + + delh = delh - deli*.5d0 + + dfx1 = oscl(1,ivar,hpos) + dfx2 = oscl(2,ivar,hpos) + + dfx1 = dfx1 + dfx2*delh + + !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! + + oval = (hh00 * dfx1)**2 & + & + (hsqr * dfx2)**2 + + if (oval .lt. omin) then + omin = oval + else & + & if (oval .gt. omax) then + omax = oval + end if + + end do + + return + + end subroutine + + pure subroutine wenoc (npos,delx,oscl,ipos, & + & ivar,halo,& + & wlim,omin,omax) + + ! + ! *this is the constant grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! DELX grid-cell spacing array. SIZE(DELX) == +1 if + ! the grid is uniformly spaced . + ! OSCL cell-centred oscillation-detectors, where OSCL + ! has SIZE = +2-by-NVAR-by-NPOS-1. OSCL is given + ! by calls to OSCLI(). + ! IPOS grid-cell index for which to calc. weights . + ! IVAR state-var index for which to calc/ weights . + ! HALO width of recon. stencil, symmetric about IPOS . + ! WLIM limiter treatment at endpoints, monotonic or + ! otherwise . + ! OMIN min. and max. oscillation indicators over the + ! OMAX local re-con. stencil . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,halo + integer, intent(in) :: ipos,ivar + integer, intent(in) :: wlim + real*8 , intent(in) :: delx(1) + real*8 , intent(in) :: oscl(:,:,:) + real*8 , intent(out) :: omin,omax + + !------------------------------------------- variables ! + integer :: hpos + integer :: head,tail + integer :: imin,imax + real*8 :: delh + real*8 :: dfx1,dfx2 + real*8 :: oval + + !------------------- calc. lower//upper stencil bounds ! + + head = 1; tail = npos - 1 + + if(wlim.eq.mono_limit) then + + !---------------------- deactivate WENO at boundaries ! + + if (ipos-halo.lt.head) then + + omax = 1.e0 + omin = 0.e0 ; return + + end if + + if (ipos+halo.gt.tail) then + + omax = 1.e0 + omin = 0.e0 ; return + + end if + + end if + + !---------------------- truncate stencil at boundaries ! + + imin = max(ipos-halo,head) + imax = min(ipos+halo,tail) + + !------------------ find min/max indicators on stencil ! + + dfx1 = oscl(1,ivar,ipos) + dfx2 = oscl(2,ivar,ipos) + + oval = (2.e0**1*dfx1)**2 & + & + (2.e0**2*dfx2)**2 + + omin = oval + omax = oval + + !---------------------------------------- "lower" part ! + + delh = 0.e0 + + do hpos = ipos-1, imin, -1 + + !------------------ calc. derivatives centred on IPOS. ! + + delh = delh + 2.e0 + + dfx1 = oscl(1,ivar,hpos) + dfx2 = oscl(2,ivar,hpos) + + dfx1 = dfx1 + dfx2*delh + + !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! + + oval = (2.e0**1*dfx1)**2 & + & + (2.e0**2*dfx2)**2 + + if (oval .lt. omin) then + omin = oval + else & + & if (oval .gt. omax) then + omax = oval + end if + + end do + + !---------------------------------------- "upper" part ! + + delh = 0.e0 + + do hpos = ipos+1, imax, +1 + + !------------------ calc. derivatives centred on IPOS. ! + + delh = delh - 2.e0 + + dfx1 = oscl(1,ivar,hpos) + dfx2 = oscl(2,ivar,hpos) + + dfx1 = dfx1 + dfx2*delh + + !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! + + oval = (2.e0**1*dfx1)**2 & + & + (2.e0**2*dfx2)**2 + + if (oval .lt. omin) then + omin = oval + else & + & if (oval .gt. omax) then + omax = oval + end if + + end do + + return + + end subroutine + + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! OSCL1D.h90: "oscillation-indicators" for WENO interp. + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine oscli (npos,nvar,ndof,delx,& + & fdat,oscl,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX (constant) grid-cell spacing. LENGTH(DELX)==+1 . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! OSCL grid-cell oscil. dof.'s. OSCL is an array with + ! SIZE = +2 -by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: oscl(:,:,:) + + !------------------------------------------- variables ! + integer :: ivar,ipos + + if (npos.lt.3) then + !------------------------------- at least 3 grid-cells ! + do ipos = +1, npos-1 + do ivar = +1, nvar-0 + oscl(1,ivar,ipos) = +0.e0 + oscl(2,ivar,ipos) = +0.e0 + end do + end do + end if + + if (npos.lt.3) return + if (nvar.lt.1) return + if (ndof.lt.1) return + + if (size(delx).gt.+1) then + + !------------------------------- variable grid-spacing ! + + call osclv(npos,nvar,ndof,delx, & + & fdat,oscl,dmin) + + else + + !------------------------------- constant grid-spacing ! + + call osclc(npos,nvar,ndof,delx, & + & fdat,oscl,dmin) + + end if + + return + + end subroutine + + pure subroutine osclv (npos,nvar,ndof,delx,& + & fdat,oscl,dmin) + + ! + ! *this is the variable grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX (variable) grid-cell spacing. LENGTH(DELX)!=+1 . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! OSCL grid-cell oscil. dof.'s. OSCL is an array with + ! SIZE = +2 -by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: oscl(:,:,:) + + !------------------------------------------- variables ! + integer :: head,tail + integer :: ipos,ivar + real*8 :: hhll,hhcc,hhrr + real*8 :: hhmm,hhrc,hhlc + real*8 :: cmat(2,3) + + head = +1 ; tail = npos-1 + + !--------------------------------------- centred point ! + + do ipos = head+1, tail-1 + + hhll = max(delx(ipos-1),dmin) + hhcc = max(delx(ipos+0),dmin) + hhrr = max(delx(ipos+1),dmin) + + hhrc = hhrr + hhcc + hhlc = hhll + hhcc + hhmm = hhll + hhcc + hhrr + + cmat(1,1) = -(hhcc+2.e0*hhrr)/(hhlc*hhmm) + cmat(1,2) = -(hhll-hhrr)* & + & (3.e0*hhcc+2.e0*(hhll+hhrr))/& + & (hhlc*hhrc*hhmm) + cmat(1,3) = +(hhcc+2.e0*hhll)/(hhrc*hhmm) + + cmat(2,1) = +3.e0/(hhlc*hhmm) + cmat(2,2) = -3.e0*(2.e0*hhcc+hhll+hhrr)/& + & (hhlc*hhrc*hhmm) + cmat(2,3) = +3.e0/(hhrc*hhmm) + + do ivar = 1, nvar + + oscl(1,ivar,ipos) = +1.e0 * ( & + & + cmat(1,1)*fdat(1,ivar,ipos-1) & + & + cmat(1,2)*fdat(1,ivar,ipos+0) & + & + cmat(1,3)*fdat(1,ivar,ipos+1) ) + + oscl(2,ivar,ipos) = +2.e0 * ( & + & + cmat(2,1)*fdat(1,ivar,ipos-1) & + & + cmat(2,2)*fdat(1,ivar,ipos+0) & + & + cmat(2,3)*fdat(1,ivar,ipos+1) ) + + end do + + end do + + !-------------------------------------- lower endpoint ! + + hhll = max(delx(head+0),dmin) + hhcc = max(delx(head+1),dmin) + hhrr = max(delx(head+2),dmin) + + cmat(1,1) = -2.e0 / (hhll+hhcc) + cmat(1,2) = +2.e0 / (hhll+hhcc) + + do ivar = 1, nvar + + oscl(1,ivar,head) = & + & + cmat(1,1)*fdat(1,ivar,head+0) & + & + cmat(1,2)*fdat(1,ivar,head+1) + + oscl(2,ivar,head) = +0.e0 + + end do + + !-------------------------------------- upper endpoint ! + + hhll = max(delx(tail-2),dmin) + hhcc = max(delx(tail-1),dmin) + hhrr = max(delx(tail-0),dmin) + + cmat(1,2) = -2.e0 / (hhrr+hhcc) + cmat(1,3) = +2.e0 / (hhrr+hhcc) + + do ivar = 1, nvar + + oscl(1,ivar,tail) = & + & + cmat(1,2)*fdat(1,ivar,tail-1) & + & + cmat(1,3)*fdat(1,ivar,tail+0) + + oscl(2,ivar,tail) = +0.e0 + + end do + + return + + end subroutine + + pure subroutine osclc (npos,nvar,ndof,delx,& + & fdat,oscl,dmin) + + ! + ! *this is the constant grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX (constant) grid-cell spacing. LENGTH(DELX)==+1 . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! OSCL grid-cell oscil. dof.'s. OSCL is an array with + ! SIZE = +2 -by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(1) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: oscl(:,:,:) + + !------------------------------------------- variables ! + integer :: head,tail,ipos,ivar + + head = +1; tail = npos - 1 + + !-------------------------------------- centred points ! + + do ipos = 2, npos-2 + do ivar = 1, nvar-0 + + oscl(1,ivar,ipos) = & + & + .25d+0 * fdat(1,ivar,ipos+1) & + & - .25d+0 * fdat(1,ivar,ipos-1) + + oscl(2,ivar,ipos) = & + & + .25d+0 * fdat(1,ivar,ipos+1) & + & - .50d+0 * fdat(1,ivar,ipos+0) & + & + .25d+0 * fdat(1,ivar,ipos-1) + + end do + end do + + !-------------------------------------- lower endpoint ! + + do ivar = 1, nvar + + oscl(1,ivar,head) = & + & + .50d+0 * fdat(1,ivar,head+1) & + & - .50d+0 * fdat(1,ivar,head+0) + + oscl(2,ivar,head) = +0.e0 + + end do + + !-------------------------------------- upper endpoint ! + + do ivar = 1, nvar + + oscl(1,ivar,tail) = & + & + .50d+0 * fdat(1,ivar,tail+0) & + & - .50d+0 * fdat(1,ivar,tail-1) + + oscl(2,ivar,tail) = +0.e0 + + end do + + return + + end subroutine + + + + + !------------------------------------------------------! + ! RCON1D : one-dimensional poly. reconstructions . ! + !------------------------------------------------------! + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! RCON1D.h90: conservative, polynomial reconstructions. + ! + ! Darren Engwirda + ! 07-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine rcon1d(npos,nvar,ndof,delx,fdat, & + & bclo,bchi,fhat,work,opts, & + & tCPU) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCLO boundary condition at lower endpoint. + ! BCHI boundary condition at upper endpoint. + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! WORK method work-space. See RCON-WORK for details . + ! OPTS method parameters. See RCON-OPTS for details . + ! TCPU method tcpu-timer. + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + class(rcon_work), intent(inout):: work + class(rcon_opts), intent(in) :: opts + real*8 , intent( in) :: delx(:) + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + type (rcon_ends), intent(in) :: bclo(:) + type (rcon_ends), intent(in) :: bchi(:) + type (rmap_tics), & + & intent(inout) , optional :: tCPU + + !------------------------------------------- variables ! + integer :: halo,ipos + real*8 :: dmin,dmid + + + if (ndof.lt.1) return + if (npos.lt.2) return + if (nvar.lt.1) return + + !-------------------------- compute min grid-tolerance ! + + dmid = delx(1) + + if (size(delx).gt.+1) then + + do ipos = 2, npos-1 + dmid = & + & dmid + delx (ipos) + end do + + dmid = dmid /(npos-1) + + end if + + dmin = +1.0d-14 * dmid + + !-------------------------- compute edge values/slopes ! + + + if ( (opts%cell_meth.eq.ppm_method) & + & .or. (opts%cell_meth.eq.pqm_method) ) then + + select case (opts%edge_meth) + case(p1e_method) + !------------------------------------ 2nd-order method ! + halo = +1 + call p1e(npos,nvar,ndof, & + & delx,fdat, & + & bclo,bchi, & + & work%edge_func, & + & work%edge_dfdx, & + & opts,dmin) + + case(p3e_method) + !------------------------------------ 4th-order method ! + halo = +2 + call p3e(npos,nvar,ndof, & + & delx,fdat, & + & bclo,bchi, & + & work%edge_func, & + & work%edge_dfdx, & + & opts,dmin) + + case(p5e_method) + !------------------------------------ 6th-order method ! + halo = +3 + call p5e(npos,nvar,ndof, & + & delx,fdat, & + & bclo,bchi, & + & work%edge_func, & + & work%edge_dfdx, & + & opts,dmin) + + end select + + end if + + + !-------------------------- compute oscil. derivatives ! + + + if (opts%cell_lims.eq.weno_limit) then + + call oscli(npos,nvar,ndof, & + & delx,fdat, & + & work%cell_oscl, & + & dmin) + + end if + + + !-------------------------- compute grid-cell profiles ! + + + select case (opts%cell_meth) + case(pcm_method) + !------------------------------------ 1st-order method ! + call pcm(npos,nvar,ndof, & + & fdat,fhat) + + case(plm_method) + !------------------------------------ 2nd-order method ! + call plm(npos,nvar,ndof, & + & delx,fdat,fhat, & + & dmin,& + & opts%cell_lims) + + case(ppm_method) + !------------------------------------ 3rd-order method ! + call ppm(npos,nvar,ndof, & + & delx,fdat,fhat, & + & work%edge_func, & + & work%cell_oscl, & + & dmin,& + & opts%cell_lims, & + & opts%wall_lims, & + & halo ) + + case(pqm_method) + !------------------------------------ 5th-order method ! + call pqm(npos,nvar,ndof, & + & delx,fdat,fhat, & + & work%edge_func, & + & work%edge_dfdx, & + & work%cell_oscl, & + & dmin,& + & opts%cell_lims, & + & opts%wall_lims, & + & halo ) + + end select + + + end subroutine + + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! INV.h90: block-wise solution of small linear systems. + ! + ! Darren Engwirda + ! 25-Mar-2019 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine inv_2x2(amat,adim,ainv,vdim, & + & adet) + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: adim + real*8 , intent( in) :: amat(adim,*) + integer, intent( in) :: vdim + real*8 , intent(out) :: ainv(vdim,*) + real*8 , intent(out) :: adet + + !------------------------------------------- form A^-1 ! + + adet = amat(1,1) * amat(2,2) & + - amat(1,2) * amat(2,1) + + ainv(1,1) = amat(2,2) + ainv(1,2) = - amat(1,2) + ainv(2,1) = - amat(2,1) + ainv(2,2) = amat(1,1) + + return + + end subroutine + + pure subroutine inv_3x3(amat,adim,ainv,vdim, & + & adet) + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: adim + real*8 , intent( in) :: amat(adim,*) + integer, intent( in) :: vdim + real*8 , intent(out) :: ainv(vdim,*) + real*8 , intent(out) :: adet + + !------------------------------------------- variables ! + real*8 :: & + aa2233,aa2332,aa2133,aa2331,aa2132,& + aa2231,aa1233,aa1332,aa1223,aa1322,& + aa1133,aa1331,aa1123,aa1321,aa1132,& + aa1231,aa1122,aa1221 + + !------------------------------------------- form A^-1 ! + + aa2233 = amat(2,2) * amat(3,3) + aa2332 = amat(2,3) * amat(3,2) + aa2133 = amat(2,1) * amat(3,3) + aa2331 = amat(2,3) * amat(3,1) + aa2132 = amat(2,1) * amat(3,2) + aa2231 = amat(2,2) * amat(3,1) + + adet = & + amat(1,1) * (aa2233 - aa2332) - & + amat(1,2) * (aa2133 - aa2331) + & + amat(1,3) * (aa2132 - aa2231) + + aa1233 = amat(1,2) * amat(3,3) + aa1332 = amat(1,3) * amat(3,2) + aa1223 = amat(1,2) * amat(2,3) + aa1322 = amat(1,3) * amat(2,2) + aa1133 = amat(1,1) * amat(3,3) + aa1331 = amat(1,3) * amat(3,1) + aa1123 = amat(1,1) * amat(2,3) + aa1321 = amat(1,3) * amat(2,1) + aa1132 = amat(1,1) * amat(3,2) + aa1231 = amat(1,2) * amat(3,1) + aa1122 = amat(1,1) * amat(2,2) + aa1221 = amat(1,2) * amat(2,1) + + ainv(1,1) = (aa2233 - aa2332) + ainv(1,2) = -(aa1233 - aa1332) + ainv(1,3) = (aa1223 - aa1322) + + ainv(2,1) = -(aa2133 - aa2331) + ainv(2,2) = (aa1133 - aa1331) + ainv(2,3) = -(aa1123 - aa1321) + + ainv(3,1) = (aa2132 - aa2231) + ainv(3,2) = -(aa1132 - aa1231) + ainv(3,3) = (aa1122 - aa1221) + + return + + end subroutine + + pure subroutine mul_2x2(amat,adim,bmat,bdim, & + & scal,cmat,cdim) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: bdim + real*8 , intent(in) :: bmat(bdim,*) + real*8 , intent(in) :: scal + integer, intent(in) :: cdim + real*8 , intent(inout) :: cmat(cdim,*) + + !-------------------------------- C = C + scal * A * B ! + + if (scal .eq. +1.e0) then + + cmat(1,1) = cmat(1,1) & + + ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) ) + cmat(2,1) = cmat(2,1) & + + ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) ) + + cmat(1,2) = cmat(1,2) & + + ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) ) + cmat(2,2) = cmat(2,2) & + + ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) ) + + else & + if (scal .eq. -1.e0) then + + cmat(1,1) = cmat(1,1) & + - ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) ) + cmat(2,1) = cmat(2,1) & + - ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) ) + + cmat(1,2) = cmat(1,2) & + - ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) ) + cmat(2,2) = cmat(2,2) & + - ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) ) + + else + + cmat(1,1) = cmat(1,1) + & + scal * ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) ) + cmat(2,1) = cmat(2,1) + & + scal * ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) ) + + cmat(1,2) = cmat(1,2) + & + scal * ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) ) + cmat(2,2) = cmat(2,2) + & + scal * ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) ) + + end if + + return + + end subroutine + + pure subroutine mul_3x3(amat,adim,bmat,bdim, & + & scal,cmat,cdim) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: bdim + real*8 , intent(in) :: bmat(bdim,*) + real*8 , intent(in) :: scal + integer, intent(in) :: cdim + real*8 , intent(inout) :: cmat(cdim,*) + + !-------------------------------- C = C + scal * A * B ! + + if (scal .eq. +1.e0) then + + cmat(1,1) = cmat(1,1) & + + ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) & + + amat(1,3) * bmat(3,1) ) + cmat(2,1) = cmat(2,1) & + + ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) & + + amat(2,3) * bmat(3,1) ) + cmat(3,1) = cmat(3,1) & + + ( amat(3,1) * bmat(1,1) & + + amat(3,2) * bmat(2,1) & + + amat(3,3) * bmat(3,1) ) + + cmat(1,2) = cmat(1,2) & + + ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) & + + amat(1,3) * bmat(3,2) ) + cmat(2,2) = cmat(2,2) & + + ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) & + + amat(2,3) * bmat(3,2) ) + cmat(3,2) = cmat(3,2) & + + ( amat(3,1) * bmat(1,2) & + + amat(3,2) * bmat(2,2) & + + amat(3,3) * bmat(3,2) ) + + cmat(1,3) = cmat(1,3) & + + ( amat(1,1) * bmat(1,3) & + + amat(1,2) * bmat(2,3) & + + amat(1,3) * bmat(3,3) ) + cmat(2,3) = cmat(2,3) & + + ( amat(2,1) * bmat(1,3) & + + amat(2,2) * bmat(2,3) & + + amat(2,3) * bmat(3,3) ) + cmat(3,3) = cmat(3,3) & + + ( amat(3,1) * bmat(1,3) & + + amat(3,2) * bmat(2,3) & + + amat(3,3) * bmat(3,3) ) + + else & + if (scal .eq. -1.e0) then + + cmat(1,1) = cmat(1,1) & + - ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) & + + amat(1,3) * bmat(3,1) ) + cmat(2,1) = cmat(2,1) & + - ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) & + + amat(2,3) * bmat(3,1) ) + cmat(3,1) = cmat(3,1) & + - ( amat(3,1) * bmat(1,1) & + + amat(3,2) * bmat(2,1) & + + amat(3,3) * bmat(3,1) ) + + cmat(1,2) = cmat(1,2) & + - ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) & + + amat(1,3) * bmat(3,2) ) + cmat(2,2) = cmat(2,2) & + - ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) & + + amat(2,3) * bmat(3,2) ) + cmat(3,2) = cmat(3,2) & + - ( amat(3,1) * bmat(1,2) & + + amat(3,2) * bmat(2,2) & + + amat(3,3) * bmat(3,2) ) + + cmat(1,3) = cmat(1,3) & + - ( amat(1,1) * bmat(1,3) & + + amat(1,2) * bmat(2,3) & + + amat(1,3) * bmat(3,3) ) + cmat(2,3) = cmat(2,3) & + - ( amat(2,1) * bmat(1,3) & + + amat(2,2) * bmat(2,3) & + + amat(2,3) * bmat(3,3) ) + cmat(3,3) = cmat(3,3) & + - ( amat(3,1) * bmat(1,3) & + + amat(3,2) * bmat(2,3) & + + amat(3,3) * bmat(3,3) ) + + else + + cmat(1,1) = cmat(1,1) + & + scal * ( amat(1,1) * bmat(1,1) & + + amat(1,2) * bmat(2,1) & + + amat(1,3) * bmat(3,1) ) + cmat(2,1) = cmat(2,1) + & + scal * ( amat(2,1) * bmat(1,1) & + + amat(2,2) * bmat(2,1) & + + amat(2,3) * bmat(3,1) ) + cmat(3,1) = cmat(3,1) + & + scal * ( amat(3,1) * bmat(1,1) & + + amat(3,2) * bmat(2,1) & + + amat(3,3) * bmat(3,1) ) + + cmat(1,2) = cmat(1,2) + & + scal * ( amat(1,1) * bmat(1,2) & + + amat(1,2) * bmat(2,2) & + + amat(1,3) * bmat(3,2) ) + cmat(2,2) = cmat(2,2) + & + scal * ( amat(2,1) * bmat(1,2) & + + amat(2,2) * bmat(2,2) & + + amat(2,3) * bmat(3,2) ) + cmat(3,2) = cmat(3,2) + & + scal * ( amat(3,1) * bmat(1,2) & + + amat(3,2) * bmat(2,2) & + + amat(3,3) * bmat(3,2) ) + + cmat(1,3) = cmat(1,3) + & + scal * ( amat(1,1) * bmat(1,3) & + + amat(1,2) * bmat(2,3) & + + amat(1,3) * bmat(3,3) ) + cmat(2,3) = cmat(2,3) + & + scal * ( amat(2,1) * bmat(1,3) & + + amat(2,2) * bmat(2,3) & + + amat(2,3) * bmat(3,3) ) + cmat(3,3) = cmat(3,3) + & + scal * ( amat(3,1) * bmat(1,3) & + + amat(3,2) * bmat(2,3) & + + amat(3,3) * bmat(3,3) ) + + end if + + return + + end subroutine + + pure subroutine slv_2x2(amat,adim,vrhs,vdim, & + & nrhs,fEPS,okay) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: vdim + real*8 , intent(inout) :: vrhs(vdim,*) + integer, intent(in) :: nrhs + real*8 , intent(in) :: fEPS + logical, intent(inout) :: okay + + !------------------------------------------- variables ! + real*8 :: ainv(2,2) + real*8 :: adet + real*8 :: vtmp( 2) + integer :: irhs + + integer, parameter :: LDIM = 2 + + !---------------------------------------- calc. inv(A) ! + + call inv_2x2(amat,adim,ainv,LDIM,& + adet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !---------------------------------------- v = A^-1 * v ! + + do irhs = 1, nrhs + + vtmp(1) = & + + ( & + ainv(1, 1) * vrhs(1,irhs) & + + ainv(1, 2) * vrhs(2,irhs) & + ) / adet + + vtmp(2) = & + + ( & + ainv(2, 1) * vrhs(1,irhs) & + + ainv(2, 2) * vrhs(2,irhs) & + ) / adet + + vrhs(1,irhs) = vtmp(1) + vrhs(2,irhs) = vtmp(2) + + end do + + return + + end subroutine + + pure subroutine slv_3x3(amat,adim,vrhs,vdim, & + & nrhs,fEPS,okay) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: vdim + real*8 , intent(inout) :: vrhs(vdim,*) + integer, intent(in) :: nrhs + real*8 , intent(in) :: fEPS + logical, intent(inout) :: okay + + !------------------------------------------- variables ! + real*8 :: ainv(3,3) + real*8 :: adet + real*8 :: vtmp( 3) + integer :: irhs + + integer, parameter :: LDIM = 3 + + !---------------------------------------- calc. inv(A) ! + + call inv_3x3(amat,adim,ainv,LDIM,& + adet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !---------------------------------------- v = A^-1 * v ! + + do irhs = 1, nrhs + + vtmp(1) = & + + ( & + ainv(1, 1) * vrhs(1,irhs) & + + ainv(1, 2) * vrhs(2,irhs) & + + ainv(1, 3) * vrhs(3,irhs) & + ) / adet + + vtmp(2) = & + + ( & + ainv(2, 1) * vrhs(1,irhs) & + + ainv(2, 2) * vrhs(2,irhs) & + + ainv(2, 3) * vrhs(3,irhs) & + ) / adet + + vtmp(3) = & + + ( & + ainv(3, 1) * vrhs(1,irhs) & + + ainv(3, 2) * vrhs(2,irhs) & + + ainv(3, 3) * vrhs(3,irhs) & + ) / adet + + vrhs(1,irhs) = vtmp(1) + vrhs(2,irhs) = vtmp(2) + vrhs(3,irhs) = vtmp(3) + + end do + + return + + end subroutine + + pure subroutine slv_4x4(amat,adim,vrhs,vdim, & + & nrhs,fEPS,okay) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: vdim + real*8 , intent(inout) :: vrhs(vdim,*) + integer, intent(in) :: nrhs + real*8 , intent(in) :: fEPS + logical, intent(inout) :: okay + + !------------------------------------------- variables ! + real*8 :: ainv(2,2) + real*8 :: lmat(2,2) + real*8 :: umat(2,2) + real*8 :: smat(2,2) + real*8 :: sinv(2,2) + real*8 :: adet,sdet + real*8 :: vtmp( 2) + integer :: irhs + + integer, parameter :: LDIM = 2 + + !---------------------- form a block LDU factorisation ! + + call inv_2x2(amat(1,1),adim,ainv,LDIM, & + adet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !---------------------------------------- L = C * A^-1 ! + + lmat(1,1) = +0.e0 + lmat(1,2) = +0.e0 + lmat(2,1) = +0.e0 + lmat(2,2) = +0.e0 + + call mul_2x2(amat(3,1),adim,ainv,LDIM, & + +1.e0,lmat,LDIM) + + !---------------------------------------- U = A^-1 * B ! + + umat(1,1) = +0.e0 + umat(1,2) = +0.e0 + umat(2,1) = +0.e0 + umat(2,2) = +0.e0 + + call mul_2x2(ainv,LDIM,amat(1,3),adim, & + +1.e0,umat,LDIM) + + !-------------------------------- S = D - C * A^-1 * B ! + + smat(1,1) = amat(3,3) + smat(1,2) = amat(3,4) + smat(2,1) = amat(4,3) + smat(2,2) = amat(4,4) + + call mul_2x2(lmat,LDIM,amat(1,3),adim, & + -1.e0/adet,smat,LDIM) + + call inv_2x2(smat,LDIM,sinv,LDIM,sdet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !-------------------------------- back-solve LDU = rhs ! + + do irhs = 1, nrhs + + !---------------------------------------- solve L part ! + + vrhs(3,irhs) = vrhs(3,irhs) & + - ( & + lmat(1, 1) * vrhs(1,irhs) & + + lmat(1, 2) * vrhs(2,irhs) & + ) / adet + + vrhs(4,irhs) = vrhs(4,irhs) & + - ( & + lmat(2, 1) * vrhs(1,irhs) & + + lmat(2, 2) * vrhs(2,irhs) & + ) / adet + + !---------------------------------------- solve D part ! + + vtmp(1) = & + + ( & + ainv(1, 1) * vrhs(1,irhs) & + + ainv(1, 2) * vrhs(2,irhs) & + ) / adet + + vtmp(2) = & + + ( & + ainv(2, 1) * vrhs(1,irhs) & + + ainv(2, 2) * vrhs(2,irhs) & + ) / adet + + vrhs(1,irhs) = vtmp(1) + vrhs(2,irhs) = vtmp(2) + + vtmp(1) = & + + ( & + sinv(1, 1) * vrhs(3,irhs) & + + sinv(1, 2) * vrhs(4,irhs) & + ) / sdet + + vtmp(2) = & + + ( & + sinv(2, 1) * vrhs(3,irhs) & + + sinv(2, 2) * vrhs(4,irhs) & + ) / sdet + + vrhs(3,irhs) = vtmp(1) + vrhs(4,irhs) = vtmp(2) + + !---------------------------------------- solve U part ! + + vrhs(1,irhs) = vrhs(1,irhs) & + - ( & + umat(1, 1) * vrhs(3,irhs) & + + umat(1, 2) * vrhs(4,irhs) & + ) / adet + + vrhs(2,irhs) = vrhs(2,irhs) & + - ( & + umat(2, 1) * vrhs(3,irhs) & + + umat(2, 2) * vrhs(4,irhs) & + ) / adet + + end do + + return + + end subroutine + + pure subroutine slv_6x6(amat,adim,vrhs,vdim, & + & nrhs,fEPS,okay) + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: adim + real*8 , intent(in) :: amat(adim,*) + integer, intent(in) :: vdim + real*8 , intent(inout) :: vrhs(vdim,*) + integer, intent(in) :: nrhs + real*8 , intent(in) :: fEPS + logical, intent(inout) :: okay + + !------------------------------------------- variables ! + real*8 :: ainv(3,3) + real*8 :: lmat(3,3) + real*8 :: umat(3,3) + real*8 :: smat(3,3) + real*8 :: sinv(3,3) + real*8 :: adet,sdet + real*8 :: vtmp( 3) + integer :: irhs + + integer, parameter :: LDIM = 3 + + !---------------------- form a block LDU factorisation ! + + call inv_3x3(amat(1,1),adim,ainv,LDIM, & + adet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !---------------------------------------- L = C * A^-1 ! + + lmat(1,1) = +0.e0 + lmat(1,2) = +0.e0 + lmat(1,3) = +0.e0 + lmat(2,1) = +0.e0 + lmat(2,2) = +0.e0 + lmat(2,3) = +0.e0 + lmat(3,1) = +0.e0 + lmat(3,2) = +0.e0 + lmat(3,3) = +0.e0 + + call mul_3x3(amat(4,1),adim,ainv,LDIM, & + +1.e0,lmat,LDIM) + + !---------------------------------------- U = A^-1 * B ! + + umat(1,1) = +0.e0 + umat(1,2) = +0.e0 + umat(1,3) = +0.e0 + umat(2,1) = +0.e0 + umat(2,2) = +0.e0 + umat(2,3) = +0.e0 + umat(3,1) = +0.e0 + umat(3,2) = +0.e0 + umat(3,3) = +0.e0 + + call mul_3x3(ainv,LDIM,amat(1,4),adim, & + +1.e0,umat,LDIM) + + !-------------------------------- S = D - C * A^-1 * B ! + + smat(1,1) = amat(4,4) + smat(1,2) = amat(4,5) + smat(1,3) = amat(4,6) + smat(2,1) = amat(5,4) + smat(2,2) = amat(5,5) + smat(2,3) = amat(5,6) + smat(3,1) = amat(6,4) + smat(3,2) = amat(6,5) + smat(3,3) = amat(6,6) + + call mul_3x3(lmat,LDIM,amat(1,4),adim, & + -1.e0/adet,smat,LDIM) + + call inv_3x3(smat,LDIM,sinv,LDIM,sdet) + + okay = (abs(adet) .gt. fEPS) + + if (okay.eqv..false.) return + + !-------------------------------- back-solve LDU = rhs ! + + do irhs = 1, nrhs + + !---------------------------------------- solve L part ! + + vrhs(4,irhs) = vrhs(4,irhs) & + - ( & + lmat(1, 1) * vrhs(1,irhs) & + + lmat(1, 2) * vrhs(2,irhs) & + + lmat(1, 3) * vrhs(3,irhs) & + ) / adet + + vrhs(5,irhs) = vrhs(5,irhs) & + - ( & + lmat(2, 1) * vrhs(1,irhs) & + + lmat(2, 2) * vrhs(2,irhs) & + + lmat(2, 3) * vrhs(3,irhs) & + ) / adet + + vrhs(6,irhs) = vrhs(6,irhs) & + - ( & + lmat(3, 1) * vrhs(1,irhs) & + + lmat(3, 2) * vrhs(2,irhs) & + + lmat(3, 3) * vrhs(3,irhs) & + ) / adet + + !---------------------------------------- solve D part ! + + vtmp(1) = & + + ( & + ainv(1, 1) * vrhs(1,irhs) & + + ainv(1, 2) * vrhs(2,irhs) & + + ainv(1, 3) * vrhs(3,irhs) & + ) / adet + + vtmp(2) = & + + ( & + ainv(2, 1) * vrhs(1,irhs) & + + ainv(2, 2) * vrhs(2,irhs) & + + ainv(2, 3) * vrhs(3,irhs) & + ) / adet + + vtmp(3) = & + + ( & + ainv(3, 1) * vrhs(1,irhs) & + + ainv(3, 2) * vrhs(2,irhs) & + + ainv(3, 3) * vrhs(3,irhs) & + ) / adet + + vrhs(1,irhs) = vtmp(1) + vrhs(2,irhs) = vtmp(2) + vrhs(3,irhs) = vtmp(3) + + vtmp(1) = & + + ( & + sinv(1, 1) * vrhs(4,irhs) & + + sinv(1, 2) * vrhs(5,irhs) & + + sinv(1, 3) * vrhs(6,irhs) & + ) / sdet + + vtmp(2) = & + + ( & + sinv(2, 1) * vrhs(4,irhs) & + + sinv(2, 2) * vrhs(5,irhs) & + + sinv(2, 3) * vrhs(6,irhs) & + ) / sdet + + vtmp(3) = & + + ( & + sinv(3, 1) * vrhs(4,irhs) & + + sinv(3, 2) * vrhs(5,irhs) & + + sinv(3, 3) * vrhs(6,irhs) & + ) / sdet + + vrhs(4,irhs) = vtmp(1) + vrhs(5,irhs) = vtmp(2) + vrhs(6,irhs) = vtmp(3) + + !---------------------------------------- solve U part ! + + vrhs(1,irhs) = vrhs(1,irhs) & + - ( & + umat(1, 1) * vrhs(4,irhs) & + + umat(1, 2) * vrhs(5,irhs) & + + umat(1, 3) * vrhs(6,irhs) & + ) / adet + + vrhs(2,irhs) = vrhs(2,irhs) & + - ( & + umat(2, 1) * vrhs(4,irhs) & + + umat(2, 2) * vrhs(5,irhs) & + + umat(2, 3) * vrhs(6,irhs) & + ) / adet + + vrhs(3,irhs) = vrhs(3,irhs) & + - ( & + umat(3, 1) * vrhs(4,irhs) & + + umat(3, 2) * vrhs(5,irhs) & + + umat(3, 3) * vrhs(6,irhs) & + ) / adet + + end do + + return + + end subroutine + + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! PBC.h90: setup polynomial B.C.'s at domain endpoints. + ! + ! Darren Engwirda + ! 09-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine pbc(npos,nvar,ndof,delx, & + & fdat,bcon,edge,dfdx, & + & iend,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCON boundary condition data for endpoint . + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! IEND domain endpoint, IEND < +0 for lower end-point + ! and IEND > +0 for upper endpoint . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + integer, intent( in) :: iend + real*8 , intent( in) :: dmin + type(rcon_ends), intent(in) :: bcon(:) + + !------------------------------------------- variables ! + integer :: ivar,nlse,nval,nslp + + nlse = 0 ; nval = 0 ; nslp = 0 + + do ivar = +1, nvar + + select case (bcon(ivar)%bcopt) + !------------------------------------------- find BC's ! + case(bcon_loose) + nlse = nlse + 1 + + case(bcon_value) + nval = nval + 1 + + case(bcon_slope) + nslp = nslp + 1 + + end select + + end do + + !---------------------------- setup "lower" conditions ! + + if (iend.lt.+0) then + + if (nlse.gt.+0) then + !---------------------------- setup "unset" conditions ! + call lbc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_loose , & + & edge,dfdx,dmin) + + end if + + if (nval.gt.+0) then + !---------------------------- setup "value" conditions ! + call lbc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_value , & + & edge,dfdx,dmin) + + end if + + if (nslp.gt.+0) then + !---------------------------- setup "slope" conditions ! + call lbc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_slope , & + & edge,dfdx,dmin) + + end if + + end if + + !---------------------------- setup "upper" conditions ! + + if (iend.gt.+0) then + + if (nlse.gt.+0) then + !---------------------------- setup "unset" conditions ! + call ubc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_loose , & + & edge,dfdx,dmin) + + end if + + if (nval.gt.+0) then + !---------------------------- setup "value" conditions ! + call ubc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_value , & + & edge,dfdx,dmin) + + end if + + if (nslp.gt.+0) then + !---------------------------- setup "slope" conditions ! + call ubc(npos,nvar,ndof, & + & delx,fdat,bcon, & + & bcon_slope , & + & edge,dfdx,dmin) + + end if + + end if + + return + + end subroutine + + ! LBC: impose a single B.C.-type at the lower endpoint ! + + subroutine lbc(npos,nvar,ndof,delx, & + & fdat,bcon,bopt,edge, & + & dfdx,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCON boundary condition data for endpoint . + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + integer, intent( in) :: bopt + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + real*8 , intent( in) :: dmin + type(rcon_ends), intent(in) :: bcon(:) + + !------------------------------------------- variables ! + integer :: ivar,idof,isel, & + & head,tail,nsel + logical :: okay + real*8 :: xhat + real*8 :: delh(-1:+1) + real*8 :: xmap(-1:+2) + real*8 :: bvec(+3,-1:+2) + real*8 :: gvec(+3,-1:+2) + real*8 :: cmat(+3,+3) + real*8 :: fhat(+3, nvar) + real*8 :: eval(-1:+2) + real*8 :: gval(-1:+2) + + integer, parameter :: NSIZ = +3 + real*8 , parameter :: ZERO = +1.e-14 + + head = +2; tail = npos - 2 + + if (size(delx).gt.+1) then + + !------------------ mean grid spacing about ii-th cell ! + + xhat = max(delx(head),dmin) * 0.5d+0 + + !------------------ grid spacing for all stencil cells ! + + delh(-1) = delx(head-1) + delh(+0) = delx(head+0) + delh(+1) = delx(head+1) + + else + + !------------------ mean grid spacing about ii-th cell ! + + xhat = max(delx( +1),dmin) * 0.5d+0 + + !------------------ grid spacing for all stencil cells ! + + delh(-1) = delx( +1) + delh(+0) = delx( +1) + delh(+1) = delx( +1) + + end if + + !---------- local coordinate mapping for stencil edges ! + + xmap(-1) =-(delh(-1) + & + & delh(+0)*0.5d0)/xhat + xmap(+0) = -1.e0 + xmap(+1) = +1.e0 + xmap(+2) = (delh(+1) + & + & delh(+0)*0.5d0)/xhat + + !------------ linear system: lhs reconstruction matrix ! + + select case(bopt ) + case( bcon_loose ) + + call bfun1d(-1,+3,xmap(-1),bvec(:,-1)) + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + call bfun1d(-1,+3,xmap(+2),bvec(:,+2)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+0) & + & - bvec(idof,-1) + cmat(2,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + cmat(3,idof) = bvec(idof,+2) & + & - bvec(idof,+1) + + end do + + case( bcon_value ) + + call bfun1d(+0,+3,xmap(-1),gvec(:,-1)) + + call bfun1d(-1,+3,xmap(-1),bvec(:,-1)) + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+0) & + & - bvec(idof,-1) + cmat(2,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + + cmat(3,idof) = gvec(idof,-1) + + end do + + case( bcon_slope ) + + call bfun1d(+1,+3,xmap(-1),gvec(:,-1)) + + call bfun1d(-1,+3,xmap(-1),bvec(:,-1)) + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+0) & + & - bvec(idof,-1) + cmat(2,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + + cmat(3,idof) = gvec(idof,-1) + + end do + + end select + + !------------ linear system: rhs reconstruction vector ! + + isel = 0 ; nsel = 0 + + select case( bopt ) + case ( bcon_loose ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_loose) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(-1) * & + & fdat(1,ivar,head-1) / xhat + fhat(2,isel) = delh(+0) * & + & fdat(1,ivar,head+0) / xhat + fhat(3,isel) = delh(+1) * & + & fdat(1,ivar,head+1) / xhat + + end if + + end do + + case ( bcon_value ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_value) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(-1) * & + & fdat(1,ivar,head-1) / xhat + fhat(2,isel) = delh(+0) * & + & fdat(1,ivar,head+0) / xhat + + fhat(3,isel) = bcon(ivar)%value + + end if + + end do + + case ( bcon_slope ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_slope) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(-1) * & + & fdat(1,ivar,head-1) / xhat + fhat(2,isel) = delh(+0) * & + & fdat(1,ivar,head+0) / xhat + + fhat(3,isel) = & + & bcon(ivar)%slope * xhat + + end if + + end do + + end select + + !------------------------- factor/solve linear systems ! + + call slv_3x3(cmat,NSIZ,fhat , & + & NSIZ,nvar, & + & ZERO*dmin,okay) + + if (okay .eqv..false.) then + + + end if + + if (okay .eqv. .true.) then + + !------------- extrapolate values/slopes at lower edge ! + + isel = +0 + + call bfun1d(+0,+3,xmap(-1),bvec(:,-1)) + call bfun1d(+0,+3,xmap(+0),bvec(:,+0)) + call bfun1d(+0,+3,xmap(+1),bvec(:,+1)) + + call bfun1d(+1,+3,xmap(-1),gvec(:,-1)) + call bfun1d(+1,+3,xmap(+0),gvec(:,+0)) + call bfun1d(+1,+3,xmap(+1),gvec(:,+1)) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bopt) then + + isel = isel + 1 + + eval(-1) = dot_product( & + & bvec(:,-1),fhat(:,isel)) + eval(+0) = dot_product( & + & bvec(:,+0),fhat(:,isel)) + eval(+1) = dot_product( & + & bvec(:,+1),fhat(:,isel)) + + gval(-1) = dot_product( & + & gvec(:,-1),fhat(:,isel)) + gval(+0) = dot_product( & + & gvec(:,+0),fhat(:,isel)) + gval(+1) = dot_product( & + & gvec(:,+1),fhat(:,isel)) + + edge(ivar,head-1) = eval(-1) + edge(ivar,head+0) = eval(+0) + edge(ivar,head+1) = eval(+1) + + dfdx(ivar,head-1) = gval(-1) & + & / xhat + dfdx(ivar,head+0) = gval(+0) & + & / xhat + dfdx(ivar,head+1) = gval(+1) & + & / xhat + + end if + + end do + + else + + !------------- low-order if re-con. matrix is singular ! + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bopt) then + + eval(-1) = & + & fdat(1,ivar,head-1) * 1.e0 + eval(+0) = & + & fdat(1,ivar,head-1) * .5d0 + & + & fdat(1,ivar,head+0) * .5d0 + eval(+1) = & + & fdat(1,ivar,head+0) * .5d0 + & + & fdat(1,ivar,head+1) * .5d0 + + gval(-1) = & + & fdat(1,ivar,head+0) * .5d0 - & + & fdat(1,ivar,head-1) * .5d0 + gval(+0) = & + & fdat(1,ivar,head+0) * .5d0 - & + & fdat(1,ivar,head-1) * .5d0 + gval(+1) = & + & fdat(1,ivar,head+1) * .5d0 - & + & fdat(1,ivar,head+0) * .5d0 + + edge(ivar,head-1) = eval(-1) + edge(ivar,head+0) = eval(+0) + edge(ivar,head+1) = eval(+1) + + dfdx(ivar,head-1) = gval(-1) & + & / xhat + dfdx(ivar,head+0) = gval(+0) & + & / xhat + dfdx(ivar,head+1) = gval(+1) & + & / xhat + + end if + + end do + + end if + + return + + end subroutine + + ! UBC: impose a single B.C.-type at the upper endpoint ! + + subroutine ubc(npos,nvar,ndof,delx, & + & fdat,bcon,bopt,edge, & + & dfdx,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCON boundary condition data for endpoint . + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + integer, intent( in) :: bopt + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + real*8 , intent( in) :: dmin + type(rcon_ends), intent(in) :: bcon(:) + + !------------------------------------------- variables ! + integer :: ivar,idof,isel, & + & head,tail,nsel + logical :: okay + real*8 :: xhat + real*8 :: delh(-1:+1) + real*8 :: xmap(-1:+2) + real*8 :: bvec(+3,-1:+2) + real*8 :: gvec(+3,-1:+2) + real*8 :: cmat(+3,+3) + real*8 :: fhat(+3, nvar) + real*8 :: eval(-1:+2) + real*8 :: gval(-1:+2) + + integer, parameter :: NSIZ = +3 + real*8 , parameter :: ZERO = +1.e-14 + + head = +2; tail = npos - 2 + + if (size(delx).gt.+1) then + + !------------------ mean grid spacing about ii-th cell ! + + xhat = max(delx(tail),dmin) * 0.5d+0 + + !------------------ grid spacing for all stencil cells ! + + delh(-1) = delx(tail-1) + delh(+0) = delx(tail+0) + delh(+1) = delx(tail+1) + + else + + !------------------ mean grid spacing about ii-th cell ! + + xhat = max(delx( +1),dmin) * 0.5d+0 + + !------------------ grid spacing for all stencil cells ! + + delh(-1) = delx( +1) + delh(+0) = delx( +1) + delh(+1) = delx( +1) + + end if + + !---------- local coordinate mapping for stencil edges ! + + xmap(-1) =-(delh(-1) + & + & delh(+0)*0.5d0)/xhat + xmap(+0) = -1.e0 + xmap(+1) = +1.e0 + xmap(+2) = (delh(+1) + & + & delh(+0)*0.5d0)/xhat + + !------------ linear system: lhs reconstruction matrix ! + + select case(bopt ) + case( bcon_loose ) + + call bfun1d(-1,+3,xmap(-1),bvec(:,-1)) + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + call bfun1d(-1,+3,xmap(+2),bvec(:,+2)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+0) & + & - bvec(idof,-1) + cmat(2,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + cmat(3,idof) = bvec(idof,+2) & + & - bvec(idof,+1) + + end do + + case( bcon_value ) + + call bfun1d(+0,+3,xmap(+2),gvec(:,+2)) + + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + call bfun1d(-1,+3,xmap(+2),bvec(:,+2)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + cmat(2,idof) = bvec(idof,+2) & + & - bvec(idof,+1) + + cmat(3,idof) = gvec(idof,+2) + + end do + + case( bcon_slope ) + + call bfun1d(+1,+3,xmap(+2),gvec(:,+2)) + + call bfun1d(-1,+3,xmap(+0),bvec(:,+0)) + call bfun1d(-1,+3,xmap(+1),bvec(:,+1)) + call bfun1d(-1,+3,xmap(+2),bvec(:,+2)) + + do idof = +1 , +3 + + cmat(1,idof) = bvec(idof,+1) & + & - bvec(idof,+0) + cmat(2,idof) = bvec(idof,+2) & + & - bvec(idof,+1) + + cmat(3,idof) = gvec(idof,+2) + + end do + + end select + + !------------ linear system: rhs reconstruction vector ! + + isel = 0 ; nsel = 0 + + select case( bopt ) + case ( bcon_loose ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_loose) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(-1) * & + & fdat(1,ivar,tail-1) / xhat + fhat(2,isel) = delh(+0) * & + & fdat(1,ivar,tail+0) / xhat + fhat(3,isel) = delh(+1) * & + & fdat(1,ivar,tail+1) / xhat + + end if + + end do + + case ( bcon_value ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_value) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(+0) * & + & fdat(1,ivar,tail+0) / xhat + fhat(2,isel) = delh(+1) * & + & fdat(1,ivar,tail+1) / xhat + + fhat(3,isel) = bcon(ivar)%value + + end if + + end do + + case ( bcon_slope ) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bcon_slope) then + + isel = isel + 1 + nsel = nsel + 1 + + fhat(1,isel) = delh(+0) * & + & fdat(1,ivar,tail+0) / xhat + fhat(2,isel) = delh(+1) * & + & fdat(1,ivar,tail+1) / xhat + + fhat(3,isel) = & + & bcon(ivar)%slope * xhat + + end if + + end do + + end select + + !------------------------- factor/solve linear systems ! + + call slv_3x3(cmat,NSIZ,fhat , & + & NSIZ,nvar, & + & ZERO*dmin,okay) + + if (okay .eqv..false.) then + + + end if + + if (okay .eqv. .true.) then + + !------------- extrapolate values/slopes at lower edge ! + + isel = +0 + + call bfun1d(+0,+3,xmap(+0),bvec(:,+0)) + call bfun1d(+0,+3,xmap(+1),bvec(:,+1)) + call bfun1d(+0,+3,xmap(+2),bvec(:,+2)) + + call bfun1d(+1,+3,xmap(+0),gvec(:,+0)) + call bfun1d(+1,+3,xmap(+1),gvec(:,+1)) + call bfun1d(+1,+3,xmap(+2),gvec(:,+2)) + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bopt) then + + isel = isel + 1 + + eval(+0) = dot_product( & + & bvec(:,+0),fhat(:,isel)) + eval(+1) = dot_product( & + & bvec(:,+1),fhat(:,isel)) + eval(+2) = dot_product( & + & bvec(:,+2),fhat(:,isel)) + + gval(+0) = dot_product( & + & gvec(:,+0),fhat(:,isel)) + gval(+1) = dot_product( & + & gvec(:,+1),fhat(:,isel)) + gval(+2) = dot_product( & + & gvec(:,+2),fhat(:,isel)) + + edge(ivar,tail+0) = eval(+0) + edge(ivar,tail+1) = eval(+1) + edge(ivar,tail+2) = eval(+2) + + dfdx(ivar,tail+0) = gval(+0) & + & / xhat + dfdx(ivar,tail+1) = gval(+1) & + & / xhat + dfdx(ivar,tail+2) = gval(+2) & + & / xhat + + end if + + end do + + else + + !------------- low-order if re-con. matrix is singular ! + + do ivar = +1, nvar + + if (bcon(ivar)%bcopt.eq.bopt) then + + eval(+0) = & + & fdat(1,ivar,tail-1) * .5d0 + & + & fdat(1,ivar,tail+0) * .5d0 + eval(+1) = & + & fdat(1,ivar,tail+0) * .5d0 + & + & fdat(1,ivar,tail+1) * .5d0 + eval(+2) = & + & fdat(1,ivar,tail+1) * 1.e0 + + gval(+0) = & + & fdat(1,ivar,tail+0) * .5d0 - & + & fdat(1,ivar,tail-1) * .5d0 + gval(+1) = & + & fdat(1,ivar,tail+1) * .5d0 - & + & fdat(1,ivar,tail+0) * .5d0 + gval(+2) = & + & fdat(1,ivar,tail+1) * .5d0 - & + & fdat(1,ivar,tail+0) * .5d0 + + edge(ivar,tail+0) = eval(+0) + edge(ivar,tail+1) = eval(+1) + edge(ivar,tail+2) = eval(+2) + + dfdx(ivar,tail+0) = gval(+0) & + & / xhat + dfdx(ivar,tail+1) = gval(+1) & + & / xhat + dfdx(ivar,tail+2) = gval(+2) & + & / xhat + + end if + + end do + + end if + + return + + end subroutine + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! P1E.h90: set edge estimates via degree-1 polynomials. + ! + ! Darren Engwirda + ! 09-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine p1e(npos,nvar,ndof,delx, & + & fdat,bclo,bchi,edge, & + & dfdx,opts,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCLO boundary condition at lower endpoint. + ! BCHI boundary condition at upper endpoint. + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! OPTS method parameters. See RCON-OPTS for details . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + type (rcon_ends), intent(in) :: bclo(:) + type (rcon_ends), intent(in) :: bchi(:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + real*8 , intent( in) :: dmin + class(rcon_opts), intent(in) :: opts + + !------------------------------------------- variables ! + integer :: ipos,ivar,head,tail + real*8 :: dd10 + real*8 :: delh(-1:+0) + + head = +2; tail = npos-1 + + if (npos.lt.2) return + if (npos.eq.2) then + !----- default to reduced order if insufficient points ! + do ivar = 1,nvar + + edge(ivar,1) = fdat(1,ivar,1) + dfdx(ivar,1) = 0.e0 + + edge(ivar,2) = fdat(1,ivar,1) + dfdx(ivar,2) = 0.e0 + + end do + end if + + if (npos.le.2) return + + ! Reconstruct edge-centred 2nd-order polynomials. Com- ! + ! pute values/slopes at edges directly. Full-order ex- ! + ! trapolation at endpoints. + + if (size(delx).eq.+1) then + + do ipos = head , tail + + !--------------- reconstruction: constant grid-spacing ! + + dd10 = delx(+1) * 2.e0 + + do ivar = +1, nvar + + edge(ivar,ipos) = & + & + delx(+1) * & + & fdat(1,ivar,ipos-1) & + & + delx(+1) * & + & fdat(1,ivar,ipos+0) + + dfdx(ivar,ipos) = & + & - 2.0d+0 * & + & fdat(1,ivar,ipos-1) & + & + 2.0d+0 * & + & fdat(1,ivar,ipos+0) + + edge(ivar,ipos) = & + & edge(ivar,ipos) / dd10 + dfdx(ivar,ipos) = & + & dfdx(ivar,ipos) / dd10 + + end do + + end do + + else + + do ipos = head , tail + + !--------------- reconstruction: variable grid-spacing ! + + delh(-1) = & + & max(delx(ipos-1),dmin) + delh(+0) = & + & max(delx(ipos+0),dmin) + + dd10 = delh(-1)+delh(+0) + + do ivar = +1, nvar + + edge(ivar,ipos) = & + & + delh(+0) * & + & fdat(1,ivar,ipos-1) & + & + delh(-1) * & + & fdat(1,ivar,ipos+0) + + dfdx(ivar,ipos) = & + & - 2.0d+0 * & + & fdat(1,ivar,ipos-1) & + & + 2.0d+0 * & + & fdat(1,ivar,ipos+0) + + edge(ivar,ipos) = & + & edge(ivar,ipos) / dd10 + dfdx(ivar,ipos) = & + & dfdx(ivar,ipos) / dd10 + + end do + + end do + + end if + + !------------- 1st-order value/slope BC's at endpoints ! + + do ivar = +1, nvar + + edge(ivar,head-1) = & + & fdat(+1,ivar,head-1) + edge(ivar,tail+1) = & + & fdat(+1,ivar,tail+0) + + dfdx(ivar,head-1) = 0.e0 + dfdx(ivar,tail+1) = 0.e0 + + end do + + return + + end subroutine + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! P3E.h90: set edge estimates via degree-3 polynomials. + ! + ! Darren Engwirda + ! 09-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine p3e(npos,nvar,ndof,delx, & + & fdat,bclo,bchi,edge, & + & dfdx,opts,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCLO boundary condition at lower endpoint. + ! BCHI boundary condition at upper endpoint. + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! OPTS method parameters. See RCON-OPTS for details . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + type (rcon_ends), intent(in) :: bclo(:) + type (rcon_ends), intent(in) :: bchi(:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + real*8 , intent( in) :: dmin + class(rcon_opts), intent(in) :: opts + + !------------------------------------------- variables ! + integer :: ipos,ivar,idof,head,tail + logical :: okay + real*8 :: xhat,fEPS + real*8 :: delh(-2:+1) + real*8 :: xmap(-2:+2) + real*8 :: fhat(+4, nvar) + real*8 :: ivec(+4,-2:+2) + real*8 :: cmat(+4,+4) + + integer, parameter :: NSIZ = +4 + real*8 , parameter :: ZERO = 1.e-14 + + head = +3 ; tail = npos - 2 + + if (npos.le.4) then + !----- default to reduced order if insufficient points ! + call p1e (npos,nvar,ndof, & + & delx,fdat,bclo, & + & bchi,edge,dfdx, & + & opts,dmin) + end if + + if (npos.le.4) return + + !------ impose value/slope B.C.'s about lower endpoint ! + + call pbc(npos,nvar,ndof,delx, & + & fdat,bclo,edge,dfdx, & + & -1 ,dmin) + + !------ impose value/slope B.C.'s about upper endpoint ! + + call pbc(npos,nvar,ndof,delx, & + & fdat,bchi,edge,dfdx, & + & +1 ,dmin) + + ! Reconstruct edge-centred 4th-order polynomials. Com- ! + ! pute values/slopes at edges directly. Mid.-order ex- ! + ! trapolation at endpoints. ! + + if (size(delx).eq.+1) then + + do ipos = head , tail + + !--------------- reconstruction: constant grid-spacing ! + + do ivar = 1, nvar + + edge(ivar,ipos) = ( & + & - 1.e0 * & + & fdat(1,ivar,ipos-2) & + & + 7.e0 * & + & fdat(1,ivar,ipos-1) & + & + 7.e0 * & + & fdat(1,ivar,ipos+0) & + & - 1.e0 * & + & fdat(1,ivar,ipos+1) ) / 12.e0 + + dfdx(ivar,ipos) = ( & + & + 1.e0 * & + & fdat(1,ivar,ipos-2) & + & - 15.e0 * & + & fdat(1,ivar,ipos-1) & + & + 15.e0 * & + & fdat(1,ivar,ipos+0) & + & - 1.e0 * & + & fdat(1,ivar,ipos+1) ) / 12.e0 + + dfdx(ivar,ipos) = & + & dfdx(ivar,ipos) / delx(+1) + + end do + + end do + + else + + fEPS = ZERO * dmin + + do ipos = head , tail + + !--------------- reconstruction: variable grid-spacing ! + + delh(-2) = delx(ipos-2) + delh(-1) = delx(ipos-1) + delh(+0) = delx(ipos+0) + delh(+1) = delx(ipos+1) + + xhat = .5d0 * max(delh(-1),dmin) + & + & .5d0 * max(delh(+0),dmin) + + xmap(-2) = -( delh(-2) & + & + delh(-1) ) / xhat + xmap(-1) = - delh(-1) / xhat + xmap(+0) = + 0.e0 + xmap(+1) = + delh(+0) / xhat + xmap(+2) = +( delh(+0) & + & + delh(+1) ) / xhat + + !--------------------------- calc. integral basis vec. ! + + do idof = -2, +2 + + ivec(1,idof) = & + & xmap(idof) ** 1 / 1.0d+0 + ivec(2,idof) = & + & xmap(idof) ** 2 / 2.0d+0 + ivec(3,idof) = & + & xmap(idof) ** 3 / 3.0d+0 + ivec(4,idof) = & + & xmap(idof) ** 4 / 4.0d+0 + + end do + + !--------------------------- linear system: lhs matrix ! + + do idof = +1, +4 + + cmat(1,idof) = ivec(idof,-1) & + & - ivec(idof,-2) + cmat(2,idof) = ivec(idof,+0) & + & - ivec(idof,-1) + cmat(3,idof) = ivec(idof,+1) & + & - ivec(idof,+0) + cmat(4,idof) = ivec(idof,+2) & + & - ivec(idof,+1) + + end do + + !--------------------------- linear system: rhs vector ! + + do ivar = +1, nvar + + fhat(+1,ivar) = & + & delx(ipos-2) * & + & fdat(+1,ivar,ipos-2) / xhat + fhat(+2,ivar) = & + & delx(ipos-1) * & + & fdat(+1,ivar,ipos-1) / xhat + fhat(+3,ivar) = & + & delx(ipos+0) * & + & fdat(+1,ivar,ipos+0) / xhat + fhat(+4,ivar) = & + & delx(ipos+1) * & + & fdat(+1,ivar,ipos+1) / xhat + + end do + + !------------------------- factor/solve linear systems ! + + call slv_4x4(cmat,NSIZ,fhat, & + & NSIZ,nvar,fEPS, & + & okay) + + if (okay .eqv. .true.) then + + do ivar = +1, nvar + + edge(ivar,ipos) = fhat(1,ivar) + + dfdx(ivar,ipos) = fhat(2,ivar) & + & / xhat + + end do + + else + + !------------------------- fallback if system singular ! + + + do ivar = +1, nvar + + edge(ivar,ipos) = & + & fdat(1,ivar,ipos-1) * 0.5d+0 + & + & fdat(1,ivar,ipos-0) * 0.5d+0 + + dfdx(ivar,ipos) = & + & fdat(1,ivar,ipos-0) * 1.0d+0 - & + & fdat(1,ivar,ipos-1) * 1.0d+0 + + dfdx(ivar,ipos) = & + & dfdx(ivar,ipos) / xhat + + end do + + end if + + end do + + end if + + return + + end subroutine + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! P5E.h90: set edge estimates via degree-5 polynomials. + ! + ! Darren Engwirda + ! 25-Mar-2019 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine p5e(npos,nvar,ndof,delx, & + & fdat,bclo,bchi,edge, & + & dfdx,opts,dmin) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! BCLO boundary condition at lower endpoint. + ! BCHI boundary condition at upper endpoint. + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! OPTS method parameters. See RCON-OPTS for details . + ! DMIN min. grid-cell spacing thresh . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent( in) :: delx(:) + real*8 , intent( in) :: fdat(:,:,:) + type (rcon_ends), intent(in) :: bclo(:) + type (rcon_ends), intent(in) :: bchi(:) + real*8 , intent(out) :: edge(:,:) + real*8 , intent(out) :: dfdx(:,:) + real*8 , intent( in) :: dmin + class(rcon_opts), intent(in) :: opts + + !------------------------------------------- variables ! + integer :: ipos,ivar,idof,head,tail + logical :: okay + real*8 :: xhat,fEPS + real*8 :: delh(-3:+2) + real*8 :: xmap(-3:+3) + real*8 :: fhat(+6, nvar) + real*8 :: ivec(+6,-3:+3) + real*8 :: cmat(+6,+6) + + integer, parameter :: NSIZ = +6 + real*8 , parameter :: ZERO = 1.e-14 + + head = +4 ; tail = npos - 3 + + if (npos.le.6) then + !----- default to reduced order if insufficient points ! + call p3e (npos,nvar,ndof, & + & delx,fdat,bclo, & + & bchi,edge,dfdx, & + & opts,dmin) + end if + + if (npos.le.6) return + + !------ impose value/slope B.C.'s about lower endpoint ! + + call pbc(npos,nvar,ndof,delx, & + & fdat,bclo,edge,dfdx, & + & -1 ,dmin) + + !------ impose value/slope B.C.'s about upper endpoint ! + + call pbc(npos,nvar,ndof,delx, & + & fdat,bchi,edge,dfdx, & + & +1 ,dmin) + + ! Reconstruct edge-centred 6th-order polynomials. Com- ! + ! pute values/slopes at edges directly. Mid.-order ex- ! + ! trapolation at endpoints. ! + + if (size(delx).eq.+1) then + + do ipos = head , tail + + !--------------- reconstruction: constant grid-spacing ! + + do ivar = 1, nvar + + edge(ivar,ipos) = & + & + ( 1.e0 / 60.e0) * & + & fdat(1,ivar,ipos-3) & + & - ( 8.e0 / 60.e0) * & + & fdat(1,ivar,ipos-2) & + & + (37.e0 / 60.e0) * & + & fdat(1,ivar,ipos-1) & + & + (37.e0 / 60.e0) * & + & fdat(1,ivar,ipos+0) & + & - ( 8.e0 / 60.e0) * & + & fdat(1,ivar,ipos+1) & + & + ( 1.e0 / 60.e0) * & + & fdat(1,ivar,ipos+2) + + dfdx(ivar,ipos) = & + & - ( 1.e0 / 90.e0) * & + & fdat(1,ivar,ipos-3) & + & + ( 5.e0 / 36.e0) * & + & fdat(1,ivar,ipos-2) & + & - (49.e0 / 36.e0) * & + & fdat(1,ivar,ipos-1) & + & + (49.e0 / 36.e0) * & + & fdat(1,ivar,ipos+0) & + & - ( 5.e0 / 36.e0) * & + & fdat(1,ivar,ipos+1) & + & + ( 1.e0 / 90.e0) * & + & fdat(1,ivar,ipos+2) + + dfdx(ivar,ipos) = & + dfdx(ivar,ipos) / delx(+1) + + end do + + end do + + else + + fEPS = ZERO * dmin + + do ipos = head , tail + + !--------------- reconstruction: variable grid-spacing ! + + delh(-3) = & + & max(delx(ipos-3),dmin) + delh(-2) = & + & max(delx(ipos-2),dmin) + delh(-1) = & + & max(delx(ipos-1),dmin) + delh(+0) = & + & max(delx(ipos+0),dmin) + delh(+1) = & + & max(delx(ipos+1),dmin) + delh(+2) = & + & max(delx(ipos+2),dmin) + + xhat = .5d0 * delh(-1) + & + & .5d0 * delh(+0) + + xmap(-3) = -( delh(-3) & + & + delh(-2) & + & + delh(-1) ) / xhat + xmap(-2) = -( delh(-2) & + & + delh(-1) ) / xhat + xmap(-1) = - delh(-1) / xhat + xmap(+0) = + 0.e0 + xmap(+1) = + delh(+0) / xhat + xmap(+2) = +( delh(+0) & + & + delh(+1) ) / xhat + xmap(+3) = +( delh(+0) & + & + delh(+1) & + & + delh(+2) ) / xhat + + !--------------------------- calc. integral basis vec. ! + + do idof = -3, +3 + + ivec(1,idof) = & + & xmap(idof) ** 1 / 1.0d+0 + ivec(2,idof) = & + & xmap(idof) ** 2 / 2.0d+0 + ivec(3,idof) = & + & xmap(idof) ** 3 / 3.0d+0 + ivec(4,idof) = & + & xmap(idof) ** 4 / 4.0d+0 + ivec(5,idof) = & + & xmap(idof) ** 5 / 5.0d+0 + ivec(6,idof) = & + & xmap(idof) ** 6 / 6.0d+0 + + end do + + !--------------------------- linear system: lhs matrix ! + + do idof = +1, +6 + + cmat(1,idof) = ivec(idof,-2) & + & - ivec(idof,-3) + cmat(2,idof) = ivec(idof,-1) & + & - ivec(idof,-2) + cmat(3,idof) = ivec(idof,+0) & + & - ivec(idof,-1) + cmat(4,idof) = ivec(idof,+1) & + & - ivec(idof,+0) + cmat(5,idof) = ivec(idof,+2) & + & - ivec(idof,+1) + cmat(6,idof) = ivec(idof,+3) & + & - ivec(idof,+2) + + end do + + !--------------------------- linear system: rhs vector ! + + do ivar = +1, nvar + + fhat(+1,ivar) = & + & delx(ipos-3) * & + & fdat(+1,ivar,ipos-3) / xhat + fhat(+2,ivar) = & + & delx(ipos-2) * & + & fdat(+1,ivar,ipos-2) / xhat + fhat(+3,ivar) = & + & delx(ipos-1) * & + & fdat(+1,ivar,ipos-1) / xhat + fhat(+4,ivar) = & + & delx(ipos+0) * & + & fdat(+1,ivar,ipos+0) / xhat + fhat(+5,ivar) = & + & delx(ipos+1) * & + & fdat(+1,ivar,ipos+1) / xhat + fhat(+6,ivar) = & + & delx(ipos+2) * & + & fdat(+1,ivar,ipos+2) / xhat + + end do + + !------------------------- factor/solve linear systems ! + + call slv_6x6(cmat,NSIZ,fhat, & + & NSIZ,nvar,fEPS, & + & okay) + + if (okay .eqv. .true.) then + + do ivar = +1, nvar + + edge(ivar,ipos) = fhat(1,ivar) + + dfdx(ivar,ipos) = fhat(2,ivar) & + & / xhat + + end do + + else + + !------------------------- fallback if system singular ! + + + do ivar = +1, nvar + + edge(ivar,ipos) = & + & fdat(1,ivar,ipos-1) * 0.5d+0 + & + & fdat(1,ivar,ipos-0) * 0.5d+0 + + dfdx(ivar,ipos) = & + & fdat(1,ivar,ipos-0) * 0.5d+0 - & + & fdat(1,ivar,ipos-1) * 0.5d+0 + + dfdx(ivar,ipos) = & + & dfdx(ivar,ipos) / xhat + + end do + + end if + + end do + + end if + + return + + end subroutine + + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! ROOT1D.h90: find the "roots" of degree-k polynomials. + ! + ! Darren Engwirda + ! 25-Mar-2019 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine roots_2(aa,bb,cc,xx,haveroot) + + ! + ! solve:: aa * xx**2 + bb * xx**1 + cc = +0.0 . + ! + + implicit none + + !------------------------------------------- arguments ! + real*8 , intent( in) :: aa,bb,cc + real*8 , intent(out) :: xx(1:2) + logical, intent(out) :: haveroot + + !------------------------------------------- variables ! + real*8 :: sq,ia,a0,b0,c0,x0 + + real*8, parameter :: rt = +1.e-14 + + a0 = abs(aa) + b0 = abs(bb) + c0 = abs(cc) + + sq = bb * bb - 4.0d+0 * aa * cc + + if (sq .ge. 0.0d+0) then + + sq = sqrt (sq) + + xx(1) = - bb + sq + xx(2) = - bb - sq + + x0 = max(abs(xx(1)), & + & abs(xx(2))) + + if (a0 .gt. (rt*x0)) then + + !-------------------------------------- degree-2 roots ! + + haveroot = .true. + + ia = 0.5d+0 / aa + + xx(1) = xx(1) * ia + xx(2) = xx(2) * ia + + else & + & if (b0 .gt. (rt*c0)) then + + !-------------------------------------- degree-1 roots ! + + haveroot = .true. + + xx(1) = - cc / bb + xx(2) = - cc / bb + + else + + haveroot = .false. + + end if + + else + + haveroot = .false. + + end if + + return + + end subroutine + + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! PCM.h90: 1d piecewise constant reconstruction . + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine pcm(npos,nvar,ndof,fdat, & + & fhat) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar,ndof + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + + !------------------------------------------- variables ! + integer:: ipos,ivar,idof + + do ipos = +1, npos - 1 + do ivar = +1, nvar + 0 + do idof = +1, ndof + 0 + + fhat(idof,ivar,ipos) = fdat(idof,ivar,ipos) + + end do + end do + end do + + return + + end subroutine + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! PLM.h90: a 1d, slope-limited piecewise linear method. + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + pure subroutine plm(npos,nvar,ndof,delx, & + & fdat,fhat,dmin,ilim) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! ILIM cell slope-limiting selection . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar + integer, intent( in) :: ndof,ilim + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(:) + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + + if (size(delx).gt.+1) then + + !------------------------------- variable grid-spacing ! + + call plmv(npos,nvar,ndof,delx,& + & fdat,fhat,& + & dmin,ilim ) + + else + + !------------------------------- constant grid-spacing ! + + call plmc(npos,nvar,ndof,delx,& + & fdat,fhat,& + & dmin,ilim ) + + end if + + return + + end subroutine + + !------------------------- assemble PLM reconstruction ! + + pure subroutine plmv(npos,nvar,ndof,delx, & + & fdat,fhat,dmin,ilim) + + ! + ! *this is the variable grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! ILIM cell slope-limiting selection . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar + integer, intent( in) :: ndof,ilim + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(:) + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + + !------------------------------------------- variables ! + integer :: ipos,ivar,head,tail + real*8 :: dfds(-1:+1) + + head = +1; tail = npos - 1 + + if (npos.eq.2) then + !----------------------- reduce order if small stencil ! + do ivar = +1, nvar + fhat(1,ivar,1) = & + & fdat(1,ivar,1) + fhat(2,ivar,1) = 0.e+0 + end do + end if + + if (npos.le.2) return + + !-------------------------------------- lower-endpoint ! + + do ivar = +1 , nvar-0 + + call plsv( & + & fdat(1,ivar,head+0) , & + & delx(head+0), & + & fdat(1,ivar,head+0) , & + & delx(head+0), & + & fdat(1,ivar,head+1) , & + & delx(head+1), dfds) + + fhat(1,ivar,head) = & + & fdat(1,ivar,head) + fhat(2,ivar,head) = dfds(0) + + end do + + !-------------------------------------- upper-endpoint ! + + do ivar = +1 , nvar-0 + + call plsv( & + & fdat(1,ivar,tail-1) , & + & delx(tail-1), & + & fdat(1,ivar,tail+0) , & + & delx(tail+0), & + & fdat(1,ivar,tail+0) , & + & delx(tail+0), dfds) + + fhat(1,ivar,tail) = & + & fdat(1,ivar,tail) + fhat(2,ivar,tail) = dfds(0) + + end do + + !-------------------------------------- interior cells ! + + do ipos = +2 , npos-2 + do ivar = +1 , nvar-0 + + call plsv( & + & fdat(1,ivar,ipos-1) , & + & delx(ipos-1), & + & fdat(1,ivar,ipos+0) , & + & delx(ipos+0), & + & fdat(1,ivar,ipos+1) , & + & delx(ipos+1), dfds) + + fhat(1,ivar,ipos) = & + & fdat(1,ivar,ipos) + fhat(2,ivar,ipos) = dfds(0) + + end do + end do + + return + + end subroutine + + !------------------------- assemble PLM reconstruction ! + + pure subroutine plmc(npos,nvar,ndof,delx, & + & fdat,fhat,dmin,ilim) + + ! + ! *this is the constant grid-spacing variant . + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell . + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! ILIM cell slope-limiting selection . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nvar + integer, intent( in) :: ndof,ilim + real*8 , intent( in) :: dmin + real*8 , intent( in) :: delx(1) + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + + !------------------------------------------- variables ! + integer :: ipos,ivar,head,tail + real*8 :: dfds(-1:+1) + + head = +1; tail = npos - 1 + + if (npos.eq.2) then + !----------------------- reduce order if small stencil ! + do ivar = +1, nvar + fhat(1,ivar,1) = & + & fdat(1,ivar,1) + fhat(2,ivar,1) = 0.e+0 + end do + end if + + if (npos.le.2) return + + !-------------------------------------- lower-endpoint ! + + do ivar = +1 , nvar-0 + + call plsc( & + & fdat(1,ivar,head+0) , & + & fdat(1,ivar,head+0) , & + & fdat(1,ivar,head+1) , & + & dfds) + + fhat(1,ivar,head) = & + & fdat(1,ivar,head) + fhat(2,ivar,head) = dfds(0) + + end do + + !-------------------------------------- upper-endpoint ! + + do ivar = +1 , nvar-0 + + call plsc( & + & fdat(1,ivar,tail-1) , & + & fdat(1,ivar,tail+0) , & + & fdat(1,ivar,tail+0) , & + & dfds) + + fhat(1,ivar,tail) = & + & fdat(1,ivar,tail) + fhat(2,ivar,tail) = dfds(0) + + end do + + !-------------------------------------- interior cells ! + + do ipos = +2 , npos-2 + do ivar = +1 , nvar-0 + + call plsc( & + & fdat(1,ivar,ipos-1) , & + & fdat(1,ivar,ipos+0) , & + & fdat(1,ivar,ipos+1) , & + & dfds) + + fhat(1,ivar,ipos) = & + & fdat(1,ivar,ipos) + fhat(2,ivar,ipos) = dfds(0) + + end do + end do + + return + + end subroutine + + !------------------------------- assemble PLM "slopes" ! + + pure subroutine plsv(ffll,hhll,ff00,hh00,& + & ffrr,hhrr,dfds) + + ! + ! *this is the variable grid-spacing variant . + ! + ! FFLL left -biased grid-cell mean. + ! HHLL left -biased grid-cell spac. + ! FF00 centred grid-cell mean. + ! HH00 centred grid-cell spac. + ! FFRR right-biased grid-cell mean. + ! HHRR right-biased grid-cell spac. + ! DFDS piecewise linear gradients in local co-ord.'s. + ! DFDS(+0) is a centred, slope-limited estimate, + ! DFDS(-1), DFDS(+1) are left- and right-biased + ! estimates (unlimited). + ! + + implicit none + + !------------------------------------------- arguments ! + real*8 , intent( in) :: ffll,ff00,ffrr + real*8 , intent( in) :: hhll,hh00,hhrr + real*8 , intent(out) :: dfds(-1:+1) + + !------------------------------------------- variables ! + real*8 :: fell,ferr,scal + + real*8 , parameter :: ZERO = 1.e-14 + + !---------------------------- 2nd-order approximations ! + + dfds(-1) = ff00-ffll + dfds(+1) = ffrr-ff00 + + if (dfds(-1) * & + & dfds(+1) .gt. 0.0d+0) then + + !---------------------------- calc. ll//rr edge values ! + + fell = (hh00*ffll+hhll*ff00) & + & / (hhll+hh00) + ferr = (hhrr*ff00+hh00*ffrr) & + & / (hh00+hhrr) + + !---------------------------- calc. centred derivative ! + + dfds(+0) = & + & 0.5d+0 * (ferr - fell) + + !---------------------------- monotonic slope-limiting ! + + scal = min(abs(dfds(-1)), & + & abs(dfds(+1))) & + & / max(abs(dfds(+0)), & + ZERO) + scal = min(scal,+1.0d+0) + + dfds(+0) = scal * dfds(+0) + + else + + !---------------------------- flatten if local extrema ! + + dfds(+0) = +0.0d+0 + + end if + + !---------------------------- scale onto local co-ord. ! + + dfds(-1) = dfds(-1) & + & / (hhll + hh00) * hh00 + dfds(+1) = dfds(+1) & + & / (hh00 + hhrr) * hh00 + + return + + end subroutine + + !------------------------------- assemble PLM "slopes" ! + + pure subroutine plsc(ffll,ff00,ffrr,dfds) + + ! + ! *this is the constant grid-spacing variant . + ! + ! FFLL left -biased grid-cell mean. + ! FF00 centred grid-cell mean. + ! FFRR right-biased grid-cell mean. + ! DFDS piecewise linear gradients in local co-ord.'s. + ! DFDS(+0) is a centred, slope-limited estimate, + ! DFDS(-1), DFDS(+1) are left- and right-biased + ! estimates (unlimited). + ! + + implicit none + + !------------------------------------------- arguments ! + real*8 , intent( in) :: ffll,ff00,ffrr + real*8 , intent(out) :: dfds(-1:+1) + + !------------------------------------------- variables ! + real*8 :: fell,ferr,scal + + real*8 , parameter :: ZERO = 1.e-14 + + !---------------------------- 2nd-order approximations ! + + dfds(-1) = ff00-ffll + dfds(+1) = ffrr-ff00 + + if (dfds(-1) * & + & dfds(+1) .gt. 0.0d+0) then + + !---------------------------- calc. ll//rr edge values ! + + fell = (ffll+ff00) * .5d+0 + ferr = (ff00+ffrr) * .5d+0 + + !---------------------------- calc. centred derivative ! + + dfds(+0) = & + & 0.5d+0 * (ferr - fell) + + !---------------------------- monotonic slope-limiting ! + + scal = min(abs(dfds(-1)), & + & abs(dfds(+1))) & + & / max(abs(dfds(+0)), & + ZERO) + scal = min(scal,+1.0d+0) + + dfds(+0) = scal * dfds(+0) + + else + + !---------------------------- flatten if local extrema ! + + dfds(+0) = +0.0d+0 + + end if + + !---------------------------- scale onto local co-ord. ! + + dfds(-1) = + 0.5d+0 * dfds(-1) + dfds(+1) = + 0.5d+0 * dfds(+1) + + return + + end subroutine + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! PPM.h90: 1d slope-limited, piecewise parabolic recon. + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + ! P. Colella and PR. Woodward, The Piecewise Parabolic + ! Method (PPM) for gas-dynamical simulations., J. Comp. + ! Phys., 54 (1), 1984, 174-201, + ! https://doi.org/10.1016/0021-9991(84)90143-8 + ! + + pure subroutine ppm(npos,nvar,ndof,delx, & + & fdat,fhat,edge,oscl, & + & dmin,ilim,wlim,halo) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! OSCL grid-cell oscil. dof.'s. OSCL is an array with + ! SIZE = +2 -by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! ILIM cell slope-limiting selection . + ! WLIM wall slope-limiting selection . + ! HALO width of re-con. stencil, symmetric about mid. . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,nvar,ndof + real*8 , intent(in) :: dmin + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent(in) :: oscl(:,:,:) + real*8 , intent(in) :: delx(:) + real*8 , intent(in) :: fdat(:,:,:) + real*8 , intent(in) :: edge(:,:) + integer, intent(in) :: ilim,wlim,halo + + !------------------------------------------- variables ! + integer :: ipos,ivar,iill,iirr,head,tail + real*8 :: ff00,ffll,ffrr,hh00,hhll,hhrr + integer :: mono + real*8 :: fell,ferr + real*8 :: dfds(-1:+1) + real*8 :: wval(+1:+2) + real*8 :: uhat(+1:+3) + real*8 :: lhat(+1:+3) + + head = +1; tail = npos - 1 + + if (npos.eq.2) then + !----- default to reduced order if insufficient points ! + do ivar = +1, nvar + fhat(1,ivar,+1) = & + & fdat(1,ivar,+1) + fhat(2,ivar,+1) = 0.e0 + fhat(3,ivar,+1) = 0.e0 + end do + end if + + if (npos.le.2) return + + !------------------- reconstruct function on each cell ! + + uhat = +0.e+0 + lhat = +0.e+0 + + do ipos = +1 , npos-1 + + iill = max(head,ipos-1) + iirr = min(tail,ipos+1) + + do ivar = +1 , nvar-0 + + !----------------------------- cell mean + edge values ! + + ff00 = fdat(1,ivar,ipos) + ffll = fdat(1,ivar,iill) + ffrr = fdat(1,ivar,iirr) + + fell = edge(ivar,ipos+0) + ferr = edge(ivar,ipos+1) + + !----------------------------- calc. LL/00/RR gradient ! + + if (size(delx).gt.+1) then + + hh00 = delx(ipos) + hhll = delx(iill) + hhrr = delx(iirr) + + call plsv (ffll,hhll,ff00, & + & hh00,ffrr,hhrr, & + & dfds) + else + + call plsc (ffll,ff00,ffrr, & + & dfds) + + end if + + !----------------------------- calc. cell-wise profile ! + + select case(ilim) + case (null_limit) + + !----------------------------- calc. unlimited profile ! + + call ppmfn(ff00,ffll,ffrr, & + & fell,ferr,dfds, & + & uhat,lhat,mono) + + !----------------------------- pref. unlimited profile ! + + wval(1) = +1.e+0 + wval(2) = +0.e+0 + + case (mono_limit) + + !----------------------------- calc. monotonic profile ! + + call ppmfn(ff00,ffll,ffrr, & + & fell,ferr,dfds, & + & uhat,lhat,mono) + + !----------------------------- pref. monotonic profile ! + + wval(1) = +0.e+0 + wval(2) = +1.e+0 + + case (weno_limit) + + !----------------------------- calc. unlimited profile ! + + call ppmfn(ff00,ffll,ffrr, & + & fell,ferr,dfds, & + & uhat,lhat,mono) + + if (mono.gt.+0) then + + !----------------------------- calc. WENO-type weights ! + + call wenoi(npos,delx,oscl, & + & ipos,ivar,halo, & + & wlim,wval) + + else + + !----------------------------- pref. unlimited profile ! + + wval(1) = +1.e+0 + wval(2) = +0.e+0 + + end if + + end select + + !----------------------------- blend "null" and "mono" ! + + fhat(1,ivar,ipos) = & + & wval(1) * uhat(1) + & + & wval(2) * lhat(1) + fhat(2,ivar,ipos) = & + & wval(1) * uhat(2) + & + & wval(2) * lhat(2) + fhat(3,ivar,ipos) = & + & wval(1) * uhat(3) + & + & wval(2) * lhat(3) + + end do + + end do + + return + + end subroutine + + !--------- assemble piecewise parabolic reconstruction ! + + pure subroutine ppmfn(ff00,ffll,ffrr,fell,& + & ferr,dfds,uhat,lhat,& + & mono) + + ! + ! FF00 centred grid-cell mean. + ! FFLL left -biased grid-cell mean. + ! FFRR right-biased grid-cell mean. + ! FELL left -biased edge interp. + ! FERR right-biased edge interp. + ! DFDS piecewise linear gradients in local co-ord.'s. + ! DFDS(+0) is a centred, slope-limited estimate, + ! DFDS(-1), DFDS(+1) are left- and right-biased + ! estimates (unlimited). + ! UHAT unlimited PPM reconstruction coefficients . + ! LHAT monotonic PPM reconstruction coefficients . + ! MONO slope-limiting indicator, MONO > +0 if some + ! limiting has occured . + ! + + implicit none + + !------------------------------------------- arguments ! + real*8 , intent(in) :: ff00 + real*8 , intent(in) :: ffll,ffrr + real*8 , intent(inout) :: fell,ferr + real*8 , intent(in) :: dfds(-1:+1) + real*8 , intent(out) :: uhat(+1:+3) + real*8 , intent(out) :: lhat(+1:+3) + integer, intent(out) :: mono + + !------------------------------------------- variables ! + real*8 :: turn + + mono = 0 + + !-------------------------------- "null" slope-limiter ! + + uhat( 1 ) = & + & + (3.0d+0 / 2.0d+0) * ff00 & + & - (1.0d+0 / 4.0d+0) *(ferr+fell) + uhat( 2 ) = & + & + (1.0d+0 / 2.0d+0) *(ferr-fell) + uhat( 3 ) = & + & - (3.0d+0 / 2.0d+0) * ff00 & + & + (3.0d+0 / 4.0d+0) *(ferr+fell) + + !-------------------------------- "mono" slope-limiter ! + + if((ffrr - ff00) * & + & (ff00 - ffll) .lt. 0.e+0) then + + !----------------------------------- "flatten" extrema ! + + mono = +1 + + lhat(1) = ff00 + lhat(2) = 0.e0 + lhat(3) = 0.e0 + + return + + end if + + !----------------------------------- limit edge values ! + + if((ffll - fell) * & + & (fell - ff00) .le. 0.e+0) then + + mono = +1 + + fell = ff00 - dfds(0) + + end if + + if((ffrr - ferr) * & + & (ferr - ff00) .le. 0.e+0) then + + mono = +1 + + ferr = ff00 + dfds(0) + + end if + + !----------------------------------- update ppm coeff. ! + + lhat( 1 ) = & + & + (3.0d+0 / 2.0d+0) * ff00 & + & - (1.0d+0 / 4.0d+0) *(ferr+fell) + lhat( 2 ) = & + & + (1.0d+0 / 2.0d+0) *(ferr-fell) + lhat( 3 ) = & + & - (3.0d+0 / 2.0d+0) * ff00 & + & + (3.0d+0 / 4.0d+0) *(ferr+fell) + + !----------------------------------- limit cell values ! + + if (abs(lhat(3)) .gt. & + & abs(lhat(2))*.5d+0) then + + turn = -0.5d+0 * lhat(2) & + & / lhat(3) + + if ((turn .ge. -1.e+0)& + & .and.(turn .le. +0.e+0)) then + + mono = +2 + + !--------------------------- push TURN onto lower edge ! + + ferr = +3.0d+0 * ff00 & + & -2.0d+0 * fell + + lhat( 1 ) = & + & + (3.0d+0 / 2.0d+0) * ff00 & + & - (1.0d+0 / 4.0d+0) *(ferr+fell) + lhat( 2 ) = & + & + (1.0d+0 / 2.0d+0) *(ferr-fell) + lhat( 3 ) = & + & - (3.0d+0 / 2.0d+0) * ff00 & + & + (3.0d+0 / 4.0d+0) *(ferr+fell) + + else & + & if ((turn .gt. +0.e+0)& + & .and.(turn .le. +1.e+0)) then + + mono = +2 + + !--------------------------- push TURN onto upper edge ! + + fell = +3.0d+0 * ff00 & + & -2.0d+0 * ferr + + lhat( 1 ) = & + & + (3.0d+0 / 2.0d+0) * ff00 & + & - (1.0d+0 / 4.0d+0) *(ferr+fell) + lhat( 2 ) = & + & + (1.0d+0 / 2.0d+0) *(ferr-fell) + lhat( 3 ) = & + & - (3.0d+0 / 2.0d+0) * ff00 & + & + (3.0d+0 / 4.0d+0) *(ferr+fell) + + end if + + end if + + return + + end subroutine + + + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! PQM.h90: a 1d slope-limited, piecewise quartic recon. + ! + ! Darren Engwirda + ! 08-Sep-2016 + ! de2363 [at] columbia [dot] edu + ! + ! + + ! White, L. and Adcroft, A., A high-order finite volume + ! remapping scheme for nonuniform grids: The piecewise + ! quartic method (PQM), J. Comp. Phys., 227 (15), 2008, + ! 7394-7422, https://doi.org/10.1016/j.jcp.2008.04.026. + ! + + pure subroutine pqm(npos,nvar,ndof,delx, & + & fdat,fhat,edge,dfdx, & + & oscl,dmin,ilim,wlim, & + & halo) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if + ! spacing is uniform . + ! FDAT grid-cell moments array. FDAT is an array with + ! SIZE = NDOF-by-NVAR-by-NPOS-1 . + ! FHAT grid-cell re-con. array. FHAT is an array with + ! SIZE = MDOF-by-NVAR-by-NPOS-1 . + ! EDGE edge-centred interp. for function-value. EDGE + ! is an array with SIZE = NVAR-by-NPOS . + ! DFDX edge-centred interp. for 1st-derivative. DFDX + ! is an array with SIZE = NVAR-by-NPOS . + ! OSCL grid-cell oscil. dof.'s. OSCL is an array with + ! SIZE = +2 -by-NVAR-by-NPOS-1 . + ! DMIN min. grid-cell spacing thresh . + ! ILIM cell slope-limiting selection . + ! WLIM wall slope-limiting selection . + ! HALO width of re-con. stencil, symmetric about mid. . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,nvar,ndof + integer, intent(in) :: ilim,wlim,halo + real*8 , intent(in) :: dmin + real*8 , intent(out) :: fhat(:,:,:) + real*8 , intent(in) :: oscl(:,:,:) + real*8 , intent(in) :: delx(:) + real*8 , intent(in) :: fdat(:,:,:) + real*8 , intent(in) :: edge(:,:) + real*8 , intent(in) :: dfdx(:,:) + + !------------------------------------------- variables ! + integer :: ipos,ivar,iill,iirr,head,tail + real*8 :: ff00,ffll,ffrr,hh00,hhll,hhrr + real*8 :: xhat + integer :: mono + real*8 :: fell,ferr + real*8 :: dell,derr + real*8 :: dfds(-1:+1) + real*8 :: uhat(+1:+5) + real*8 :: lhat(+1:+5) + real*8 :: wval(+1:+2) + + head = +1; tail = npos - 1 + + if (npos.le.2) then + !----- default to reduced order if insufficient points ! + do ivar = +1, nvar + fhat(1,ivar,+1) = fdat(1,ivar,+1) + fhat(2,ivar,+1) = 0.e0 + fhat(3,ivar,+1) = 0.e0 + fhat(4,ivar,+1) = 0.e0 + fhat(5,ivar,+1) = 0.e0 + end do + end if + + if (npos.le.2) return + + !------------------- reconstruct function on each cell ! + + do ipos = +1 , npos-1 + + iill = max(head,ipos-1) + iirr = min(tail,ipos+1) + + do ivar = +1 , nvar-0 + + !----------------------------- cell mean + edge values ! + + ff00 = fdat(1,ivar,ipos) + ffll = fdat(1,ivar,iill) + ffrr = fdat(1,ivar,iirr) + + fell = edge(ivar,ipos+0) + ferr = edge(ivar,ipos+1) + + !----------------------------- calc. LL/00/RR gradient ! + + if (size(delx).gt.+1) then + + hh00 = delx(ipos) + hhll = delx(iill) + hhrr = delx(iirr) + + xhat = delx(ipos+0)*.5d+0 + + call plsv (ffll,hhll,ff00, & + & hh00,ffrr,hhrr, & + & dfds) + else + + xhat = delx( +1)*.5d+0 + + call plsc (ffll,ff00,ffrr, & + & dfds) + + end if + + dell = dfdx (ivar,ipos+0) + dell = dell * xhat + + derr = dfdx (ivar,ipos+1) + derr = derr * xhat + + !----------------------------- calc. cell-wise profile ! + + select case(ilim) + case (null_limit) + + !----------------------------- calc. unlimited profile ! + + call pqmfn(ff00,ffll,ffrr, & + & fell,ferr,dell, & + & derr,dfds,uhat, & + & lhat,mono) + + !----------------------------- pref. unlimited profile ! + + wval(1) = +1.e+0 + wval(2) = +0.e+0 + + case (mono_limit) + + !----------------------------- calc. monotonic profile ! + + call pqmfn(ff00,ffll,ffrr, & + & fell,ferr,dell, & + & derr,dfds,uhat, & + & lhat,mono) + + !----------------------------- pref. monotonic profile ! + + wval(1) = +0.e+0 + wval(2) = +1.e+0 + + case (weno_limit) + + !----------------------------- calc. monotonic profile ! + + call pqmfn(ff00,ffll,ffrr, & + & fell,ferr,dell, & + & derr,dfds,uhat, & + & lhat,mono) + + if (mono.gt.+0) then + + !----------------------------- calc. WENO-type weights ! + + call wenoi(npos,delx,oscl, & + & ipos,ivar,halo, & + & wlim,wval) + + else + + !----------------------------- pref. unlimited profile ! + + wval(1) = +1.e+0 + wval(2) = +0.e+0 + + end if + + end select + + !----------------------------- blend "null" and "mono" ! + + fhat(1,ivar,ipos) = & + & wval(1) * uhat(1) + & + & wval(2) * lhat(1) + fhat(2,ivar,ipos) = & + & wval(1) * uhat(2) + & + & wval(2) * lhat(2) + fhat(3,ivar,ipos) = & + & wval(1) * uhat(3) + & + & wval(2) * lhat(3) + fhat(4,ivar,ipos) = & + & wval(1) * uhat(4) + & + & wval(2) * lhat(4) + fhat(5,ivar,ipos) = & + & wval(1) * uhat(5) + & + & wval(2) * lhat(5) + + end do + + end do + + return + + end subroutine + + !----------- assemble piecewise quartic reconstruction ! + + pure subroutine pqmfn(ff00,ffll,ffrr,fell, & + & ferr,dell,derr,dfds, & + & uhat,lhat,mono) + + ! + ! FF00 centred grid-cell mean. + ! FFLL left -biased grid-cell mean. + ! FFRR right-biased grid-cell mean. + ! FELL left -biased edge interp. + ! FERR right-biased edge interp. + ! DELL left -biased edge df//dx. + ! DERR right-biased edge df//dx. + ! DFDS piecewise linear gradients in local co-ord.'s. + ! DFDS(+0) is a centred, slope-limited estimate, + ! DFDS(-1), DFDS(+1) are left- and right-biased + ! estimates (unlimited). + ! UHAT unlimited PPM reconstruction coefficients . + ! LHAT monotonic PPM reconstruction coefficients . + ! MONO slope-limiting indicator, MONO > +0 if some + ! limiting has occured . + ! + + implicit none + + !------------------------------------------- arguments ! + real*8 , intent(in) :: ff00 + real*8 , intent(in) :: ffll,ffrr + real*8 , intent(inout) :: fell,ferr + real*8 , intent(inout) :: dell,derr + real*8 , intent(in) :: dfds(-1:+1) + real*8 , intent(out) :: uhat(+1:+5) + real*8 , intent(out) :: lhat(+1:+5) + integer, intent(out) :: mono + + !------------------------------------------- variables ! + integer :: turn + real*8 :: grad, iflx(+1:+2) + logical :: haveroot + + !-------------------------------- "null" slope-limiter ! + + mono = 0 + + uhat(1) = & + & + (30.e+0 / 16.e+0) * ff00 & + & - ( 7.e+0 / 16.e+0) *(ferr+fell) & + & + ( 1.e+0 / 16.e+0) *(derr-dell) + uhat(2) = & + & + ( 3.e+0 / 4.e+0) *(ferr-fell) & + & - ( 1.e+0 / 4.e+0) *(derr+dell) + uhat(3) = & + & - (30.e+0 / 8.e+0) * ff00 & + & + (15.e+0 / 8.e+0) *(ferr+fell) & + & - ( 3.e+0 / 8.e+0) *(derr-dell) + uhat(4) = & + & - ( 1.e+0 / 4.e+0) *(ferr-fell & + & -derr-dell) + uhat(5) = & + & + (30.e+0 / 16.e+0) * ff00 & + & - (15.e+0 / 16.e+0) *(ferr+fell) & + & + ( 5.e+0 / 16.e+0) *(derr-dell) + + !-------------------------------- "mono" slope-limiter ! + + if((ffrr - ff00) * & + & (ff00 - ffll) .le. 0.e+0) then + + !----------------------------------- "flatten" extrema ! + + mono = +1 + + lhat(1) = ff00 + lhat(2) = 0.e0 + lhat(3) = 0.e0 + lhat(4) = 0.e0 + lhat(5) = 0.e0 + + return + + end if + + !----------------------------------- limit edge values ! + + if((ffll - fell) * & + & (fell - ff00) .le. 0.e+0) then + + mono = +1 + + fell = ff00 - dfds(0) + + end if + + if (dell * dfds(0) .lt. 0.e+0) then + + mono = +1 + + dell = dfds(0) + + end if + + if((ffrr - ferr) * & + & (ferr - ff00) .le. 0.e+0) then + + mono = +1 + + ferr = ff00 + dfds(0) + + end if + + if (derr * dfds(0) .lt. 0.e+0) then + + mono = +1 + + derr = dfds(0) + + end if + + !----------------------------------- limit cell values ! + + lhat(1) = & + & + (30.e+0 / 16.e+0) * ff00 & + & - ( 7.e+0 / 16.e+0) *(ferr+fell) & + & + ( 1.e+0 / 16.e+0) *(derr-dell) + lhat(2) = & + & + ( 3.e+0 / 4.e+0) *(ferr-fell) & + & - ( 1.e+0 / 4.e+0) *(derr+dell) + lhat(3) = & + & - (30.e+0 / 8.e+0) * ff00 & + & + (15.e+0 / 8.e+0) *(ferr+fell) & + & - ( 3.e+0 / 8.e+0) *(derr-dell) + lhat(4) = & + & - ( 1.e+0 / 4.e+0) *(ferr-fell & + & -derr-dell) + lhat(5) = & + & + (30.e+0 / 16.e+0) * ff00 & + & - (15.e+0 / 16.e+0) *(ferr+fell) & + & + ( 5.e+0 / 16.e+0) *(derr-dell) + + !------------------ calc. inflexion via 2nd-derivative ! + + call roots_2(12.e+0 * lhat(5), & + & 6.e+0 * lhat(4), & + & 2.e+0 * lhat(3), & + & iflx , haveroot ) + + if (haveroot) then + + turn = +0 + + if ( ( iflx(1) .gt. -1.e+0 ) & + & .and. ( iflx(1) .lt. +1.e+0 ) ) then + + !------------------ check for non-monotonic inflection ! + + grad = lhat(2) & + &+ (iflx(1)**1) * 2.e+0* lhat(3) & + &+ (iflx(1)**2) * 3.e+0* lhat(4) & + &+ (iflx(1)**3) * 4.e+0* lhat(5) + + if (grad * dfds(0) .lt. 0.e+0) then + + if (abs(dfds(-1)) & + & .lt. abs(dfds(+1)) ) then + + turn = -1 ! modify L + + else + + turn = +1 ! modify R + + end if + + end if + + end if + + if ( ( iflx(2) .gt. -1.e+0 ) & + & .and. ( iflx(2) .lt. +1.e+0 ) ) then + + !------------------ check for non-monotonic inflection ! + + grad = lhat(2) & + &+ (iflx(2)**1) * 2.e+0* lhat(3) & + &+ (iflx(2)**2) * 3.e+0* lhat(4) & + &+ (iflx(2)**3) * 4.e+0* lhat(5) + + if (grad * dfds(0) .lt. 0.e+0) then + + if (abs(dfds(-1)) & + & .lt. abs(dfds(+1)) ) then + + turn = -1 ! modify L + + else + + turn = +1 ! modify R + + end if + + end if + + end if + + !------------------ pop non-monotone inflexion to edge ! + + if (turn .eq. -1) then + + !------------------ pop inflection points onto -1 edge ! + + mono = +2 + + derr = & + &- ( 5.e+0 / 1.e+0) * ff00 & + &+ ( 3.e+0 / 1.e+0) * ferr & + &+ ( 2.e+0 / 1.e+0) * fell + dell = & + &+ ( 5.e+0 / 3.e+0) * ff00 & + &- ( 1.e+0 / 3.e+0) * ferr & + &- ( 4.e+0 / 3.e+0) * fell + + if (dell*dfds(+0) .lt. 0.e+0) then + + dell = 0.e+0 + + ferr = & + &+ ( 5.e+0 / 1.e+0) * ff00 & + &- ( 4.e+0 / 1.e+0) * fell + derr = & + &+ (10.e+0 / 1.e+0) * ff00 & + &- (10.e+0 / 1.e+0) * fell + + else & + & if (derr*dfds(+0) .lt. 0.e+0) then + + derr = 0.e+0 + + fell = & + &+ ( 5.e+0 / 2.e+0) * ff00 & + &- ( 3.e+0 / 2.e+0) * ferr + dell = & + &- ( 5.e+0 / 3.e+0) * ff00 & + &+ ( 5.e+0 / 3.e+0) * ferr + + end if + + lhat(1) = & + &+ (30.e+0 / 16.e+0) * ff00 & + &- ( 7.e+0 / 16.e+0) *(ferr+fell) & + &+ ( 1.e+0 / 16.e+0) *(derr-dell) + lhat(2) = & + &+ ( 3.e+0 / 4.e+0) *(ferr-fell) & + &- ( 1.e+0 / 4.e+0) *(derr+dell) + lhat(3) = & + &- (30.e+0 / 8.e+0) * ff00 & + &+ (15.e+0 / 8.e+0) *(ferr+fell) & + &- ( 3.e+0 / 8.e+0) *(derr-dell) + lhat(4) = & + &- ( 1.e+0 / 4.e+0) *(ferr-fell & + & -derr-dell) + lhat(5) = & + &+ (30.e+0 / 16.e+0) * ff00 & + &- (15.e+0 / 16.e+0) *(ferr+fell) & + &+ ( 5.e+0 / 16.e+0) *(derr-dell) + + end if + + if (turn .eq. +1) then + + !------------------ pop inflection points onto -1 edge ! + + mono = +2 + + derr = & + &- ( 5.e+0 / 3.e+0) * ff00 & + &+ ( 4.e+0 / 3.e+0) * ferr & + &+ ( 1.e+0 / 3.e+0) * fell + dell = & + &+ ( 5.e+0 / 1.e+0) * ff00 & + &- ( 2.e+0 / 1.e+0) * ferr & + &- ( 3.e+0 / 1.e+0) * fell + + if (dell*dfds(+0) .lt. 0.e+0) then + + dell = 0.e+0 + + ferr = & + &+ ( 5.e+0 / 2.e+0) * ff00 & + &- ( 3.e+0 / 2.e+0) * fell + derr = & + &+ ( 5.e+0 / 3.e+0) * ff00 & + &- ( 5.e+0 / 3.e+0) * fell + + else & + & if (derr*dfds(+0) .lt. 0.e+0) then + + derr = 0.e+0 + + fell = & + &+ ( 5.e+0 / 1.e+0) * ff00 & + &- ( 4.e+0 / 1.e+0) * ferr + dell = & + &- (10.e+0 / 1.e+0) * ff00 & + &+ (10.e+0 / 1.e+0) * ferr + + end if + + lhat(1) = & + &+ (30.e+0 / 16.e+0) * ff00 & + &- ( 7.e+0 / 16.e+0) *(ferr+fell) & + &+ ( 1.e+0 / 16.e+0) *(derr-dell) + lhat(2) = & + &+ ( 3.e+0 / 4.e+0) *(ferr-fell) & + &- ( 1.e+0 / 4.e+0) *(derr+dell) + lhat(3) = & + &- (30.e+0 / 8.e+0) * ff00 & + &+ (15.e+0 / 8.e+0) *(ferr+fell) & + &- ( 3.e+0 / 8.e+0) *(derr-dell) + lhat(4) = & + &- ( 1.e+0 / 4.e+0) *(ferr-fell & + & -derr-dell) + lhat(5) = & + &+ (30.e+0 / 16.e+0) * ff00 & + &- (15.e+0 / 16.e+0) *(ferr+fell) & + &+ ( 5.e+0 / 16.e+0) *(derr-dell) + + end if + + end if ! haveroot + + return + + end subroutine + + + + + !------------------------------------------------------! + ! RMAP1D : one-dimensional conservative "re-map" . ! + !------------------------------------------------------! + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! RMAP1D.h90: high-order integral re-mapping operators. + ! + ! Darren Engwirda + ! 31-Mar-2019 + ! ​de2363 [at] columbia [dot] edu + ! + ! + + subroutine rmap1d(npos,nnew,nvar,ndof,xpos, & + & xnew,fdat,fnew,bclo,bcup, & + & work,opts,tCPU) + + ! + ! NPOS no. edges in old grid. + ! NNEW no. edges in new grid. + ! NVAR no. discrete variables to remap. + ! NDOF no. degrees-of-freedom per cell. + ! XPOS old grid edge positions. XPOS is a length NPOS + ! array . + ! XNEW new grid edge positions. XNEW is a length NNEW + ! array . + ! FDAT grid-cell moments on old grid. FNEW has SIZE = + ! NDOF-by-NVAR-by-NNEW-1 . + ! FNEW grid-cell moments on new grid. FNEW has SIZE = + ! NDOF-by-NVAR-by-NNEW-1 . + ! BCLO boundary condition at lower endpoint . + ! BCHI boundary condition at upper endpoint . + ! WORK method work-space. See RCON-WORK for details . + ! OPTS method parameters. See RCON-OPTS for details . + ! TCPU method tcpu-timer. + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nnew + integer, intent( in) :: nvar,ndof + class(rmap_work), intent(inout):: work + class(rmap_opts), intent(inout):: opts + real*8 , intent( in) :: xpos(:) + real*8 , intent( in) :: xnew(:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: fnew(:,:,:) + type (rcon_ends), intent(in) :: bclo(:) + type (rcon_ends), intent(in) :: bcup(:) + type (rmap_tics), & + & intent(inout) , optional :: tCPU + + real*8 , parameter :: RTOL = +1.e-14 + + !------------------------------------------- variables ! + integer :: ipos + real*8 :: diff,spac,same,xtol + real*8 :: delx(1) + logical :: uniform + + + if (ndof.lt.1) return + if (npos.lt.2) return + if (nnew.lt.2) return + if (nvar.lt.1) return + + !------------- calc. grid-spacing and check uniformity ! + + same = (xpos(npos)& + - xpos( +1)) / (npos-1) + + uniform = .true. + + xtol = same * RTOL + + do ipos = +1 , npos-1, +1 + + spac = xpos(ipos+1) & + & - xpos(ipos+0) + + diff = abs(spac - same) + + if (diff.gt.xtol) then + + uniform = .false. + + end if + + work% & + & cell_spac(ipos) = spac + + end do + + !uniform = .false. + + !------------- reconstruct FHAT over all cells in XPOS ! + + if (.not. uniform) then + + !------------------------------------ variable spacing ! + call rcon1d(npos,nvar,ndof, & + & work%cell_spac, & + & fdat,bclo,bcup, & + & work%cell_func, & + & work,opts,tCPU) + + else + + !------------------------------------ constant spacing ! + delx(1) = work%cell_spac(1) + + call rcon1d(npos,nvar,ndof, & + & delx, & + & fdat,bclo,bcup, & + & work%cell_func, & + & work,opts,tCPU) + + end if + + !------------- remap FDAT from XPOS to XNEW using FHAT ! + + + select case(opts%cell_meth) + case(pcm_method) + !------------------------------------ 1st-order method ! + call imap1d(npos,nnew,nvar, & + & ndof, +1, & + & xpos,xnew, & + & work%cell_func, & + & fdat,fnew,xtol) + + case(plm_method) + !------------------------------------ 2nd-order method ! + call imap1d(npos,nnew,nvar, & + & ndof, +2, & + & xpos,xnew, & + & work%cell_func, & + & fdat,fnew,xtol) + + case(ppm_method) + !------------------------------------ 3rd-order method ! + call imap1d(npos,nnew,nvar, & + & ndof, +3, & + & xpos,xnew, & + & work%cell_func, & + & fdat,fnew,xtol) + + case(pqm_method) + !------------------------------------ 5th-order method ! + call imap1d(npos,nnew,nvar, & + & ndof, +5, & + & xpos,xnew, & + & work%cell_func, & + & fdat,fnew,xtol) + + end select + + + return + + end subroutine + + !------------ IMAP1D: 1-dimensional degree-k remapping ! + + pure subroutine imap1d(npos,nnew,nvar,ndof, & + & mdof,xpos,xnew,fhat, & + & fdat,fnew,XTOL) + + ! + ! NPOS no. edges in old grid. + ! NNEW no. edges in new grid. + ! NVAR no. discrete variables to remap. + ! NDOF no. degrees-of-freedom per cell. + ! MDOF no. degrees-of-freedom per FHAT. + ! XPOS old grid edge positions. XPOS is a length NPOS + ! array . + ! XNEW new grid edge positions. XNEW is a length NNEW + ! array . + ! FHAT reconstruction over old grid. FHAT has SIZE = + ! MDOF-by-NVAR-by-NPOS-1 . + ! FDAT grid-cell moments on old grid. FDAT has SIZE = + ! NDOF-by-NVAR-by-NPOS-1 . + ! FNEW grid-cell moments on new grid. FNEW has SIZE = + ! NDOF-by-NVAR-by-NNEW-1 . + ! XTOL min. grid-cell thickness . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent( in) :: npos,nnew + integer, intent( in) :: nvar + integer, intent( in) :: ndof,mdof + real*8 , intent( in) :: xpos(:) + real*8 , intent( in) :: xnew(:) + real*8 , intent( in) :: fhat(:,:,:) + real*8 , intent( in) :: fdat(:,:,:) + real*8 , intent(out) :: fnew(:,:,:) + real*8 , intent( in) :: XTOL + + !------------------------------------------- variables ! + integer :: kpos,ipos,ivar,idof + integer :: pos0,pos1,vmin,vmax + real*8 :: xmid,xhat,khat,stmp + real*8 :: xxlo,xxhi,sslo,sshi,intf + real*8 :: vvlo( +1:+5) + real*8 :: vvhi( +1:+5) + real*8 :: ivec( +1:+5) + real*8 :: sdat( +1:nvar) + real*8 :: snew( +1:nvar) + real*8 :: serr( +1:nvar) + integer :: kmin( +1:nvar) + integer :: kmax( +1:nvar) + + integer, parameter :: INTB = -1 ! integral basis + + !------------------------------------- initializations ! + + vvlo(+1:+5) = 0.e0 + vvhi(+1:+5) = 0.e0 + + !------------- remap FDAT from XPOS to XNEW using FHAT ! + + kmin = +1 ; kmax = +1 + pos0 = +1 ; pos1 = +1 + + do kpos = +1, nnew-1 + + !------ first cell in XPOS overlapping with XNEW(KPOS) ! + + pos1 = max(pos1,1) + + do pos0 = pos1, npos-1 + + if (xpos(pos0+1)& + & .gt. xnew(kpos+0)) exit + + end do + + !------ final cell in XPOS overlapping with XNEW(KPOS) ! + + do pos1 = pos0, npos-1 + + if (xpos(pos1+0)& + & .ge. xnew(kpos+1)) exit + + end do + + pos1 = pos1 - 1 + + !------------- integrate FHAT across overlapping cells ! + + khat = xnew(kpos+1) & + & - xnew(kpos+0) + khat = max (khat , XTOL) + + do idof = +1,ndof + do ivar = +1,nvar + + fnew(idof,ivar,kpos) = 0.e0 + + end do + end do + + do ipos = pos0, pos1 + + !------------------------------- integration endpoints ! + + xxlo = max (xpos(ipos+0) , & + & xnew(kpos+0)) + xxhi = min (xpos(ipos+1) , & + & xnew(kpos+1)) + + !------------------------------- local endpoint coords ! + + xmid = xpos(ipos+1) * .5d0 & + & + xpos(ipos+0) * .5d0 + xhat = xpos(ipos+1) * .5d0 & + & - xpos(ipos+0) * .5d0 + + sslo = & + & (xxlo-xmid) / max(xhat,XTOL) + sshi = & + & (xxhi-xmid) / max(xhat,XTOL) + + !------------------------------- integral basis vector ! + + call bfun1d(INTB,mdof, & + sslo,vvlo) + call bfun1d(INTB,mdof, & + sshi,vvhi) + + ivec = vvhi - vvlo + + !--------- integrate FHAT across the overlap XXLO:XXHI ! + + do ivar = +1, nvar + + intf = dot_product ( & + & ivec(+1:mdof), & + & fhat(+1:mdof,ivar,ipos-0) ) + + intf = intf * xhat + + !--------- accumulate integral contributions from IPOS ! + + fnew( +1,ivar,kpos) = & + & fnew( +1,ivar,kpos) + intf + + end do + + end do + + !------------------------------- finalise KPOS profile ! + + do ivar = +1, nvar + + fnew( +1,ivar,kpos) = & + & fnew( +1,ivar,kpos) / khat + + !--------- keep track of MIN/MAX for defect correction ! + + vmax = kmax(ivar) + vmin = kmin(ivar) + + if(fnew(1,ivar,kpos) & + & .gt.fnew(1,ivar,vmax) ) then + + kmax(ivar) = kpos + + else & + & if(fnew(1,ivar,kpos) & + & .lt.fnew(1,ivar,vmin) ) then + + kmin(ivar) = kpos + + end if + + end do + + end do + + !--------- defect corrections: Kahan/Babuska/Neumaier. ! + + ! Carefully compute column sums, leading to a defect + ! wrt. column-wise conservation. Use KBN approach to + ! account for FP roundoff. + + sdat = 0.e0; serr = 0.e0 + do ipos = +1, npos-1 + do ivar = +1, nvar-0 + + !------------------------------- integrate old profile ! + + xhat = xpos(ipos+1) & + & - xpos(ipos+0) + + intf = xhat*fdat(1,ivar,ipos) + + stmp = sdat(ivar) + intf + + if (abs(sdat(ivar)) & + & .ge. abs(intf)) then + + serr(ivar) = & + & serr(ivar) + ((sdat(ivar)-stmp)+intf) + + else + + serr(ivar) = & + & serr(ivar) + ((intf-stmp)+sdat(ivar)) + + end if + + sdat(ivar) = stmp + + end do + end do + + sdat = sdat + serr + + snew = 0.e0; serr = 0.e0 + do ipos = +1, nnew-1 + do ivar = +1, nvar-0 + + !------------------------------- integrate new profile ! + + khat = xnew(ipos+1) & + & - xnew(ipos+0) + + intf = khat*fnew(1,ivar,ipos) + + stmp = snew(ivar) + intf + + if (abs(snew(ivar)) & + & .ge. abs(intf)) then + + serr(ivar) = & + & serr(ivar) + ((snew(ivar)-stmp)+intf) + + else + + serr(ivar) = & + & serr(ivar) + ((intf-stmp)+snew(ivar)) + + end if + + snew(ivar) = stmp + + end do + end do + + snew = snew + serr + serr = sdat - snew + + !--------- defect corrections: nudge away from extrema ! + + ! Add a correction to remapped state to impose exact + ! conservation. Via sign(correction), nudge min/max. + ! cell means, such that monotonicity is not violated + ! near extrema... + + do ivar = +1, nvar-0 + + if (serr(ivar) .gt. 0.e0) then + + vmin = kmin(ivar) + + fnew(1,ivar,vmin) = & + & fnew(1,ivar,vmin) + & + & serr(ivar)/(xnew(vmin+1)-xnew(vmin+0)) + + else & + & if (serr(ivar) .lt. 0.e0) then + + vmax = kmax(ivar) + + fnew(1,ivar,vmax) = & + & fnew(1,ivar,vmax) + & + & serr(ivar)/(xnew(vmax+1)-xnew(vmax+0)) + + end if + + end do + + !------------------------------- new profile now final ! + + return + + end subroutine + + + + + !------------------------------------------------------! + ! FFSL1D : one-dimensional FFSL scalar transport . ! + !------------------------------------------------------! + + + ! + ! This program may be freely redistributed under the + ! condition that the copyright notices (including this + ! entire header) are not removed, and no compensation + ! is received through use of the software. Private, + ! research, and institutional use is free. You may + ! distribute modified versions of this code UNDER THE + ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE + ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE + ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE + ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR + ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution + ! of this code as part of a commercial system is + ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE + ! AUTHOR. (If you are not directly supplying this + ! code to a customer, and you are instead telling them + ! how they can obtain it for free, then you are not + ! required to make any arrangement with me.) + ! + ! Disclaimer: Neither I nor: Columbia University, the + ! National Aeronautics and Space Administration, nor + ! the Massachusetts Institute of Technology warrant + ! or certify this code in any way whatsoever. This + ! code is provided "as-is" to be used at your own risk. + ! + ! + + ! + ! FFSL1D.h90: upwind-biased flux-reconstruction scheme. + ! + ! Darren Engwirda + ! 31-Mar-2019 + ! de2363 [at] columbia [dot] edu + ! + ! + + subroutine ffsl1d(npos,nvar,ndof,spac,tDEL, & + & mask,uvel,qbar,qedg,bclo, & + & bchi,work,opts) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! NDOF no. degrees-of-freedom per grid-cell. + ! SPAC grid-cell spacing array. LENGTH(SPAC) == +1 if + ! spacing is uniform . + ! TDEL time-step . + ! MASK logical grid-cell masking array. + ! UVEL edge-centred velocity vectors. UVEL has SIZE = + ! NPOS-by-1 . + ! QBAR cell-centred integral moments. QBAR has SIZE = + ! NDOF-by-NVAR-by-NPOS-1 . + ! QEDG edge-centred upwind flux eval. QEDG has SIZE = + ! NVAR-by-NPOS . + ! BCLO boundary condition at lower endpoint . + ! BCHI boundary condition at upper endpoint . + ! WORK method work-space. See RCON-WORK for details . + ! OPTS method parameters. See RCON-OPTS for details . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,nvar,ndof + class(rmap_work), intent(inout):: work + class(rmap_opts), intent(inout):: opts + real*8 , intent(in) :: spac(:) + real*8 , intent(in) :: tDEL + logical, intent(in) :: mask(:) + real*8 , intent(in) :: qbar(:,:,:) + real*8 , intent(in) :: uvel(:) + real*8 , intent(out) :: qedg(:,:) + class(rcon_ends), intent(in) :: bclo(:) + class(rcon_ends), intent(in) :: bchi(:) + + !------------------------------------------- variables ! + integer :: head,tail,nprt + + head = +0 ; tail = +0 ; qedg = 0.e+0 + + do while (.true.) + + !--------------------------------- 1. find active part ! + + do head = tail+1, npos-1 + if (mask(head) .eqv..true.) exit + end do + + do tail = head+1, npos-1 + if (mask(tail).neqv..true.) exit + end do + tail = tail - 1 + + if (head.ge.npos) exit + + !--------------------------------- 2. rcon active part ! + + nprt = tail - head + 1 + + if (size(spac).ne.+1) then + + call rcon1d(nprt+1,nvar,ndof , & + & spac( head:tail), & + & qbar(:,:,head:tail), & + & bclo,bchi,work%cell_func, & + & work,opts ) + + else + + call rcon1d(nprt+1,nvar,ndof , & + & spac,qbar(:,:,head:tail), & + & bclo,bchi,work%cell_func, & + & work,opts ) + + end if + + !--------------------------------- 3. int. active part ! + + select case(opts%cell_meth) + case(pcm_method) !! 1st-order scheme + + if (size(spac).ne.+1) then + + call flux1d(nprt+1,nvar,1, & + & spac( head:tail+0) , & + & tDEL, & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + else + + call flux1d(nprt+1,nvar,1, & + & spac,tDEL , & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + end if + + case(plm_method) !! 2nd-order scheme + + if (size(spac).ne.+1) then + + call flux1d(nprt+1,nvar,2, & + & spac( head:tail+0) , & + & tDEL, & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + else + + call flux1d(nprt+1,nvar,2, & + & spac,tDEL , & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + end if + + case(ppm_method) !! 3rd-order scheme + + if (size(spac).ne.+1) then + + call flux1d(nprt+1,nvar,3, & + & spac( head:tail+0) , & + & tDEL, & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + else + + call flux1d(nprt+1,nvar,3, & + & spac,tDEL , & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + end if + + case(pqm_method) !! 5th-order scheme + + if (size(spac).ne.+1) then + + call flux1d(nprt+1,nvar,5, & + & spac( head:tail+0) , & + & tDEL, & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + else + + call flux1d(nprt+1,nvar,5, & + & spac,tDEL , & + & uvel( head:tail+1) , & + & work%cell_func, & + & qedg(:,head:tail+1) ) + + end if + + end select + + end do + + return + + end subroutine + + ! FLUX1D: a degree-k, upwind-type flux reconstruction. ! + + pure subroutine flux1d(npos,nvar,mdof,SPAC, & + & tDEL,uvel,QHAT,qedg) + + ! + ! NPOS no. edges over grid. + ! NVAR no. state variables. + ! MDOF no. degrees-of-freedom per QHAT. + ! SPAC grid spacing vector. SIZE(SPAC)==+1 if uniform . + ! TDEL time-step . + ! UVEL edge-centred velocity vectors. UVEL has SIZE = + ! NPOS-by-1 . + ! QHAT cell-centred polynomial recon. QHAT has SIZE = + ! NDOF-by-NVAR-by-NPOS-1 . + ! QEDG edge-centred upwind flux eval. QEDG has SIZE = + ! NVAR-by-NPOS . + ! + + implicit none + + !------------------------------------------- arguments ! + integer, intent(in) :: npos,nvar,mdof + real*8 , intent(in) :: SPAC(:) + real*8 , intent(in) :: tDEL + real*8 , intent(in) :: uvel(:) + real*8 , intent(in) :: QHAT(:,:,:) + real*8 , intent(out) :: qedg(:,:) + + !------------------------------------------- variables ! + integer :: ipos,ivar + real*8 :: uCFL,xhat,ss11,ss22,flux + real*8 :: vv11(1:5) + real*8 :: vv22(1:5) + real*8 :: ivec(1:5) + + !----------- single-cell, lagrangian-type upwind rcon. ! + + do ipos = +2 , npos - 1 + + if (uvel(ipos) .gt. +0.e0) then + + !----------- integrate profile over upwind cell IPOS-1 ! + + if (size(SPAC).ne.+1) then + xhat = .5d0 * SPAC(ipos-1) + uCFL = uvel(ipos) & + & * tDEL / SPAC(ipos-1) + else + xhat = .5d0 * SPAC( +1) + uCFL = uvel(ipos) & + & * tDEL / SPAC( +1) + end if + + ss11 = +1.e0 - 2.e0 * uCFL + ss22 = +1.e0 + + call bfun1d(-1,mdof,ss11,vv11) + call bfun1d(-1,mdof,ss22,vv22) + + ivec = vv22 - vv11 + + do ivar = +1, nvar + + flux = dot_product ( & + & ivec(1:mdof), & + & QHAT(1:mdof,ivar,ipos-1) ) + + flux = flux * xhat + + qedg(ivar,ipos) = flux + + end do + + else & + & if (uvel(ipos) .lt. -0.e0) then + + !----------- integrate profile over upwind cell IPOS+0 ! + + if (size(SPAC).ne.+1) then + xhat = .5d0 * SPAC(ipos-0) + uCFL = uvel(ipos) & + & * tDEL / SPAC(ipos-0) + else + xhat = .5d0 * SPAC( +1) + uCFL = uvel(ipos) & + & * tDEL / SPAC( +1) + end if + + ss11 = -1.e0 - 2.e0 * uCFL + ss22 = -1.e0 + + call bfun1d(-1,mdof,ss11,vv11) + call bfun1d(-1,mdof,ss22,vv22) + + ivec = vv22 - vv11 + + do ivar = +1, nvar + + flux = dot_product ( & + & ivec(1:mdof), & + & QHAT(1:mdof,ivar,ipos-0) ) + + flux = flux * xhat + + qedg(ivar,ipos) = flux + + end do + + end if + + end do + + return + + end subroutine + + + + + + !------------------------------------------ end ppr_1d ! + + + end module + + + diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/axis_def_nemo.xml b/cfgs/ORCA2_OCE_MIXED/EXP00/axis_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..1ccdc4912db6116c4f1c2da4294bf33e556b888d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/axis_def_nemo.xml @@ -0,0 +1 @@ +../../SHARED/axis_def_nemo.xml \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/context_nemo.xml b/cfgs/ORCA2_OCE_MIXED/EXP00/context_nemo.xml new file mode 100644 index 0000000000000000000000000000000000000000..bd06344b40d66ba3b0dcc45498cdff3c88490354 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/context_nemo.xml @@ -0,0 +1,42 @@ + + + + + + 1900 + 01 + 01 + 1026.0 + 3991.86795711963 + 0.99530670233846 + 917.0 + 330.0 + 1.e20 + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/domain_def_nemo.xml b/cfgs/ORCA2_OCE_MIXED/EXP00/domain_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..37482d1b32e013eb7861cc4cbd4a03d468ddff06 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/domain_def_nemo.xml @@ -0,0 +1 @@ +../../SHARED/domain_def_nemo.xml \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/field_def_nemo-ice.xml b/cfgs/ORCA2_OCE_MIXED/EXP00/field_def_nemo-ice.xml new file mode 120000 index 0000000000000000000000000000000000000000..8d41d507e2c112142f90b9b8deb0329cd0eab73a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/field_def_nemo-ice.xml @@ -0,0 +1 @@ +../../SHARED/field_def_nemo-ice.xml \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/field_def_nemo-oce.xml b/cfgs/ORCA2_OCE_MIXED/EXP00/field_def_nemo-oce.xml new file mode 120000 index 0000000000000000000000000000000000000000..0e209593f235eee38043b2a20592006673492720 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/field_def_nemo-oce.xml @@ -0,0 +1 @@ +../../SHARED/field_def_nemo-oce.xml \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/field_def_nemo-pisces.xml b/cfgs/ORCA2_OCE_MIXED/EXP00/field_def_nemo-pisces.xml new file mode 120000 index 0000000000000000000000000000000000000000..ee60c11e381c91f3ba94405b50ecced4be8de64d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/field_def_nemo-pisces.xml @@ -0,0 +1 @@ +../../SHARED/field_def_nemo-pisces.xml \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/file_def_nemo-ice.xml b/cfgs/ORCA2_OCE_MIXED/EXP00/file_def_nemo-ice.xml new file mode 100644 index 0000000000000000000000000000000000000000..c43f79d64b7baab6a332109a4fd773bde8a7f917 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/file_def_nemo-ice.xml @@ -0,0 +1,155 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/file_def_nemo-oce.xml b/cfgs/ORCA2_OCE_MIXED/EXP00/file_def_nemo-oce.xml new file mode 100644 index 0000000000000000000000000000000000000000..c043f56fe5e9ae6fc252ae34d78b6c2660381ec9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/file_def_nemo-oce.xml @@ -0,0 +1,173 @@ + + + + + + + + + + @toce_e3t / @e3t + @soce_e3t / @e3t + + + + sqrt( @sst2 - @sst * @sst ) + sqrt( @ssh2 - @ssh * @ssh ) + @sstmax - @sstmin + + + @mldr10_1max - @mldr10_1min + + + + + + + + + + + + + + + + + + + + @uoce_e3u / @e3u + + + + + + + + + + + + @voce_e3v / @e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/file_def_nemo-pisces.xml b/cfgs/ORCA2_OCE_MIXED/EXP00/file_def_nemo-pisces.xml new file mode 100644 index 0000000000000000000000000000000000000000..a43a193076bd4454341471322d88afd096653bef --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/file_def_nemo-pisces.xml @@ -0,0 +1,128 @@ + + + + + + + + + + tdenit * 14. * 86400. * 365. / 1e12 + tnfix * 14. * 86400. * 365. / 1e12 + tcflx * -1. * 12. * 86400. * 365. / 1e15 + tcflxcum * -1. * 12. / 1e15 + tcexp * 12. * 86400. * 365. / 1e15 + tintpp * 12. * 86400. * 365. / 1e15 + pno3tot * 16. / 117. * 1e6 + ppo4tot * 1. / 117. * 1e6 + psiltot * 1e6 + palktot * 1e6 + pfertot * 1e9 + + + + + + + + + @DIC_e3t / @e3t + @Alkalini_e3t / @e3t + @O2_e3t / @e3t + @PO4_e3t / @e3t + @Si_e3t / @e3t + @Fer_e3t / @e3t + @NCHL_e3t / @e3t + @DCHL_e3t / @e3t + @NO3_e3t / @e3t + + + + + + + + + + + + + @DIC_e3t / @e3t + @Alkalini_e3t / @e3t + @O2_e3t / @e3t + @CaCO3_e3t / @e3t + @PO4_e3t / @e3t + @POC_e3t / @e3t + @Si_e3t / @e3t + @PHY_e3t / @e3t + @ZOO_e3t / @e3t + @DOC_e3t / @e3t + @PHY2_e3t / @e3t + @ZOO2_e3t / @e3t + @DSi_e3t / @e3t + @Fer_e3t / @e3t + @BFe_e3t / @e3t + @GOC_e3t / @e3t + @SFe_e3t / @e3t + @DFe_e3t / @e3t + @GSi_e3t / @e3t + @NFe_e3t / @e3t + @NCHL_e3t / @e3t + @DCHL_e3t / @e3t + @NO3_e3t / @e3t + @NH4_e3t / @e3t + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/grid_def_nemo.xml b/cfgs/ORCA2_OCE_MIXED/EXP00/grid_def_nemo.xml new file mode 120000 index 0000000000000000000000000000000000000000..a279623c6d56ac41854ef1d315057c6e0bae37e5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/grid_def_nemo.xml @@ -0,0 +1 @@ +../../SHARED/grid_def_nemo.xml \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/iodef.xml b/cfgs/ORCA2_OCE_MIXED/EXP00/iodef.xml new file mode 100644 index 0000000000000000000000000000000000000000..d4be5c1bd4104bfd3e1a69db33d6647804565cf9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/iodef.xml @@ -0,0 +1,26 @@ + + + + + + + + + + + + 10 + false + false + oceanx + + + + + + + + + + + diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_cfg b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_cfg new file mode 100644 index 0000000000000000000000000000000000000000..7f302e9a0770f7aafe9596bf6d99a9449fe77169 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_cfg @@ -0,0 +1,455 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! ORCA2 - ICE - PISCES configuration !! +!!====================================================================== +!! *** Domain & Run management namelists *** !! +!! !! +!! namrun parameters of the run +!! namdom space and time domain +!! namcfg parameters of the configuration (default: user defined GYRE) +!! namwad Wetting and drying (default: OFF) +!! namtsd data: temperature & salinity (default: OFF) +!! namcrs coarsened grid (for outputs and/or TOP) (ln_crs =T) +!! namc1d 1D configuration options (ln_c1d =T) +!! namc1d_dyndmp 1D newtonian damping applied on currents (ln_c1d =T) +!! namc1d_uvd 1D data (currents) (ln_c1d =T) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + cn_exp = "ORCA2" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 5840 ! last time step (std 5475) + nn_istate = 0 ! output the initial state (1) or not (0) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + rn_Dt = 5400. ! time step for the dynamics and tracer +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) +!----------------------------------------------------------------------- + ln_read_cfg = .true. ! (=T) read the domain configuration file + cn_domcfg = "ORCA_R2_zps_domcfg" ! domain configuration filename + ! + ln_closea = .false. ! F => suppress closed seas (defined by closea_mask field) + ! ! from the bathymetry at runtime. +/ +!----------------------------------------------------------------------- +&namtile ! parameters of the tiling +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF) +!----------------------------------------------------------------------- + ! ! =T read T-S fields for: + ln_tsd_init = .true. ! ocean initialisation + ln_tsd_dmp = .true. ! T-S restoring (see namtra_dmp) + + cn_dir = './' ! root directory for the T-S data location + !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! + sn_tem = 'data_1m_potential_temperature_nomask', -1. ,'votemper', .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'data_1m_salinity_nomask' , -1. ,'vosaline', .true. , .true. , 'yearly' , '' , '' , '' +/ +!!====================================================================== +!! *** Surface Boundary Condition namelists *** !! +!! !! +!! namsbc surface boundary condition manager (default: NO selection) +!! namsbc_flx flux formulation (ln_flx =T) +!! namsbc_blk Bulk formulae formulation (ln_blk =T) +!! namsbc_cpl CouPLed formulation ("key_oasis3" ) +!! namsbc_sas Stand-Alone Surface module (SAS_SRC only) +!! namsbc_iif Ice-IF: use observed ice cover (nn_ice = 1 ) +!! namtra_qsr penetrative solar radiation (ln_traqsr =T) +!! namsbc_ssr sea surface restoring term (for T and/or S) (ln_ssr =T) +!! namsbc_rnf river runoffs (ln_rnf =T) +!! namsbc_apr Atmospheric Pressure (ln_apr_dyn =T) +!! namsbc_isf ice shelf melting/freezing (ln_isfcav =T : read (ln_read_cfg=T) or set or usr_def_zgr ) +!! namsbc_iscpl coupling option between land ice model and ocean (ln_isfcav =T) +!! namsbc_wave external fields from wave model (ln_wave =T) +!! namberg iceberg floats (ln_icebergs=T) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namsbc ! Surface Boundary Condition manager (default: NO selection) +!----------------------------------------------------------------------- + nn_fsbc = 4 ! frequency of SBC module call + ! (also = the frequency of sea-ice & iceberg model call) + ! Type of air-sea fluxes + ln_blk = .true. ! Bulk formulation (T => fill namsbc_blk ) + ! Sea-ice : + nn_ice = 2 ! =0 no ice boundary condition + ! ! =1 use observed ice-cover ( => fill namsbc_iif ) + ! ! =2 or 3 for SI3 and CICE, respectively + ! Misc. options of sbc : + ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr) + ln_ssr = .true. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + ln_rnf = .true. ! runoffs (T => fill namsbc_rnf) + nn_fwb = 2 ! FreshWater Budget: + ! ! =2 annual global mean of e-p-r set to zero + ln_wave = .false. ! Activate coupling with wave (T => fill namsbc_wave) +/ +!----------------------------------------------------------------------- +&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T) +!----------------------------------------------------------------------- + ! ! bulk algorithm : + ln_NCAR = .true. ! "NCAR" algorithm (Large and Yeager 2008) + + cn_dir = './' ! root directory for the bulk data location + !___________!_________________________!___________________!___________!_____________!________!___________!______________________________________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! + sn_wndi = 'u_10.15JUNE2009_fill' , 6. , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Uwnd' , '' + sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bicub' , 'Vwnd' , '' + sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' + sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' + sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' + sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' + sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' + sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' + sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core2_orca2_bilin' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_abl ! Atmospheric Boundary Layer formulation (ln_abl = T) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .true. ! RGB light penetration (Red-Green-Blue) + ! + nn_chldta = 1 ! RGB : Chl data (=1) or cst value (=0) + + cn_dir = './' ! root directory for the chlorophyl data location + !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! + sn_chl ='chlorophyll' , -1. , 'CHLA' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_ssr ! surface boundary condition : sea surface restoring (ln_ssr =T) +!----------------------------------------------------------------------- + nn_sssr = 2 ! add a damping term to the surface freshwater flux + rn_deds = -166.67 ! magnitude of the damping on salinity [mm/day] + ln_sssr_bnd = .true. ! flag to bound erp term (associated with nn_sssr=2) + rn_sssr_bnd = 4.e0 ! ABS(Max/Min) value of the damping erp term [mm/day] +/ +!----------------------------------------------------------------------- +&namsbc_rnf ! runoffs (ln_rnf =T) +!----------------------------------------------------------------------- + ln_rnf_mouth = .true. ! specific treatment at rivers mouths + rn_hrnf = 15.e0 ! depth over which enhanced vertical mixing is used (ln_rnf_mouth=T) + rn_avt_rnf = 1.e-3 ! value of the additional vertical mixing coef. [m2/s] (ln_rnf_mouth=T) + rn_rfact = 1.e0 ! multiplicative factor for runoff + + cn_dir = './' ! root directory for the location of the runoff files + !___________!_____________!___________________!___________!_____________!_________!___________!__________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename ! + sn_rnf = 'runoff_core_monthly', -1. , 'sorunoff', .true. , .true. , 'yearly' , '' , '' , '' + sn_cnf = 'runoff_core_monthly', 0. , 'socoefr0', .false. , .true. , 'yearly' , '' , '' , '' + sn_s_rnf = 'runoffs' , 24. , 'rosaline', .true. , .true. , 'yearly' , '' , '' , '' + sn_t_rnf = 'runoffs' , 24. , 'rotemper', .true. , .true. , 'yearly' , '' , '' , '' + sn_dep_rnf = 'runoffs' , 0. , 'rodepth' , .false. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_wave ! External fields from wave model (ln_wave=T) +!----------------------------------------------------------------------- + ln_sdw = .false. ! get the 2D Surf Stokes Drift & Compute the 3D stokes drift + ln_stcor = .false. ! add Stokes Coriolis and tracer advection terms + ln_cdgw = .false. ! Neutral drag coefficient read from wave model + ln_tauoc = .false. ! ocean stress is modified by wave induced stress + ln_wave_test= .false. ! Test case with constant wave fields +! + ln_charn = .false. ! Charnock coefficient read from wave model (IFS only) + ln_taw = .false. ! ocean stress is modified by wave induced stress (coupled mode) + ln_phioc = .false. ! TKE flux from wave model + ln_bern_srfc= .false. ! wave induced pressure. Bernoulli head J term + ln_breivikFV_2016 = .false. ! breivik 2016 vertical stokes profile + ln_vortex_force = .false. +! + cn_dir = './' ! root directory for the waves data location + !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! + sn_cdg = 'sdw_ecwaves_orca2' , 6. , 'drag_coeff' , .true. , .true. , 'yearly' , '' , '' , '' + sn_usd = 'sdw_ecwaves_orca2' , 6. , 'u_sd2d' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vsd = 'sdw_ecwaves_orca2' , 6. , 'v_sd2d' , .true. , .true. , 'yearly' , '' , '' , '' + sn_hsw = 'sdw_ecwaves_orca2' , 6. , 'hs' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wmp = 'sdw_ecwaves_orca2' , 6. , 'wmp' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnum = 'sdw_ecwaves_orca2' , 6. , 'wave_num' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namberg ! iceberg parameters (default: OFF) +!----------------------------------------------------------------------- + ln_icebergs = .true. ! activate iceberg floats (force =F with "key_agrif") + + cn_dir = './' ! root directory for the location of drag coefficient files + !______!___________!___________________!______________!______________!_________!___________!__________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F ) ! 'monthly' ! filename ! pairing ! filename ! + sn_icb = 'calving', -1. , 'calving' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!!====================================================================== +!! *** Lateral boundary condition *** !! +!! !! +!! namlbc lateral momentum boundary condition (default: NO selection) +!! namagrif agrif nested grid (read by child model only) ("key_agrif") +!! nam_tide Tidal forcing (default: OFF) +!! nambdy Unstructured open boundaries (default: OFF) +!! nambdy_dta Unstructured open boundaries - external data (see nambdy) +!! nambdy_tide tidal forcing at open boundaries (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namlbc ! lateral momentum boundary condition (default: NO selection) +!----------------------------------------------------------------------- + rn_shlat = 2. ! no slip +/ +!----------------------------------------------------------------------- +&namagrif ! AGRIF zoom ("key_agrif") +!----------------------------------------------------------------------- + ln_spc_dyn = .true. ! use 0 as special value for dynamics + rn_sponge_tra = 2880. ! coefficient for tracer sponge layer [m2/s] + rn_sponge_dyn = 2880. ! coefficient for dynamics sponge layer [m2/s] + ln_chk_bathy = .false. ! =T check the parent bathymetry +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!! !! +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_drg_OFF=F & ln_isfcav=T) +!! namdrg_bot bottom friction (ln_drg_OFF=F) +!! nambbc bottom temperature boundary condition (default: OFF) +!! nambbl bottom boundary layer scheme (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdrg ! top/bottom drag coefficient (default: NO selection) +!----------------------------------------------------------------------- + ln_lin = .true. ! linear drag: Cd = Cd0 Uc0 +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .true. ! Apply a geothermal heating at the ocean bottom + nn_geoflx = 2 ! geothermal heat flux: = 2 read variable flux [mW/m2] + + cn_dir = './' ! root directory for the geothermal data location + !___________!_________________________!___________________!___________!_____________!________!___________!__________________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! + sn_qgh ='geothermal_heating.nc' , -12. , 'heatflow', .false. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&nambbl ! bottom boundary layer scheme (default: OFF) +!----------------------------------------------------------------------- + ln_trabbl = .true. ! Bottom Boundary Layer parameterisation flag + nn_bbl_ldf = 1 ! diffusive bbl (=1) or not (=0) + nn_bbl_adv = 0 ! advective bbl (=1/2) or not (=0) + rn_ahtbbl = 1000. ! lateral mixing coefficient in the bbl [m2/s] + rn_gambbl = 10. ! advective bbl coefficient [s] +/ +!!====================================================================== +!! Tracer (T-S) namelists !! +!! !! +!! nameos equation of state (default: NO selection) +!! namtra_adv advection scheme (default: NO selection) +!! namtra_ldf lateral diffusion scheme (default: NO selection) +!! namtra_mle mixed layer eddy param. (Fox-Kemper param.) (default: OFF) +!! namtra_eiv eddy induced velocity param. (default: OFF) +!! namtra_dmp T & S newtonian damping (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nameos ! ocean Equation Of Seawater (default: NO selection) +!----------------------------------------------------------------------- + ln_eos80 = .true. ! = Use EOS80 +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_fct = .true. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ln_traldf_lap = .true. ! laplacian operator + ln_traldf_iso = .true. ! iso-neutral (Standard operator) + ln_traldf_msc = .true. ! Method of Stabilizing Correction (both operators) + ! ! Coefficients: + nn_aht_ijk_t = 20 ! space/time variation of eddy coef + ! ! = 20 aht = 1/2 Ud. max(e1,e2) + rn_Ud = 0.018 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30) + rn_Ld = 200.e+3 ! lateral diffusive length [m] (nn_aht_ijk_t= 0, 10) +/ +!----------------------------------------------------------------------- +&namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF) +!----------------------------------------------------------------------- + ln_mle = .true. ! (T) use the Mixed Layer Eddy (MLE) parameterisation +/ +!----------------------------------------------------------------------- +&namtra_eiv ! eddy induced velocity param. (default: OFF) +!----------------------------------------------------------------------- + ln_ldfeiv = .true. ! use eddy induced velocity parameterization + ! ! Coefficients: + nn_aei_ijk_t = 21 ! space/time variation of the eiv coeficient + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! time invariant coefficients: aei0 = 1/2 Ue*Le + rn_Ue = 0.03 ! lateral diffusive velocity [m/s] (nn_aht_ijk_t= 0, 10, 20, 30) + rn_Le = 200.e+3 ! lateral diffusive length [m] (nn_aht_ijk_t= 0, 10) + ! + ln_ldfeiv_dia =.true. ! diagnose eiv stream function and velocities +/ +!----------------------------------------------------------------------- +&namtra_dmp ! tracer: T & S newtonian damping (default: OFF) +!----------------------------------------------------------------------- + ln_tradmp = .true. ! add a damping term (using resto.nc coef.) + nn_zdmp = 0 ! vertical shape =0 damping throughout the water column +/ +!!====================================================================== +!! *** Dynamics namelists *** !! +!! !! +!! nam_vvl vertical coordinate options (default: z-star) +!! namdyn_adv formulation of the momentum advection (default: NO selection) +!! namdyn_vor advection scheme (default: NO selection) +!! namdyn_hpg hydrostatic pressure gradient (default: NO selection) +!! namdyn_spg surface pressure gradient (default: NO selection) +!! namdyn_ldf lateral diffusion scheme (default: NO selection) +!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_vec = .true. ! vector form - 2nd centered scheme + nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) +!----------------------------------------------------------------------- + ln_dynvor_een = .true. ! energy & enstrophy scheme +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_lap = .true. ! laplacian operator + ln_dynldf_lev = .true. ! iso-level + nn_ahm_ijk_t = -30 ! =-30 3D coeff. read in eddy_diffusivity_3D.nc +/ +!!====================================================================== +!! vertical physics namelists !! +!! !! +!! namzdf vertical physics manager (default: NO selection) +!! namzdf_ric richardson number vertical mixing (ln_zdfric=T) +!! namzdf_tke TKE vertical mixing (ln_zdftke=T) +!! namzdf_gls GLS vertical mixing (ln_zdfgls=T) +!! namzdf_osm OSM vertical diffusion (ln_zdfosm=T) +!! namzdf_iwm tidal mixing parameterization (ln_zdfiwm=T) +!!====================================================================== +! +!----------------------------------------------------------------------- +&namzdf ! vertical physics manager (default: NO selection) +!----------------------------------------------------------------------- + ln_zdftke = .true. ! Turbulent Kinetic Energy closure (T => fill namzdf_tke) + ln_zdfevd = .true. ! Enhanced Vertical Diffusion scheme + nn_evdm = 0 ! evd apply on tracer (=0) or on tracer and momentum (=1) + rn_evd = 100. ! evd mixing coefficient [m2/s] + ln_zdfddm = .true. ! double diffusive mixing + rn_avts = 1.e-4 ! maximum avs (vertical mixing on salinity) + rn_hsbfr = 1.6 ! heat/salt buoyancy flux ratio + ln_zdfiwm = .true. ! internal wave-induced mixing (T => fill namzdf_iwm) + ! ! Coefficients + rn_avm0 = 1.2e-4 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 1.2e-5 ! vertical eddy diffusivity [m2/s] (background Kz if ln_zdfcst=F) + nn_avb = 0 ! profile for background avt & avm (=1) or not (=0) + nn_havtb = 1 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T) +!----------------------------------------------------------------------- + nn_mxl = 3 ! mixing length: = 0 bounded by the distance to surface and bottom + ! ! = 1 bounded by the local vertical scale factor + ! ! = 2 first vertical derivative of mixing length bounded by 1 + ! ! = 3 as =2 with distinct dissipative an mixing length scale + nn_etau = 1 ! penetration of tke below the mixed layer (ML) due to NIWs + ! ! = 0 none ; = 1 add a tke source below the ML + ! ! = 2 add a tke source just at the base of the ML + ! ! = 3 as = 1 applied on HF part of the stress (ln_cpl=T) + ln_mxhsw = .false. ! surface mixing length scale = F(wave height) +/ +!----------------------------------------------------------------------- +&namzdf_iwm ! internal wave-driven mixing parameterization (ln_zdfiwm =T) +!----------------------------------------------------------------------- + ln_mevar = .false. ! variable (T) or constant (F) mixing efficiency + ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F) + + cn_dir = './' ! root directory for the iwm data location + !___________!_________________________!___________________!_____________!_____________!________!___________!__________________!__________!_______________! + ! ! file name ! frequency (hours) ! variable ! time interp.! clim ! 'yearly'/ ! weights filename ! rotation ! land/sea mask ! + ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! ! pairing ! filename ! + sn_mpb = 'zdfiwm_forcing_orca2' , -12. , 'power_bot' , .false. , .true. , 'yearly' , '' , '' , '' + sn_mpc = 'zdfiwm_forcing_orca2' , -12. , 'power_cri' , .false. , .true. , 'yearly' , '' , '' , '' + sn_mpn = 'zdfiwm_forcing_orca2' , -12. , 'power_nsq' , .false. , .true. , 'yearly' , '' , '' , '' + sn_mps = 'zdfiwm_forcing_orca2' , -12. , 'power_sho' , .false. , .true. , 'yearly' , '' , '' , '' + sn_dsb = 'zdfiwm_forcing_orca2' , -12. , 'scale_bot' , .false. , .true. , 'yearly' , '' , '' , '' + sn_dsc = 'zdfiwm_forcing_orca2' , -12. , 'scale_cri' , .false. , .true. , 'yearly' , '' , '' , '' +/ +!!====================================================================== +!! *** Diagnostics namelists *** !! +!! !! +!! namtrd dynamics and/or tracer trends (default: OFF) +!! namhsb Heat and salt budgets (default: OFF) +!! namdiu Cool skin and warm layer models (default: OFF) +!! namdiu Cool skin and warm layer models (default: OFF) +!! namflo float parameters (default: OFF) +!! nam_diadct transports through some sections (default: OFF) +!! nam_dia25h 25h Mean Output (default: OFF) +!! namnc4 netcdf4 chunking and compression settings ("key_netcdf4") +!!====================================================================== +! +!!====================================================================== +!! *** Observation & Assimilation *** !! +!! !! +!! namobs observation and model comparison (default: OFF) +!! nam_asminc assimilation increments ('key_asminc') +!!====================================================================== +! +!!====================================================================== +!! *** Miscellaneous namelists *** !! +!! !! +!! nammpp Massively Parallel Processing +!! namctl Control prints (default: OFF) +!! namsto Stochastic parametrization of EOS (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_ice_cfg b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_ice_cfg new file mode 100644 index 0000000000000000000000000000000000000000..40ad62b00f1851a9d5df68d7a53f9df07381a630 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_ice_cfg @@ -0,0 +1,84 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! SI3 configuration namelist: Overwrites SHARED/namelist_ice_ref +!! 1 - Generic parameters (nampar) +!! 2 - Ice thickness discretization (namitd) +!! 3 - Ice dynamics (namdyn) +!! 4 - Ice ridging/rafting (namdyn_rdgrft) +!! 5 - Ice rheology (namdyn_rhg) +!! 6 - Ice advection (namdyn_adv) +!! 7 - Ice surface boundary conditions (namsbc) +!! 8 - Ice thermodynamics (namthd) +!! 9 - Ice heat diffusion (namthd_zdf) +!! 10 - Ice lateral melting (namthd_da) +!! 11 - Ice growth in open water (namthd_do) +!! 12 - Ice salinity (namthd_sal) +!! 13 - Ice melt ponds (namthd_pnd) +!! 14 - Ice initialization (namini) +!! 15 - Ice/snow albedos (namalb) +!! 16 - Ice diagnostics (namdia) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! +!------------------------------------------------------------------------------ +&nampar ! Generic parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namitd ! Ice discretization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn ! Ice dynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rdgrft ! Ice ridging/rafting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_rhg ! Ice rheology +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdyn_adv ! Ice advection +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namsbc ! Ice surface boundary conditions +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd ! Ice thermodynamics +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_zdf ! Ice heat diffusion +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_do ! Ice growth in open water +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_sal ! Ice salinity +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namthd_pnd ! Melt ponds +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namini ! Ice initialization +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namalb ! albedo parameters +!------------------------------------------------------------------------------ +/ +!------------------------------------------------------------------------------ +&namdia ! Diagnostics +!------------------------------------------------------------------------------ +/ diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_ice_ref b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_ice_ref new file mode 120000 index 0000000000000000000000000000000000000000..46b604583df4e381310f02355cef579a393f2be7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_ice_ref @@ -0,0 +1 @@ +../../SHARED/namelist_ice_ref \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_pisces_cfg b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_pisces_cfg new file mode 100644 index 0000000000000000000000000000000000000000..f67b07c4201e8ffed4eec3f2454fe6077d89f1c4 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_pisces_cfg @@ -0,0 +1,141 @@ +!----------------------------------------------------------------------- +&nampismod ! Model used +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisext ! air-sea exchange +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisatm ! Atmospheric prrssure +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisbio ! biological parameters +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zlim ! parameters for nutrient limitations for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zlim ! parameters for nutrient limitations PISCES QUOTA - ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zquota ! parameters for nutrient limitations PISCES quota - ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisopt ! parameters for optics +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zprod ! parameters for phytoplankton growth for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zprod ! parameters for phytoplankton growth for PISCES quota- ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zmort ! parameters for phytoplankton sinks for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zmort ! parameters for phytoplankton sinks for PISCES quota - ln_p5z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zmes ! parameters for mesozooplankton for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zmes ! parameters for mesozooplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp4zzoo ! parameters for microzooplankton for PISCES std - ln_p4z +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namp5zzoo ! parameters for microzooplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisfer ! parameters for iron chemistry +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisrem ! parameters for remineralization +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampispoc ! parameters for organic particles +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampiscal ! parameters for Calcite chemistry +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisbc ! parameters for inputs deposition +!----------------------------------------------------------------------- + sn_dust = 'dust.orca.new' , -1 , 'dust' , .true. , .true. , 'yearly' , '' , '' , '' + ln_ironsed = .true. ! boolean for Fe input from sediments + ln_ironice = .true. ! boolean for Fe input from sea ice + ln_hydrofe = .true. ! boolean for from hydrothermal vents +/ +!----------------------------------------------------------------------- +&nampissed ! parameters for sediments mobilization +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampislig ! Namelist parameters for ligands, nampislig +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisice ! Prescribed sea ice tracers +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nampisdmp ! Damping +!----------------------------------------------------------------------- + nn_pisdmp = 5840 ! Frequency of Relaxation +/ +!----------------------------------------------------------------------- +&nampismass ! Mass conservation +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobphy ! biological parameters for phytoplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobnut ! biological parameters for nutrients +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobzoo ! biological parameters for zooplankton +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobdet ! biological parameters for detritus +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobdom ! biological parameters for DOM +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobsed ! parameters from aphotic layers to sediment +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobrat ! general coefficients +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namlobopt ! optical parameters +!----------------------------------------------------------------------- +/ diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_pisces_ref b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_pisces_ref new file mode 120000 index 0000000000000000000000000000000000000000..1af37ed08081e87b1a2af44648602b809bb0c651 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_pisces_ref @@ -0,0 +1 @@ +../../SHARED/namelist_pisces_ref \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_ref b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_ref new file mode 120000 index 0000000000000000000000000000000000000000..730143a114bce42d8dc3e86726f733b6c690078a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_ref @@ -0,0 +1 @@ +../../SHARED/namelist_ref \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_top_cfg b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_top_cfg new file mode 100644 index 0000000000000000000000000000000000000000..55f9f177c690fa4089cbd5526ef1a65085c1c94a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_top_cfg @@ -0,0 +1,145 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/TOP1 : Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_top_ref +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!----------------------------------------------------------------------- +&namtrc_run ! run information +!----------------------------------------------------------------------- + ln_top_euler = .true. +/ +!----------------------------------------------------------------------- +&namtrc ! tracers definition +!----------------------------------------------------------------------- + jp_bgc = 24 +! + ln_pisces = .true. + ln_my_trc = .false. + ln_age = .false. + ln_cfc11 = .false. + ln_cfc12 = .false. + ln_c14 = .false. +! + ln_trcdta = .true. ! Initialisation from data input file (T) or not (F) + ln_trcbc = .true. ! Enables Boundary conditions +! ! ! ! ! ! +! ! name ! title of the field ! units ! init ! sbc ! cbc ! obc ! ais + sn_tracer(1) = 'DIC ' , 'Dissolved inorganic Concentration ', 'mol-C/L' , .true. , .false., .true. , .false. , .false. + sn_tracer(2) = 'Alkalini' , 'Total Alkalinity Concentration ', 'eq/L ' , .true. , .false., .true. , .false. , .false. + sn_tracer(3) = 'O2 ' , 'Dissolved Oxygen Concentration ', 'mol-C/L' , .true. , .false., .false., .false. , .false. + sn_tracer(4) = 'CaCO3 ' , 'Calcite Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(5) = 'PO4 ' , 'Phosphate Concentration ', 'mol-C/L' , .true. , .true. , .true. , .false. , .false. + sn_tracer(6) = 'POC ' , 'Small organic carbon Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(7) = 'Si ' , 'Silicate Concentration ', 'mol-C/L' , .true. , .true. , .true. , .false. , .false. + sn_tracer(8) = 'PHY ' , 'Nanophytoplankton Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(9) = 'ZOO ' , 'Microzooplankton Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(10) = 'DOC ' , 'Dissolved organic Concentration ', 'mol-C/L' , .true. , .false., .true. , .false. , .false. + sn_tracer(11) = 'PHY2 ' , 'Diatoms Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(12) = 'ZOO2 ' , 'Mesozooplankton Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(13) = 'DSi ' , 'Diatoms Silicate Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(14) = 'Fer ' , 'Dissolved Iron Concentration ', 'mol-C/L' , .true. , .true. , .true. , .false. , .true. + sn_tracer(15) = 'BFe ' , 'Big iron particles Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(16) = 'GOC ' , 'Big organic carbon Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(17) = 'SFe ' , 'Small iron particles Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(18) = 'DFe ' , 'Diatoms iron Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(19) = 'GSi ' , 'Sinking biogenic Silicate Concentration', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(20) = 'NFe ' , 'Nano iron Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(21) = 'NCHL ' , 'Nano chlorophyl Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(22) = 'DCHL ' , 'Diatoms chlorophyl Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. + sn_tracer(23) = 'NO3 ' , 'Nitrates Concentration ', 'mol-C/L' , .true. , .true. , .true. , .false. , .false. + sn_tracer(24) = 'NH4 ' , 'Ammonium Concentration ', 'mol-C/L' , .false. , .false., .false., .false. , .false. +/ +!----------------------------------------------------------------------- +&namage ! AGE +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_dta ! Initialisation from data input file +!----------------------------------------------------------------------- +! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! +! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename ! + sn_trcdta(1) = 'data_DIC_nomask.nc', -12 , 'PiDIC' , .false. , .true. , 'yearly' , 'weights_3D_r360x180_bilin.nc' , '' , '' + sn_trcdta(2) = 'data_ALK_nomask.nc', -12 , 'TALK' , .false. , .true. , 'yearly' , 'weights_3D_r360x180_bilin.nc' , '' , '' + sn_trcdta(3) = 'data_OXY_nomask.nc', -1 , 'O2' , .true. , .true. , 'yearly' , 'weights_3D_r360x180_bilin.nc' , '' , '' + sn_trcdta(5) = 'data_PO4_nomask.nc', -1 , 'PO4' , .true. , .true. , 'yearly' , 'weights_3D_r360x180_bilin.nc' , '' , '' + sn_trcdta(7) = 'data_SIL_nomask.nc', -1 , 'Si' , .true. , .true. , 'yearly' , 'weights_3D_r360x180_bilin.nc' , '' , '' + sn_trcdta(10) = 'data_DOC_nomask.nc', -1 , 'DOC' , .true. , .true. , 'yearly' , 'weights_3D_r360x180_bilin.nc' , '' , '' + sn_trcdta(14) = 'data_FER_nomask.nc', -1 , 'Fer' , .true. , .true. , 'yearly' , 'weights_3D_r360x180_bilin.nc' , '' , '' + sn_trcdta(23) = 'data_NO3_nomask.nc', -1 , 'NO3' , .true. , .true. , 'yearly' , 'weights_3D_r360x180_bilin.nc' , '' , '' + rn_trfac(1) = 1.028e-06 ! multiplicative factor + rn_trfac(2) = 1.028e-06 ! - - - - + rn_trfac(3) = 44.6e-06 ! - - - - + rn_trfac(5) = 117.0e-06 ! - - - - + rn_trfac(7) = 1.0e-06 ! - - - - + rn_trfac(10) = 1.0e-06 ! - - - - + rn_trfac(14) = 1.0e-06 ! - - - - + rn_trfac(23) = 7.3125e-06 ! - - - - +/ +!----------------------------------------------------------------------- +&namtrc_adv ! advection scheme for passive tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_trcadv_mus = .true. ! MUSCL scheme + ln_mus_ups = .false. ! use upstream scheme near river mouths +/ +!----------------------------------------------------------------------- +&namtrc_ldf ! lateral diffusion scheme for passive tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_trcldf_tra = .true. ! use active tracer setting +/ +!----------------------------------------------------------------------- +&namtrc_rad ! treatment of negative concentrations +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_snk ! sedimentation of particles +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_dmp ! passive tracer newtonian damping +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_ice ! Representation of sea ice growth & melt effects +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_trd ! diagnostics on tracer trends ('key_trdtrc') +!---------------------------------------------------------------------- +/ +!---------------------------------------------------------------------- +&namtrc_bc ! data for boundary conditions +!----------------------------------------------------------------------- +! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! +! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename ! + sn_trcsbc(5) = 'dust.orca.new' , -1 , 'dustpo4' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trcsbc(7) = 'dust.orca.new' , -1 , 'dustsi' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trcsbc(14) = 'dust.orca.new' , -1 , 'dustfer' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trcsbc(23) = 'ndeposition.orca', -12 , 'ndep' , .false. , .true. , 'yearly' , '' , '' , '' + rn_trsfac(5) = 7.9258065e-02 ! ( 0.021 / 31. * 117 ) + rn_trsfac(7) = 3.1316726e-01 ! ( 8.8 / 28.1 ) + rn_trsfac(14) = 6.2667860e-04 ! ( 0.035 / 55.85 ) + rn_trsfac(23) = 5.2232143e-01 ! ( From kgN m-2 s-1 to molC l-1 ====> zfact = 7.3125/14 ) + rn_sbc_time = 1. ! Time scaling factor for SBC and CBC data (seconds in a day) + ! + sn_trccbc(1) = 'river.orca' , 120 , 'riverdic' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trccbc(2) = 'river.orca' , 120 , 'riverdic' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trccbc(5) = 'river.orca' , 120 , 'riverdip' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trccbc(7) = 'river.orca' , 120 , 'riverdsi' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trccbc(10) = 'river.orca' , 120 , 'riverdoc' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trccbc(14) = 'river.orca' , 120 , 'riverdic' , .true. , .true. , 'yearly' , '' , '' , '' + sn_trccbc(23) = 'river.orca' , 120 , 'riverdin' , .true. , .true. , 'yearly' , '' , '' , '' + rn_trcfac(1) = 8.333333e+01 ! ( data in Mg/m2/yr : 1e3/12/ryyss) + rn_trcfac(2) = 8.333333e+01 ! ( 1e3 /12 ) + rn_trcfac(5) = 3.774193e+03 ! ( 1e3 / 31. * 117 ) + rn_trcfac(7) = 3.558719e+01 ! ( 1e3 / 28.1 ) + rn_trcfac(10) = 8.333333e+01 ! ( 1e3 / 12 + rn_trcfac(14) = 4.166667e-03 ! ( 1e3 / 12 * 5e-5 ) + rn_trcfac(23) = 5.223214e+02 ! ( 1e3 / 14 * 7.3125 ) + rn_cbc_time = 3.1536e+7 ! Time scaling factor for CBC data (seconds in a year) +/ +!---------------------------------------------------------------------- +&namtrc_bdy ! Setup of tracer boundary conditions +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtrc_ais ! Representation of Antarctic Ice Sheet tracers supply +!----------------------------------------------------------------------- +/ diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_top_ref b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_top_ref new file mode 120000 index 0000000000000000000000000000000000000000..fcdb44393e1873b82b0a1a7a930d85537d901e80 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/namelist_top_ref @@ -0,0 +1 @@ +../../SHARED/namelist_top_ref \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/EXP00/nemo b/cfgs/ORCA2_OCE_MIXED/EXP00/nemo new file mode 120000 index 0000000000000000000000000000000000000000..4b32aeaef71fe0a7fd5e31a1ac4b29e03234b727 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/EXP00/nemo @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/cfgs/ORCA2_OCE_MIXED_DEF_4/BLD/bin/nemo.exe \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/abl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/abl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..c34ac6793a21b8207428f2b75db83ecec1cb5443 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/abl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/abl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/asmbkg.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/asmbkg.F90 new file mode 120000 index 0000000000000000000000000000000000000000..05a74ed8bc8d7bb7468119a363de45f0e7cec149 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/asmbkg.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ASM/asmbkg.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/asminc.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/asminc.F90 new file mode 120000 index 0000000000000000000000000000000000000000..ff9bf4b134aa142bb0054c64bfe8fcd7e6399d2f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/asminc.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ASM/asminc.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/asmpar.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/asmpar.F90 new file mode 120000 index 0000000000000000000000000000000000000000..5a3d094b44dce9a6f7d06d9118b4054430c9ccbe --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/asmpar.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ASM/asmpar.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/bdy_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/bdy_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9a7f6d3ff6861d096d4db1f336c4021e7baf560e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/bdy_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/BDY/bdy_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/bdydta.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/bdydta.F90 new file mode 120000 index 0000000000000000000000000000000000000000..12318b3933f34f5bc242454b4759927eec3e82ea --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/bdydta.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/BDY/bdydta.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/bdydyn.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/bdydyn.F90 new file mode 120000 index 0000000000000000000000000000000000000000..3e11020a40ce295e768bbfba553c1033cfe97425 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/bdydyn.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/BDY/bdydyn.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/bdydyn2d.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/bdydyn2d.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d5c7dc87c39e9a8ee78c12d8fac834020184fab7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/bdydyn2d.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/BDY/bdydyn2d.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/bdydyn3d.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/bdydyn3d.F90 new file mode 120000 index 0000000000000000000000000000000000000000..c9fd32264b7b67e96f234a2820d1bff83a2b8a2a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/bdydyn3d.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/BDY/bdydyn3d.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/bdyice.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/bdyice.F90 new file mode 120000 index 0000000000000000000000000000000000000000..6d8050ebe8cc08793a0551d27b33b3258d7343fe --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/bdyice.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/BDY/bdyice.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/bdyini.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/bdyini.F90 new file mode 120000 index 0000000000000000000000000000000000000000..72e7554b868fd60742c3322ea1926394f9a316e4 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/bdyini.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/BDY/bdyini.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/bdylib.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/bdylib.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9400a0c913c0af823e8159f988664af76fbf9ee2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/bdylib.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/BDY/bdylib.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/bdytides.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/bdytides.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0b0bce8b7f5ada46af175f71fbc09d994524de04 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/bdytides.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/BDY/bdytides.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/bdytra.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/bdytra.F90 new file mode 120000 index 0000000000000000000000000000000000000000..38c8d83a248bb8a3cc760e6df4d8bf33e1f0b34b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/bdytra.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/BDY/bdytra.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/bdyvol.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/bdyvol.F90 new file mode 120000 index 0000000000000000000000000000000000000000..204e164eaae4ad848203d63c6361d246a9a2ee33 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/bdyvol.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/BDY/bdyvol.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/c1d.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/c1d.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f19c247352ee5262fd40d76b3e1d9088f08b14a5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/c1d.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/C1D/c1d.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/closea.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/closea.F90 new file mode 120000 index 0000000000000000000000000000000000000000..71801dcc019e370b8e1996db9888f9767a8e8b29 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/closea.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/closea.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/cpl_oasis3.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/cpl_oasis3.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f5a04fb5204d409f556457abee4b121658f23c76 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/cpl_oasis3.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/cpl_oasis3.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/crs.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/crs.F90 new file mode 120000 index 0000000000000000000000000000000000000000..82890c7b0000413446182bf82bf3c83865a5b804 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/crs.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/CRS/crs.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/crsdom.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/crsdom.F90 new file mode 120000 index 0000000000000000000000000000000000000000..5e577c7c1dac9aa4c80ccc539ab737bfdd4ca72f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/crsdom.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/CRS/crsdom.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/crsdomwri.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/crsdomwri.F90 new file mode 120000 index 0000000000000000000000000000000000000000..239e7c05e66eaa1f313528ed7e4dbc42183e08ee --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/crsdomwri.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/CRS/crsdomwri.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/crsfld.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/crsfld.F90 new file mode 120000 index 0000000000000000000000000000000000000000..52d17bea33b2aee898a6e2f1e1c65c0b9c87986c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/crsfld.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/CRS/crsfld.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/crsini.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/crsini.F90 new file mode 120000 index 0000000000000000000000000000000000000000..59fd04ccf330c81148530d0076edc04750fcfdd9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/crsini.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/CRS/crsini.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/crslbclnk.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/crslbclnk.F90 new file mode 120000 index 0000000000000000000000000000000000000000..30d10352f299ffaa50b737ea360b55d471e86c12 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/crslbclnk.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/CRS/crslbclnk.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/cyclone.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/cyclone.F90 new file mode 120000 index 0000000000000000000000000000000000000000..69e5b58cea5b664298490a3938215465d3f6dc7b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/cyclone.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/cyclone.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/daymod.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/daymod.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f87a32a14f4fd9a5a3d10b3bf1d1ad659ec86416 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/daymod.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/daymod.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/ddatetoymdhms.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/ddatetoymdhms.h90 new file mode 120000 index 0000000000000000000000000000000000000000..938ea07ed1b28d04cd29a23d4378e8d0b9a7c30c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/ddatetoymdhms.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/ddatetoymdhms.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/depth_e3.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/depth_e3.F90 new file mode 120000 index 0000000000000000000000000000000000000000..8025de5b791b78d26287fe958d523439d5a363cf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/depth_e3.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/depth_e3.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dia25h.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dia25h.F90 new file mode 120000 index 0000000000000000000000000000000000000000..283caaf7677cecc8a1388332977f3b87906f956c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dia25h.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIA/dia25h.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diaar5.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diaar5.F90 new file mode 120000 index 0000000000000000000000000000000000000000..cb20e77a4a290fa45bf075375d277f879da796f4 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diaar5.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIA/diaar5.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diacfl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diacfl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..642f4ff2824b181688ea02ebf3ed4414e21d5dff --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diacfl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIA/diacfl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diadct.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diadct.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1a0da066c9388c801dcaddcd20ecd8c70f44d78a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diadct.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIA/diadct.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diadetide.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diadetide.F90 new file mode 120000 index 0000000000000000000000000000000000000000..33a14a1133fd91cb9951f46e4e67b68e59184d85 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diadetide.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIA/diadetide.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diahsb.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diahsb.F90 new file mode 120000 index 0000000000000000000000000000000000000000..4ddac97154627b1816a128a301c4e69a2a89efc7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diahsb.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIA/diahsb.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diahth.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diahth.F90 new file mode 120000 index 0000000000000000000000000000000000000000..7af833f6372625e38d8d1722b8e9a05e76c4554f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diahth.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIA/diahth.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diamlr.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diamlr.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a7b25fc3e6484af96a1e748b5cdd960b62f01230 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diamlr.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIA/diamlr.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dianam.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dianam.F90 new file mode 120000 index 0000000000000000000000000000000000000000..552ede4c72ecbdb50b411ed32f881993b059b7f2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dianam.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIA/dianam.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diaobs.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diaobs.F90 new file mode 120000 index 0000000000000000000000000000000000000000..ce0d6b92805828c1c9d3153b37f8554d32c2e0d3 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diaobs.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/diaobs.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diaptr.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diaptr.F90 new file mode 120000 index 0000000000000000000000000000000000000000..8064ab3d05a5cbc488c258db15e7fb7f354ce064 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diaptr.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIA/diaptr.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diawri.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diawri.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a5e51b17381d887c5387bbf134309af16540bb79 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diawri.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIA/diawri.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diu_bulk.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diu_bulk.F90 new file mode 120000 index 0000000000000000000000000000000000000000..c7bc2744e0f3d4b9a94148244ee1d2305a9958d1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diu_bulk.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIU/diu_bulk.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diu_coolskin.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diu_coolskin.F90 new file mode 120000 index 0000000000000000000000000000000000000000..4e378a97f749839645f3e1045219055bc9fb8b3c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diu_coolskin.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIU/diu_coolskin.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/diu_layers.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/diu_layers.F90 new file mode 120000 index 0000000000000000000000000000000000000000..034ecda0ec991b3d302bcd41512307c87db4f3b1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/diu_layers.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIU/diu_layers.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/divhor.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/divhor.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1f9a1d4b1fba74a6b0dee4cfc6cdcf3d7a516b65 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/divhor.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/divhor.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/do_loop_substitute.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/do_loop_substitute.h90 new file mode 120000 index 0000000000000000000000000000000000000000..35f661ee473625b1f76687fcab7f883a02efb850 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/do_loop_substitute.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/do_loop_substitute.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dom_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dom_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..eab9684eace7f229275b33a70a66d57d14d29488 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dom_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/dom_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/domain.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/domain.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d95fcf20f9351dc9fe5f364c0f6dd5ef3741ee83 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/domain.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/domain.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/domhgr.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/domhgr.F90 new file mode 120000 index 0000000000000000000000000000000000000000..e40b2c0132ef0590b9db60f0405331c102cd3a96 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/domhgr.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/domhgr.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dommsk.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dommsk.F90 new file mode 120000 index 0000000000000000000000000000000000000000..652522d24689943f28dfcf4d67f55f82e1512415 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dommsk.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/dommsk.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/domqco.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/domqco.F90 new file mode 120000 index 0000000000000000000000000000000000000000..194a693ade05a20326908bfc3afd97dc0dab7f79 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/domqco.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/domqco.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/domtile.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/domtile.F90 new file mode 120000 index 0000000000000000000000000000000000000000..965a4d31d4b3041b491e320d9aba1079b7434bbf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/domtile.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/domtile.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/domutl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/domutl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0054eb2139ce45c9207aa97247479b37b420833b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/domutl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/domutl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/domvvl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/domvvl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..aff2f6913a0b61102a2137967ca244cebeb12288 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/domvvl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/domvvl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/domwri.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/domwri.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f27db42e0c40434e8608adb07acc16fa26219094 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/domwri.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/domwri.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/domzgr.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/domzgr.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0d32083c90edee890aeacf204bdbbe5df84af32a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/domzgr.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/domzgr.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/domzgr_substitute.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/domzgr_substitute.h90 new file mode 120000 index 0000000000000000000000000000000000000000..dd298a9a648e9ee03251fce4858055120c08156c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/domzgr_substitute.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/domzgr_substitute.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dtatsd.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dtatsd.F90 new file mode 120000 index 0000000000000000000000000000000000000000..15c3a1852211e5b40ceefcad96405a100af4ad95 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dtatsd.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/dtatsd.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dtauvd.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dtauvd.F90 new file mode 120000 index 0000000000000000000000000000000000000000..adc4abf0e3d79118d30993c271a1857de752f52e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dtauvd.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/C1D/dtauvd.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynadv.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynadv.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0b5f3b790d1549d3d72399ae0b2bf45d18a3ca9d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynadv.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynadv.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynadv_cen2.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynadv_cen2.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9e3c11258140bb7e0d34b22d52e0118723334c52 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynadv_cen2.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynadv_cen2.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynadv_ubs.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynadv_ubs.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1fcd809896c88ecb7601d1c106ec572be6860435 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynadv_ubs.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynadv_ubs.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynatf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynatf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..94ea5001c7d6a22ddf1b522bd06d1d393c0be411 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynatf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynatf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynatf_qco.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynatf_qco.F90 new file mode 120000 index 0000000000000000000000000000000000000000..2a4a1c39901fc8a2a5761591839701b64b7f5bdc --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynatf_qco.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynatf_qco.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dyndmp.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dyndmp.F90 new file mode 120000 index 0000000000000000000000000000000000000000..c62f0ca71118c32e98c0c5b922395ec598890069 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dyndmp.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/C1D/dyndmp.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynhpg.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynhpg.F90 new file mode 120000 index 0000000000000000000000000000000000000000..3a3162c6b139d116ba1de2dfa680ec3241032c11 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynhpg.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynhpg.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynkeg.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynkeg.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a6f077432487e5ad17a5fd43382f85f14ca52de5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynkeg.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynkeg.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynldf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynldf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..6d5b9b28b30bd50a491b9f334ac773b04f240ee8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynldf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynldf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_iso.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_iso.F90 new file mode 120000 index 0000000000000000000000000000000000000000..2d29ba1c770c24217191024577d6385dca1f4128 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_iso.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynldf_iso.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_iso_lf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_iso_lf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..fbec515f8466941a76b1872503c4a627b89456c4 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_iso_lf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynldf_iso_lf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_lap_blp.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_lap_blp.F90 new file mode 120000 index 0000000000000000000000000000000000000000..337225bd5fefbd45000ce86127382768be862339 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_lap_blp.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynldf_lap_blp.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_lap_blp_lf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_lap_blp_lf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..798e19f479dc94df69a481d72260f425a8f5afc0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynldf_lap_blp_lf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynldf_lap_blp_lf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynspg.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynspg.F90 new file mode 120000 index 0000000000000000000000000000000000000000..69f4f5d659781b5e22a4ed5d508c70bc5d012b7d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynspg.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynspg.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynspg_exp.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynspg_exp.F90 new file mode 120000 index 0000000000000000000000000000000000000000..2150a70b3920a4694d7b2760aef536620829e249 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynspg_exp.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynspg_exp.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynspg_ts.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynspg_ts.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0a4babd5de0c3b0a85c72a8691696792db6a2033 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynspg_ts.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynspg_ts.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynvor.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynvor.F90 new file mode 120000 index 0000000000000000000000000000000000000000..eec798de3f4ce5dcff627b5deee715e2e1736852 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynvor.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynvor.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynzad.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynzad.F90 new file mode 120000 index 0000000000000000000000000000000000000000..87f9217c0135fb7e165f72ea910d0db3f959a454 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynzad.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynzad.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/dynzdf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/dynzdf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..6c1fc1c35b93158e6069f8eb86022685fb875ac0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/dynzdf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/dynzdf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/eosbn2.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/eosbn2.F90 new file mode 120000 index 0000000000000000000000000000000000000000..886a7a6df65e825e9835b6a53c17b1746b78e5de --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/eosbn2.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/eosbn2.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/find_obs_proc.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/find_obs_proc.h90 new file mode 120000 index 0000000000000000000000000000000000000000..20c3fde319a188fd517d9fb89d90dcf5f980d529 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/find_obs_proc.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/find_obs_proc.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/fldread.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/fldread.F90 new file mode 120000 index 0000000000000000000000000000000000000000..11c3806736e8843c8097a7dbf1983f78bb0350ae --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/fldread.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/fldread.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/flo4rk.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/flo4rk.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1f8c1ee52b52267a8467c9e08bf994cc5a7681c0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/flo4rk.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/FLO/flo4rk.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/flo_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/flo_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0844ab596250d1b37f9dd104d061d1060018b763 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/flo_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/FLO/flo_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/floats.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/floats.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f77abc50aa547df31fc414ca881bb798b96ac82e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/floats.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/FLO/floats.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/floblk.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/floblk.F90 new file mode 120000 index 0000000000000000000000000000000000000000..3b0b39ca49eea62bf07edc8e444e5b1dd33936d1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/floblk.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/FLO/floblk.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/flodom.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/flodom.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f3595337577b61fd202cd92000041d4bdbdc928f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/flodom.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/FLO/flodom.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/florst.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/florst.F90 new file mode 120000 index 0000000000000000000000000000000000000000..6cf6e153220493cecae7278d7c60e03b747da473 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/florst.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/FLO/florst.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/flowri.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/flowri.F90 new file mode 120000 index 0000000000000000000000000000000000000000..defa5cdac5408a79d928ee558819836e053271f4 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/flowri.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/FLO/flowri.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/geo2ocean.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/geo2ocean.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d1af84bd695dc801e7fdc6b265e1806999c9959b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/geo2ocean.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/geo2ocean.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/greg2jul.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/greg2jul.h90 new file mode 120000 index 0000000000000000000000000000000000000000..c1775965d5dd6507350540968041b86dbb165b74 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/greg2jul.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/greg2jul.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/grt_cir_dis.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/grt_cir_dis.h90 new file mode 120000 index 0000000000000000000000000000000000000000..16593f5927ca5438a3bbb8eb9a7a414e04991d7b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/grt_cir_dis.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/grt_cir_dis.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/grt_cir_dis_saa.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/grt_cir_dis_saa.h90 new file mode 120000 index 0000000000000000000000000000000000000000..0b10a2c1404ac4e922d76ceb044feaac70a18b7e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/grt_cir_dis_saa.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/grt_cir_dis_saa.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/halo_mng.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/halo_mng.F90 new file mode 120000 index 0000000000000000000000000000000000000000..895e0c6e25b1824a94d005e209502f6b8c01b1bb --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/halo_mng.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/halo_mng.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/icb_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/icb_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..3a5b6c86b9cd27021a5e10f85d6c3008457379d6 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/icb_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ICB/icb_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/icbclv.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/icbclv.F90 new file mode 120000 index 0000000000000000000000000000000000000000..ffad6f2559fbb4b11ff1f907355c6f6b910235b5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/icbclv.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ICB/icbclv.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/icbdia.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/icbdia.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9cbec9987323b3d967032c83034b62591af2bdca --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/icbdia.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ICB/icbdia.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/icbdyn.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/icbdyn.F90 new file mode 120000 index 0000000000000000000000000000000000000000..ae767812415cdad2d783fb4b715af68b856a15ad --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/icbdyn.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ICB/icbdyn.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/icbini.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/icbini.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d63b617114d70a089dc84aa8a6f095671976f36a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/icbini.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ICB/icbini.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/icblbc.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/icblbc.F90 new file mode 120000 index 0000000000000000000000000000000000000000..ce33a4bf90ade1fb0aabd8831e01b461478a4780 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/icblbc.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ICB/icblbc.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/icbrst.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/icbrst.F90 new file mode 120000 index 0000000000000000000000000000000000000000..30d7641fb65ab1a03dba13465e3d53e3106cd1ec --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/icbrst.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ICB/icbrst.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/icbstp.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/icbstp.F90 new file mode 120000 index 0000000000000000000000000000000000000000..b8674450f3e98f4d21ea726ce9e7197edf37e1f5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/icbstp.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ICB/icbstp.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/icbthm.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/icbthm.F90 new file mode 120000 index 0000000000000000000000000000000000000000..cf9364582b0510f4503861e0d03f1d41e2e11953 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/icbthm.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ICB/icbthm.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/icbtrj.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/icbtrj.F90 new file mode 120000 index 0000000000000000000000000000000000000000..2a36eb79ca6200782e1a06db16b4c4b88733f0dd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/icbtrj.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ICB/icbtrj.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/icbutl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/icbutl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..33cfcf2b0e241f4a07d5e9ca34aea1828c38b0db --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/icbutl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ICB/icbutl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/in_out_manager.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/in_out_manager.F90 new file mode 120000 index 0000000000000000000000000000000000000000..037c4968b0e1e696a6c73ab5aea231305f220eb2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/in_out_manager.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/IOM/in_out_manager.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/iom.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/iom.F90 new file mode 120000 index 0000000000000000000000000000000000000000..03b96c49ec44b10b8e190b26834827876fd1190d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/iom.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/IOM/iom.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/iom_def.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/iom_def.F90 new file mode 120000 index 0000000000000000000000000000000000000000..4bfe344dfad9efa6461bd49bbd6b257f70fbb828 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/iom_def.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/IOM/iom_def.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/iom_nf90.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/iom_nf90.F90 new file mode 120000 index 0000000000000000000000000000000000000000..233ffce982dab98bb292c752aeffa548f5b49670 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/iom_nf90.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/IOM/iom_nf90.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isf_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isf_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..dd4ecdfd7e0f0d51079633244b3de3fa68772650 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isf_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isf_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfcav.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfcav.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9dfe9861b48b446464fa5a0a24f2695a037c1bc6 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfcav.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfcav.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfcavgam.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfcavgam.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1cc732645289caf4d978836e55540a983dbb3bf1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfcavgam.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfcavgam.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfcavmlt.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfcavmlt.F90 new file mode 120000 index 0000000000000000000000000000000000000000..b56df3a5031f4b778a853498c279fc2060d00812 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfcavmlt.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfcavmlt.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfcpl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfcpl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..5f8b23f6c00de5223acf7e83d94a784645f28bca --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfcpl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfcpl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfdiags.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfdiags.F90 new file mode 120000 index 0000000000000000000000000000000000000000..20a005693e6773602b514c9f286cec10086872bd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfdiags.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfdiags.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfdynatf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfdynatf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..bb8c55dfd13cd8535c2fb49a2d7e1a196fc47365 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfdynatf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfdynatf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfhdiv.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfhdiv.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1beb1b1268ce570f999b708e7bdb018c97fb78f5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfhdiv.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfhdiv.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfload.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfload.F90 new file mode 120000 index 0000000000000000000000000000000000000000..2512f061ac8675c624fb7e013aeddf1526dcbc1c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfload.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfload.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfpar.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfpar.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f79a7aa65fc6e93a943aeb95b3e49192ad73641b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfpar.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfpar.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfparmlt.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfparmlt.F90 new file mode 120000 index 0000000000000000000000000000000000000000..ce9eab4a2c2c34619fa8d37c150a34a2dc283839 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfparmlt.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfparmlt.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfrst.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfrst.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d15962e07762762e224bd2a08c637f95a15e51a9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfrst.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfrst.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfstp.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfstp.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a7c9879f8037b96e14effad708eb87e0c836bac9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfstp.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfstp.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isftbl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isftbl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..c13062e8fff3bf764dd709729a8a8b756f3ff423 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isftbl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isftbl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/isfutils.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/isfutils.F90 new file mode 120000 index 0000000000000000000000000000000000000000..48c42db58e7072051f6685129eb904ef172ad7fe --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/isfutils.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ISF/isfutils.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/istate.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/istate.F90 new file mode 120000 index 0000000000000000000000000000000000000000..56c5d30347d3ca3eea668369d5876239eb906f12 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/istate.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/istate.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/jul2greg.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/jul2greg.h90 new file mode 120000 index 0000000000000000000000000000000000000000..60dfa83f4160c8af71a4580e2c4246e3257876ca --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/jul2greg.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/jul2greg.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/julian.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/julian.F90 new file mode 120000 index 0000000000000000000000000000000000000000..712e55a43541581b2d2f9a1068667ae2e5748742 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/julian.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/julian.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/lbc_lnk_call_generic.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/lbc_lnk_call_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..4a8ccf5be1f8eee7e2e016ba294b78b4cd2632e6 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/lbc_lnk_call_generic.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/lbc_lnk_call_generic.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/lbc_lnk_neicoll_generic.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/lbc_lnk_neicoll_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..06bc661e765f4d9fbbd87d7285046973984093cf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/lbc_lnk_neicoll_generic.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/lbc_lnk_neicoll_generic.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/lbc_lnk_pt2pt_generic.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/lbc_lnk_pt2pt_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..1c449a110ff797530793b2a6e5d5ec85e76a39ea --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/lbc_lnk_pt2pt_generic.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/lbc_nfd_ext_generic.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/lbc_nfd_ext_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..7a49a9df325d2980250e1d71ecf3aefad9fa3846 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/lbc_nfd_ext_generic.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/lbc_nfd_ext_generic.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/lbc_nfd_generic.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/lbc_nfd_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..7fd83ab1a7e81408b61aa871ec2198d618a05064 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/lbc_nfd_generic.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/lbc_nfd_generic.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/lbclnk.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/lbclnk.F90 new file mode 120000 index 0000000000000000000000000000000000000000..5af70dab3bc64fb79ba24d6d3b544bdba9278cc9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/lbclnk.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/lbclnk.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/lbcnfd.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/lbcnfd.F90 new file mode 120000 index 0000000000000000000000000000000000000000..6b1087efa6cf3f562501404abd826f5027473bce --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/lbcnfd.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/lbcnfd.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/ldfc1d_c2d.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/ldfc1d_c2d.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9d5d46f53ddb8999af15afa0db47acd818da8717 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/ldfc1d_c2d.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LDF/ldfc1d_c2d.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/ldfdyn.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/ldfdyn.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a205bc3ff7c5d6bf7400c2a30226669935ae156d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/ldfdyn.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LDF/ldfdyn.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/ldfslp.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/ldfslp.F90 new file mode 120000 index 0000000000000000000000000000000000000000..50ba5688bfd65e2f26b566231d282b4619b290d5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/ldfslp.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LDF/ldfslp.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/ldftra.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/ldftra.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a86b931ab331f524c60ddfd2f54f596db5936742 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/ldftra.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LDF/ldftra.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/lib_cray.f90 b/cfgs/ORCA2_OCE_MIXED/WORK/lib_cray.f90 new file mode 120000 index 0000000000000000000000000000000000000000..a51580918618a42cf030e8ed7e863b37e76547b9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/lib_cray.f90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/lib_cray.f90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/lib_fortran.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/lib_fortran.F90 new file mode 120000 index 0000000000000000000000000000000000000000..125e8497cef3c42aee8c3fad0c75abea293a957b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/lib_fortran.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/lib_fortran.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/lib_fortran_generic.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/lib_fortran_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..0389cbff65fd34253c367cbe41f4d82dec8bd6f2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/lib_fortran_generic.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/lib_fortran_generic.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/lib_mpp.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/lib_mpp.F90 new file mode 120000 index 0000000000000000000000000000000000000000..3d799b7594ce225c69087b84969dc691b898c9a7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/lib_mpp.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/lib_mpp.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/linquad.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/linquad.h90 new file mode 120000 index 0000000000000000000000000000000000000000..75991894b12de61db08299950e23dba023cdbab7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/linquad.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/linquad.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/maxdist.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/maxdist.h90 new file mode 120000 index 0000000000000000000000000000000000000000..b32c3553d406d2fdfcb3a663e1bbabd43e1ab3c2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/maxdist.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/maxdist.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/module_example.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/module_example.F90 new file mode 120000 index 0000000000000000000000000000000000000000..470b3d3bbba5ae9801378a2d83a23eb2e54899ab --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/module_example.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/module_example.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/mpp_allreduce_generic.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_allreduce_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..df2bd98c4a49fa63454652581a16266771140300 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_allreduce_generic.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/mpp_allreduce_generic.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/mpp_lbc_north_icb_generic.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_lbc_north_icb_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..dc41b4eeeddab434e578762edf1620d04244d47e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_lbc_north_icb_generic.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/mpp_lbc_north_icb_generic.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/mpp_lnk_icb_generic.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_lnk_icb_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..5da4177591210b1eb7c26f9cc138552d6d9b060a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_lnk_icb_generic.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/mpp_lnk_icb_generic.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/mpp_loc_generic.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_loc_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..c9be0881c6736748f91479dcbab731e497ecd582 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_loc_generic.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/mpp_loc_generic.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/mpp_map.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_map.F90 new file mode 120000 index 0000000000000000000000000000000000000000..37006a3a58a802cdd4964923fad19eafd683f8da --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_map.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/mpp_map.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/mpp_nfd_generic.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_nfd_generic.h90 new file mode 120000 index 0000000000000000000000000000000000000000..5c58e16e5601fdcdac6977f488c1714e12cfb55b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/mpp_nfd_generic.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/mpp_nfd_generic.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/mppini.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/mppini.F90 new file mode 120000 index 0000000000000000000000000000000000000000..df0443723a4e3281eb05331fd6c3cc7575588c39 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/mppini.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/LBC/mppini.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/nemo.f90 b/cfgs/ORCA2_OCE_MIXED/WORK/nemo.f90 new file mode 120000 index 0000000000000000000000000000000000000000..071dc7569e7695cff5c4a5e098b426e2785f8318 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/nemo.f90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/nemo.f90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/nemogcm.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/nemogcm.F90 new file mode 120000 index 0000000000000000000000000000000000000000..6f1bc98ada872c2bbc49ad4ad700dc538448ebe0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/nemogcm.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/nemogcm.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_averg_h2d.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_averg_h2d.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1cf210a21a6ee76e02840f78fed63385c7f1432a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_averg_h2d.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_averg_h2d.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_const.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_const.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f421e85dff17a3d2d2e82ac8af9a8eb87883b59e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_const.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_const.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_conv.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_conv.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1a261612009c7a2216d08b413430b14c2926873e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_conv.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_conv.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_conv_functions.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_conv_functions.h90 new file mode 120000 index 0000000000000000000000000000000000000000..4f698bd31b42cc8546186c63d8aa194d6f5400c2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_conv_functions.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_conv_functions.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_fbm.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_fbm.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d1370e416c9f23556b0aff60fa3e7b418a7702ac --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_fbm.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_fbm.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_grd_bruteforce.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_grd_bruteforce.h90 new file mode 120000 index 0000000000000000000000000000000000000000..7a5c38d9e6280fc96615fbd7df7e9ab9cbdc5ae8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_grd_bruteforce.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_grd_bruteforce.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_grid.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_grid.F90 new file mode 120000 index 0000000000000000000000000000000000000000..13601108684671c8ab9a370236b7df050f30bad3 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_grid.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_grid.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_inter_h2d.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_inter_h2d.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d463cd2a4290a3ce5090a3e6d9cdf3a8f58f4fbf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_inter_h2d.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_inter_h2d.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_inter_sup.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_inter_sup.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a621128f2576dd0938804b869339382dd16bfc11 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_inter_sup.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_inter_sup.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_inter_z1d.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_inter_z1d.F90 new file mode 120000 index 0000000000000000000000000000000000000000..b0420e934140eae77b014839b4d3c879892a9a28 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_inter_z1d.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_inter_z1d.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_level_search.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_level_search.h90 new file mode 120000 index 0000000000000000000000000000000000000000..6e0847d96798fb68c2fec677ecf1aa3d58d116c6 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_level_search.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_level_search.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_mpp.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_mpp.F90 new file mode 120000 index 0000000000000000000000000000000000000000..031d08ae873e8831a5cabaf30b4a36e19c2a97ac --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_mpp.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_mpp.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_oper.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_oper.F90 new file mode 120000 index 0000000000000000000000000000000000000000..e80b17f370a3cbc1d19b7fb578703105dc166b08 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_oper.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_oper.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_prep.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_prep.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f8e7728ea76144af91cb6aed1088bb29f110ee07 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_prep.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_prep.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_profiles.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_profiles.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f575abe714e8a1f0cf485cf287dadd734c03e454 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_profiles.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_profiles.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_profiles_def.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_profiles_def.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f519c9bfae0588de995532734fdefcca12d7fe6a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_profiles_def.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_profiles_def.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_read_altbias.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_read_altbias.F90 new file mode 120000 index 0000000000000000000000000000000000000000..694e3af9cfd8b612de5c06043882d0497c0bf05d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_read_altbias.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_read_altbias.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_read_prof.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_read_prof.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1d1830b63d2e742513da965cd63745d73d94158e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_read_prof.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_read_prof.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_read_surf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_read_surf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..bcee8cb12ee7f1360dc2965f321d25f061df549d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_read_surf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_read_surf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_readmdt.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_readmdt.F90 new file mode 120000 index 0000000000000000000000000000000000000000..13a574c751a23f6e6a3566bcd77ca3a0262e63cf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_readmdt.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_readmdt.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_rot_vel.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_rot_vel.F90 new file mode 120000 index 0000000000000000000000000000000000000000..fe4017ce6814ac78a35d6ff19012691f4a2ee73b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_rot_vel.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_rot_vel.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_sort.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_sort.F90 new file mode 120000 index 0000000000000000000000000000000000000000..39efccfe5a23440d45a70159dce86464f84c3a49 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_sort.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_sort.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_sstbias.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_sstbias.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9389de3a5164077209b1d1226fe38a8edf2fb57a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_sstbias.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_sstbias.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_surf_def.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_surf_def.F90 new file mode 120000 index 0000000000000000000000000000000000000000..2934fbcf519225d536fd21070e33bf00881898bd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_surf_def.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_surf_def.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_types.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_types.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0e436855ca860bd669b738cbd51afbfe1f0dc2e2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_types.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_types.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_utils.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_utils.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d3d7c7e031bb6f0d1cff6a4ad5a6238211ed72e9 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_utils.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_utils.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obs_write.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/obs_write.F90 new file mode 120000 index 0000000000000000000000000000000000000000..cb66faf2970ed590af308247906dcfa11c7c5fef --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obs_write.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obs_write.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obsinter_h2d.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/obsinter_h2d.h90 new file mode 120000 index 0000000000000000000000000000000000000000..aeba756078c098861c05fe93830dd6e026bf54a5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obsinter_h2d.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obsinter_h2d.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/obsinter_z1d.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/obsinter_z1d.h90 new file mode 120000 index 0000000000000000000000000000000000000000..6bfc261bdce2a17cb7b092cac856016fa0364280 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/obsinter_z1d.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/obsinter_z1d.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..91a01e45e9d11f483c0eaf99350d508f36d2867a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/ocealb.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/ocealb.F90 new file mode 120000 index 0000000000000000000000000000000000000000..8047be78d7cb129d2cae024f3ac92c8fd7079e4a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/ocealb.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/ocealb.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/par_kind.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/par_kind.F90 new file mode 120000 index 0000000000000000000000000000000000000000..b0a551f6708ee7e618b059096d91a4c00464b831 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/par_kind.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/par_kind.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/par_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/par_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..acccf548c495d56330d6aef25936b0d5c097f81e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/par_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/par_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/phycst.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/phycst.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0ede0cabfc3b2c0495967e2c121e2a1088d34fdd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/phycst.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DOM/phycst.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/prtctl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/prtctl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..200295e2b8099e5e8ff0a2790ea7fb84d87b55fd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/prtctl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/IOM/prtctl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/restart.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/restart.F90 new file mode 120000 index 0000000000000000000000000000000000000000..da481385bf35910986d67e21ff58eb5989621a69 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/restart.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/IOM/restart.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbc_ice.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbc_ice.F90 new file mode 120000 index 0000000000000000000000000000000000000000..ea2a515389ded1537cee92c96a25b47a4b70c54e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbc_ice.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbc_ice.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbc_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbc_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..486fd3fcae795cd8bf098f919fa754f4c18b4e4b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbc_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbc_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbc_phy.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbc_phy.F90 new file mode 120000 index 0000000000000000000000000000000000000000..ba0dcd0a85905c46ac146bb99f6869f106ce3db3 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbc_phy.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbc_phy.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcabl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcabl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..6351c970216af01e42159ac9c62c1b801d606b90 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcabl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcabl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcapr.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcapr.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a340a9bf5cc91ba8811c0fd513b220dddace1040 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcapr.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcapr.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f6bb89c91a81ccc5b5ba78646f26ad5846523ff5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_andreas.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_andreas.F90 new file mode 120000 index 0000000000000000000000000000000000000000..67877cb759c831908d59960a33a6e1de5fad3bdf --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_andreas.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk_algo_andreas.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_coare3p0.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_coare3p0.F90 new file mode 120000 index 0000000000000000000000000000000000000000..b61e1dd22e484f77f5f7355795a1ded12965873d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_coare3p0.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk_algo_coare3p0.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_coare3p6.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_coare3p6.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1af6065075df28c7435d52e4d7dababfd0d76617 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_coare3p6.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk_algo_coare3p6.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ecmwf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ecmwf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..30c28f9e7eefd6e619b9f282fbae55a06919424d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ecmwf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk_algo_ecmwf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_an05.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_an05.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0fac16d383b5e952a185af81635fcf5a648586dd --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_an05.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk_algo_ice_an05.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_cdn.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_cdn.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a97df44164e3736a8f3cd2dc5624c6785905069b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_cdn.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk_algo_ice_cdn.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_lg15.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_lg15.F90 new file mode 120000 index 0000000000000000000000000000000000000000..7ec58ef763af9a682e1c6c21de0e399ee14c6d01 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_lg15.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk_algo_ice_lg15.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_lu12.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_lu12.F90 new file mode 120000 index 0000000000000000000000000000000000000000..e934c1abfcf9ae57bd913d3cfcbdd9442bdc3de1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ice_lu12.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk_algo_ice_lu12.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ncar.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ncar.F90 new file mode 120000 index 0000000000000000000000000000000000000000..bb9bc544c325daa3fa41865ccf721dbe74a31eda --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_algo_ncar.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk_algo_ncar.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_skin_coare.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_skin_coare.F90 new file mode 120000 index 0000000000000000000000000000000000000000..2c7129d2264fbadd99f3e9a1ea78273744bb0635 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_skin_coare.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk_skin_coare.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_skin_ecmwf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_skin_ecmwf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..7c0bb76a7872944e5304b49a1412685fafb0cda6 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcblk_skin_ecmwf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcblk_skin_ecmwf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcclo.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcclo.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d2ff4a6857e684992b481d97fbf2bc524969c4e1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcclo.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcclo.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbccpl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbccpl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..79ea72ef809a5364e3882a7f86cf683f69503f1b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbccpl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbccpl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcdcy.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcdcy.F90 new file mode 120000 index 0000000000000000000000000000000000000000..ab388e2c8bccdc6b688800d1be364fe8c397a3ac --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcdcy.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcdcy.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcflx.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcflx.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9bffe3843fc5a50932128073658ddd6f42b11263 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcflx.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcflx.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcfwb.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcfwb.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9035ad9e8c3af93b89ac2376bfaa3ba71c839935 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcfwb.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcfwb.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcice_cice.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcice_cice.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9796eecd61585cd58bd5b87bf7a6248a640838d0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcice_cice.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcice_cice.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcice_if.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcice_if.F90 new file mode 120000 index 0000000000000000000000000000000000000000..51d15c4a04d63b808e64e7e0b04a47f8f8e7c0e2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcice_if.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcice_if.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcmod.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcmod.F90 new file mode 120000 index 0000000000000000000000000000000000000000..6ad19eeecac3b7ae39615976cecc34e84dc2bd21 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcmod.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcmod.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcrnf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcrnf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..8f08eebf94dc9a60fcba0dd36dac48425e6375c2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcrnf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcrnf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcssm.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcssm.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1ffadbef217aa628df7e141149f5980abfc49b1e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcssm.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcssm.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcssr.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcssr.F90 new file mode 120000 index 0000000000000000000000000000000000000000..3c2523fbbdf98d835cdd84eb21b87885de02a17a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcssr.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcssr.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sbcwave.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sbcwave.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d755cca26a7d2ab7c396fd907193331eff9ffb22 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sbcwave.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/SBC/sbcwave.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/single_precision_substitute.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/single_precision_substitute.h90 new file mode 120000 index 0000000000000000000000000000000000000000..4bead8818522e7ad9e457019442ed5858d4d6fc1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/single_precision_substitute.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/single_precision_substitute.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/solfrac_mod.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/solfrac_mod.F90 new file mode 120000 index 0000000000000000000000000000000000000000..6ec1f452ad21198549516fbe5a88dc48ffd19c79 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/solfrac_mod.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIU/solfrac_mod.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/sshwzv.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/sshwzv.F90 new file mode 120000 index 0000000000000000000000000000000000000000..c9d7209b0d7c21a17fdacfa38d0d6b605228744c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/sshwzv.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/sshwzv.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/step.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/step.F90 new file mode 120000 index 0000000000000000000000000000000000000000..c81a942b6bc903f9c672af9cec9db000e17ad748 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/step.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/step.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/step_diu.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/step_diu.F90 new file mode 120000 index 0000000000000000000000000000000000000000..ac39649727eeba1108099325883d69c4fec74f8f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/step_diu.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DIU/step_diu.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/step_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/step_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..8864c19e293b576b5924111717c30a5420ead2db --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/step_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/step_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/stopar.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/stopar.F90 new file mode 120000 index 0000000000000000000000000000000000000000..c682b9e95ad402b0d1b9fbe00f08572bb4acb199 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/stopar.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/STO/stopar.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/stopts.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/stopts.F90 new file mode 120000 index 0000000000000000000000000000000000000000..3581b412bde901fce92e618e61c92941c966dd34 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/stopts.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/STO/stopts.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/storng.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/storng.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1691f762b32792dcbae0560677dd259133f53512 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/storng.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/STO/storng.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/stpctl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/stpctl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..330de76a66a38de6e439915695f189780fc9647b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/stpctl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/stpctl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/stpmlf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/stpmlf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..64570007fef5b85e33e0f78b4e16aaf7d3cf0068 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/stpmlf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/stpmlf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/str_c_to_for.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/str_c_to_for.h90 new file mode 120000 index 0000000000000000000000000000000000000000..0815004222bf753876ecd4389e5c165e4e31273d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/str_c_to_for.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/OBS/str_c_to_for.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/tide.h90 b/cfgs/ORCA2_OCE_MIXED/WORK/tide.h90 new file mode 120000 index 0000000000000000000000000000000000000000..79bd739e677a5dca30c3fd807171c67965b63dc8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/tide.h90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TDE/tide.h90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/tide_mod.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/tide_mod.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9059463453b58797f3868573a2e1f23f959ffa25 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/tide_mod.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TDE/tide_mod.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/timing.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/timing.F90 new file mode 120000 index 0000000000000000000000000000000000000000..e7aef3d1ddcc6c263ffa6c4b61a0e7933601b198 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/timing.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/timing.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traadv.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traadv.F90 new file mode 120000 index 0000000000000000000000000000000000000000..4f3e10b9d4c944538ada1e08a753beb850310dfe --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traadv.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traadv.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traadv_cen.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_cen.F90 new file mode 120000 index 0000000000000000000000000000000000000000..b4d470be4d689b1a91bf0e594ead98fd68a6f27e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_cen.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traadv_cen.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traadv_cen_lf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_cen_lf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9816cc543c8e0bfce8dd1ad74095d1f36f329d19 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_cen_lf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traadv_cen_lf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traadv_fct.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_fct.F90 new file mode 120000 index 0000000000000000000000000000000000000000..23ceeac88287447de2e44fd3b2f8035a09478af4 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_fct.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traadv_fct.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traadv_mus.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_mus.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f62247e16c508d9a2f7176508cbee01988127700 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_mus.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traadv_mus.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traadv_qck.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_qck.F90 new file mode 120000 index 0000000000000000000000000000000000000000..891aa5dae30b2d44314d3bbbd016f3eb604efb85 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_qck.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traadv_qck.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traadv_qck_lf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_qck_lf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..92b84c040e5ed1acea3230883d33840326d47b11 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_qck_lf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traadv_qck_lf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traadv_ubs.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_ubs.F90 new file mode 120000 index 0000000000000000000000000000000000000000..fb22ba15f652570782471e850ac7a766b3215b89 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_ubs.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traadv_ubs.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traadv_ubs_lf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_ubs_lf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..ba89089af4e30342882bea72bddaff16b988e352 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traadv_ubs_lf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traadv_ubs_lf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traatf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traatf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..34160b5979147ccb60490e65e7094f3e2b170ea1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traatf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traatf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traatf_qco.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traatf_qco.F90 new file mode 120000 index 0000000000000000000000000000000000000000..afbf60e9746e7aa28e331011df12c344400f8b24 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traatf_qco.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traatf_qco.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trabbc.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trabbc.F90 new file mode 120000 index 0000000000000000000000000000000000000000..72075d73c9a45dc2a89f45a4b6e2c2d4f138db4b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trabbc.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/trabbc.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trabbl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trabbl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a4bf94ae3969c1b969a6eb726128ec51a5381765 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trabbl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/trabbl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/tradmp.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/tradmp.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a07a41c171adaadf38651393814eead108f1ea42 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/tradmp.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/tradmp.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traisf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traisf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a2179b91a41f0994f6468753071741c963db3ff8 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traisf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traisf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traldf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traldf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..3ffafd7f6a0b0b73a78fda5a1313847322a1617e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traldf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traldf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traldf_iso.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traldf_iso.F90 new file mode 120000 index 0000000000000000000000000000000000000000..995190fcb6cf8fe1f9c69431f673db44b22c7867 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traldf_iso.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traldf_iso.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traldf_lap_blp.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traldf_lap_blp.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f21793f88c4e9329f159fdf517a6a0c8f896e315 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traldf_lap_blp.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traldf_lap_blp.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traldf_triad.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traldf_triad.F90 new file mode 120000 index 0000000000000000000000000000000000000000..edaecf55fbc717fff4c58bde882b82e40ef2be61 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traldf_triad.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traldf_triad.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/tramle.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/tramle.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0c55d7a730580986dab7b04ddc300560d300b925 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/tramle.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/tramle.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/tranpc.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/tranpc.F90 new file mode 120000 index 0000000000000000000000000000000000000000..e24f405c2fd1b48fce5798b5bb678ece213bbf76 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/tranpc.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/tranpc.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/traqsr.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/traqsr.F90 new file mode 120000 index 0000000000000000000000000000000000000000..04aff519792f9657d516f1e595387ff5f73340db --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/traqsr.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/traqsr.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trasbc.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trasbc.F90 new file mode 120000 index 0000000000000000000000000000000000000000..8ea00fa324b10f91333d2793af0dcd03b619fbe5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trasbc.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/trasbc.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trazdf.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trazdf.F90 new file mode 120000 index 0000000000000000000000000000000000000000..2089dc3fb7ae0af6681f50406fa8a4bf8da12344 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trazdf.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/trazdf.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trc_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trc_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..07fd46703e034cfc4c969248fdff7a7a5849b18e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trc_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/trc_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trd_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trd_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..4bb591b89fc0278fd4732beeb9e450f1a475c5c0 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trd_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trd_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trddyn.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trddyn.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9e06fa5a6b4a1de9104de7b8a2429f7996af5b10 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trddyn.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trddyn.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trdglo.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trdglo.F90 new file mode 120000 index 0000000000000000000000000000000000000000..d52fa3419d569a8ce4e7e0befc7ad25f1bd09e1a --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trdglo.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trdglo.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trdini.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trdini.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f7b3d15cdac5b6d85aa59555b6f2e813dfdc8f4b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trdini.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trdini.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trdken.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trdken.F90 new file mode 120000 index 0000000000000000000000000000000000000000..692ed862a3db84f6210b4fa0a69c4417f25711f7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trdken.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trdken.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trdmxl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trdmxl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..a1f7aa029e4826e5f5578686b9b874ee2283a716 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trdmxl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trdmxl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trdmxl_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trdmxl_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..644ccf76448a0c690119715bdf2ab7491d141b15 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trdmxl_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trdmxl_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trdmxl_rst.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trdmxl_rst.F90 new file mode 120000 index 0000000000000000000000000000000000000000..2209c6b775f03a910f340b24cbdcfb66805e3aa5 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trdmxl_rst.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trdmxl_rst.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trdpen.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trdpen.F90 new file mode 120000 index 0000000000000000000000000000000000000000..493952b88a9803283aa7fc862d6d03c0234a4d59 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trdpen.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trdpen.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trdtra.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trdtra.F90 new file mode 120000 index 0000000000000000000000000000000000000000..720c67c4ee8391b122ae956fe215739abe27ab0d --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trdtra.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trdtra.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trdtrc.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trdtrc.F90 new file mode 120000 index 0000000000000000000000000000000000000000..b721b64651e5432de0edcf0050e84860a3412878 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trdtrc.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trdtrc.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trdvor.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trdvor.F90 new file mode 120000 index 0000000000000000000000000000000000000000..bb6938645e7375b8fbe45c83ae4e2dcd87d89fda --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trdvor.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trdvor.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/trdvor_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/trdvor_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..65ae43db4009cc47c87819256af290a165add319 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/trdvor_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRD/trdvor_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_fmask.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_fmask.F90 new file mode 120000 index 0000000000000000000000000000000000000000..3bff70b3884131293c83bb1750086edffcb1ede7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_fmask.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/USR/usrdef_fmask.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_hgr.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_hgr.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9a144ad678596f058aaf34b17dd7d258d3b9df98 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_hgr.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/USR/usrdef_hgr.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_istate.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_istate.F90 new file mode 120000 index 0000000000000000000000000000000000000000..1f5026f2bf7fe95908b3281fdb342adcd7ca8926 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_istate.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/USR/usrdef_istate.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_nam.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_nam.F90 new file mode 120000 index 0000000000000000000000000000000000000000..aa793b1552de228bd060b34bd56f786d3206d77b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_nam.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/USR/usrdef_nam.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_sbc.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_sbc.F90 new file mode 120000 index 0000000000000000000000000000000000000000..76f2c1835518f54f135339b6a37767ddfa50074c --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_sbc.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/USR/usrdef_sbc.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_zgr.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_zgr.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0d8770d5a266c2e4b0d986763accb065566d5df1 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/usrdef_zgr.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/USR/usrdef_zgr.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/wet_dry.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/wet_dry.F90 new file mode 120000 index 0000000000000000000000000000000000000000..6526fd948a89f24a708ac095b2a98e3956a115ff --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/wet_dry.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/DYN/wet_dry.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdf_oce.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdf_oce.F90 new file mode 120000 index 0000000000000000000000000000000000000000..64057a9605d7c6acd7329a44cd53094ea7db1825 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdf_oce.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdf_oce.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfddm.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfddm.F90 new file mode 120000 index 0000000000000000000000000000000000000000..62fc194ae2f2b1180a928b808c2085d2dca9b1c7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfddm.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfddm.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfdrg.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfdrg.F90 new file mode 120000 index 0000000000000000000000000000000000000000..e6018ac302abd3926193998808304d4e7870a7c2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfdrg.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfdrg.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfevd.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfevd.F90 new file mode 120000 index 0000000000000000000000000000000000000000..4fdbbf2b211713fbc4cc1da719e68a2e2fb47b0b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfevd.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfevd.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfgls.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfgls.F90 new file mode 120000 index 0000000000000000000000000000000000000000..0b27d02fcf2ae8f4c828c6078db3841032bc5685 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfgls.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfgls.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfiwm.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfiwm.F90 new file mode 120000 index 0000000000000000000000000000000000000000..f930c4de8838d7d9462dca6edda33403b4de4933 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfiwm.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfiwm.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfmfc.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfmfc.F90 new file mode 120000 index 0000000000000000000000000000000000000000..b3a08041c6d08d62a4ef6187c2e4c55c2fb98018 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfmfc.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfmfc.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfmxl.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfmxl.F90 new file mode 120000 index 0000000000000000000000000000000000000000..2af0ddc688effc31b80f75f89f9c31ff2c152a95 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfmxl.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfmxl.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfosm.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfosm.F90 new file mode 120000 index 0000000000000000000000000000000000000000..fc60c67a88783c2a50fa481a847263aab2b3b0d6 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfosm.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfosm.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfphy.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfphy.F90 new file mode 120000 index 0000000000000000000000000000000000000000..533414b424bc28d6101ef970118c5d4f293c5d85 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfphy.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfphy.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfric.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfric.F90 new file mode 120000 index 0000000000000000000000000000000000000000..42034d15793c7ea0b20bcccdaec488849ff302a2 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfric.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfric.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfsh2.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfsh2.F90 new file mode 120000 index 0000000000000000000000000000000000000000..8dc745c6898aa2c2301a725c70d038b3508ffd3e --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfsh2.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfsh2.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdfswm.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdfswm.F90 new file mode 120000 index 0000000000000000000000000000000000000000..6c5ed321a88759755541aeed9673ee7023a8d485 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdfswm.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdfswm.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zdftke.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zdftke.F90 new file mode 120000 index 0000000000000000000000000000000000000000..9c384e0e514827cdd7f3da19af4a53a39da8426b --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zdftke.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/ZDF/zdftke.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/WORK/zpshde.F90 b/cfgs/ORCA2_OCE_MIXED/WORK/zpshde.F90 new file mode 120000 index 0000000000000000000000000000000000000000..701ea8aa0f891aa77eca8ea4213731e8ba40d26f --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/WORK/zpshde.F90 @@ -0,0 +1 @@ +/gpfs/scratch/bsc32/bsc32331/a5ar/precisionoptimizationworkflow4nemo/model_sources_mixed/src/OCE/TRA/zpshde.F90 \ No newline at end of file diff --git a/cfgs/ORCA2_OCE_MIXED/cpp_ORCA2_OCE_MIXED_DEF_4.fcm b/cfgs/ORCA2_OCE_MIXED/cpp_ORCA2_OCE_MIXED_DEF_4.fcm new file mode 100644 index 0000000000000000000000000000000000000000..ade6c14431a81f4eb805645c36144c1e6b5ed5c7 --- /dev/null +++ b/cfgs/ORCA2_OCE_MIXED/cpp_ORCA2_OCE_MIXED_DEF_4.fcm @@ -0,0 +1 @@ +bld::tool::fppkeys key_xios key_qco key_single diff --git a/src/ICE/icedyn_adv_umx.F90 b/src/ICE/icedyn_adv_umx.F90 index e5113ac90de67aa1d107f9c1aea3275f2c71f9a2..6a057d9b9cda042fcab7b14c32607b773117748f 100644 --- a/src/ICE/icedyn_adv_umx.F90 +++ b/src/ICE/icedyn_adv_umx.F90 @@ -1157,7 +1157,7 @@ CONTAINS REAL(wp), DIMENSION(jpi,jpj ) :: zbup, zbdo REAL(wp), DIMENSION(jpi,jpj,jpl) :: zbetup, zbetdo, zti_ups, ztj_ups !!---------------------------------------------------------------------- - zbig = 1.e+40_wp + zbig = 1.e+20_wp ! antidiffusive flux : high order minus low order ! -------------------------------------------------- diff --git a/src/NST/vremap.F90 b/src/NST/vremap.F90 index 6e3853bff00e1117653109e5c839ae2d31aab04e..e0058cf1cd5948b491f0364ca8e96c0b6225b71e 100644 --- a/src/NST/vremap.F90 +++ b/src/NST/vremap.F90 @@ -292,8 +292,8 @@ CONTAINS ! INTEGER, PARAMETER :: ndof = 1 INTEGER :: jk, jn - REAL(wp) :: zwin(kjpk_in+1) , ztin(ndof, kn_var, kjpk_in) - REAL(wp) :: zwout(kjpk_out+1), ztout(ndof, kn_var, kjpk_out) + REAL(dp) :: zwin(kjpk_in+1) , ztin(ndof, kn_var, kjpk_in) + REAL(dp) :: zwout(kjpk_out+1), ztout(ndof, kn_var, kjpk_out) TYPE(rmap_work) :: work TYPE(rmap_opts) :: opts TYPE(rcon_ends) :: bc_l(kn_var) diff --git a/src/OCE/ASM/asmbkg.F90 b/src/OCE/ASM/asmbkg.F90 index 702b012872e8406d8de34e9a82ac6479f95fcbb7..ddf3a34e83a0f47a286ca7026a9065b95c7ccdcc 100644 --- a/src/OCE/ASM/asmbkg.F90 +++ b/src/OCE/ASM/asmbkg.F90 @@ -70,7 +70,7 @@ CONTAINS CHARACTER (LEN=50) :: cl_asmdin LOGICAL :: llok ! Check if file exists INTEGER :: inum ! File unit number - REAL(dp) :: zdate ! Date + REAL(wp) :: zdate ! Date !!----------------------------------------------------------------------- diff --git a/src/OCE/ASM/asminc.F90 b/src/OCE/ASM/asminc.F90 index 4a4bf5013a4ee23bfdc9b8b22d6318025ba6408f..e87b12b07575053ebae4278be4276f4e7ebd5954 100644 --- a/src/OCE/ASM/asminc.F90 +++ b/src/OCE/ASM/asminc.F90 @@ -68,11 +68,11 @@ MODULE asminc LOGICAL, PUBLIC :: ln_temnofreeze = .FALSE. !: Don't allow the temperature to drop below freezing INTEGER, PUBLIC :: nn_divdmp !: Apply divergence damping filter nn_divdmp times - REAL(dp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: t_bkg , s_bkg !: Background temperature and salinity - REAL(dp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkg , v_bkg !: Background u- & v- velocity components - REAL(dp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: t_bkginc, s_bkginc !: Increment to the background T & S - REAL(dp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkginc, v_bkginc !: Increment to the u- & v-components - REAL(dp), PUBLIC, DIMENSION(:) , ALLOCATABLE :: wgtiau !: IAU weights for each time step + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: t_bkg , s_bkg !: Background temperature and salinity + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkg , v_bkg !: Background u- & v- velocity components + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: t_bkginc, s_bkginc !: Increment to the background T & S + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkginc, v_bkginc !: Increment to the u- & v-components + REAL(wp), PUBLIC, DIMENSION(:) , ALLOCATABLE :: wgtiau !: IAU weights for each time step #if defined key_asminc REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: ssh_iau !: IAU-weighted sea surface height increment #endif @@ -84,16 +84,17 @@ MODULE asminc ! INTEGER , PUBLIC :: niaufn !: Type of IAU weighing function: = 0 Constant weighting ! !: = 1 Linear hat-like, centred in middle of IAU interval - REAL(dp), PUBLIC :: salfixmin !: Ensure that the salinity is larger than this value if (ln_salfix) + REAL(wp), PUBLIC :: salfixmin !: Ensure that the salinity is larger than this value if (ln_salfix) - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: ssh_bkg, ssh_bkginc ! Background sea surface height and its increment - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: seaice_bkginc ! Increment to the background sea ice conc + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ssh_bkg, ssh_bkginc ! Background sea surface height and its increment + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: seaice_bkginc ! Increment to the background sea ice conc #if defined key_cice && defined key_asminc REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ndaice_da ! ice increment tendency into CICE #endif !! * Substitutions # include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -119,20 +120,20 @@ CONTAINS INTEGER :: ios ! Local integer output status for namelist read INTEGER :: iiauper ! Number of time steps in the IAU period INTEGER :: icycper ! Number of time steps in the cycle - REAL(KIND=dp) :: ditend_date ! Date YYYYMMDD.HHMMSS of final time step - REAL(KIND=dp) :: ditbkg_date ! Date YYYYMMDD.HHMMSS of background time step for Jb term - REAL(KIND=dp) :: ditdin_date ! Date YYYYMMDD.HHMMSS of background time step for DI - REAL(KIND=dp) :: ditiaustr_date ! Date YYYYMMDD.HHMMSS of IAU interval start time step - REAL(KIND=dp) :: ditiaufin_date ! Date YYYYMMDD.HHMMSS of IAU interval final time step + REAL(KIND=wp) :: ditend_date ! Date YYYYMMDD.HHMMSS of final time step + REAL(KIND=wp) :: ditbkg_date ! Date YYYYMMDD.HHMMSS of background time step for Jb term + REAL(KIND=wp) :: ditdin_date ! Date YYYYMMDD.HHMMSS of background time step for DI + REAL(KIND=wp) :: ditiaustr_date ! Date YYYYMMDD.HHMMSS of IAU interval start time step + REAL(KIND=wp) :: ditiaufin_date ! Date YYYYMMDD.HHMMSS of IAU interval final time step - REAL(dp) :: znorm ! Normalization factor for IAU weights - REAL(dp) :: ztotwgt ! Value of time-integrated IAU weights (should be equal to one) - REAL(dp) :: z_inc_dateb ! Start date of interval on which increment is valid - REAL(dp) :: z_inc_datef ! End date of interval on which increment is valid - REAL(dp) :: zdate_bkg ! Date in background state file for DI - REAL(dp) :: zdate_inc ! Time axis in increments file + REAL(wp) :: znorm ! Normalization factor for IAU weights + REAL(wp) :: ztotwgt ! Value of time-integrated IAU weights (should be equal to one) + REAL(wp) :: z_inc_dateb ! Start date of interval on which increment is valid + REAL(wp) :: z_inc_datef ! End date of interval on which increment is valid + REAL(wp) :: zdate_bkg ! Date in background state file for DI + REAL(wp) :: zdate_inc ! Time axis in increments file ! - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zhdiv ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zhdiv ! 2D workspace !! NAMELIST/nam_asminc/ ln_bkgwri, & & ln_trainc, ln_dyninc, ln_sshinc, & @@ -420,7 +421,7 @@ CONTAINS & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk) ) & & / e3t(ji,jj,jk,Kmm) END_2D - CALL lbc_lnk( 'asminc', zhdiv, 'T', 1.0_dp ) ! lateral boundary cond. (no sign change) + CALL lbc_lnk( 'asminc', zhdiv, 'T', 1.0_wp ) ! lateral boundary cond. (no sign change) ! DO_2D( 0, 0, 0, 0 ) u_bkginc(ji,jj,jk) = u_bkginc(ji,jj,jk) & @@ -518,15 +519,15 @@ CONTAINS ! INTEGER :: ji, jj, jk INTEGER :: it - REAL(dp) :: zincwgt ! IAU weight for current time step - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: fzptnz ! 3d freezing point values + REAL(wp) :: zincwgt ! IAU weight for current time step + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: fzptnz ! 3d freezing point values !!---------------------------------------------------------------------- ! ! freezing point calculation taken from oc_fz_pt (but calculated for all depths) ! used to prevent the applied increments taking the temperature below the local freezing point IF( ln_temnofreeze ) THEN DO jk = 1, jpkm1 - CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) ) + CALL eos_fzp( CASTSP(pts(:,:,jk,jp_sal,Kmm)), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) ) END DO ENDIF ! @@ -652,7 +653,7 @@ CONTAINS ! INTEGER :: ji, jj, jk INTEGER :: it - REAL(dp) :: zincwgt ! IAU weight for current time step + REAL(wp) :: zincwgt ! IAU weight for current time step !!---------------------------------------------------------------------- ! ! !-------------------------------------------- @@ -727,7 +728,7 @@ CONTAINS ! INTEGER :: it INTEGER :: ji, jj, jk - REAL(dp) :: zincwgt ! IAU weight for current time step + REAL(wp) :: zincwgt ! IAU weight for current time step !!---------------------------------------------------------------------- ! ! !----------------------------------------- @@ -811,10 +812,10 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(IN) :: kt ! ocean time-step index INTEGER, INTENT(IN) :: Kbb, Kmm ! time level indices - REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence !! INTEGER :: ji, jj, jk ! dummy loop index - REAL(dp), DIMENSION(:,:) , POINTER :: ztim ! local array + REAL(wp), DIMENSION(:,:) , POINTER :: ztim ! local array !!---------------------------------------------------------------------- ! #if defined key_asminc @@ -856,7 +857,7 @@ CONTAINS ! INTEGER :: ji, jj INTEGER :: it - REAL(dp) :: zincwgt ! IAU weight for current time step + REAL(wp) :: zincwgt ! IAU weight for current time step #if defined key_si3 REAL(wp), DIMENSION(A2D(nn_hls)) :: zofrld, zohicif, zseaicendg, zhicifinc REAL(wp) :: zhicifmin = 0.5_wp ! ice minimum depth in metres diff --git a/src/OCE/BDY/bdy_oce.F90 b/src/OCE/BDY/bdy_oce.F90 index f1f5b154063ebf4f0e526ca2ee91132527bbe2be..3cdd3a6965133399413fbbacd5731eca7222f3b2 100644 --- a/src/OCE/BDY/bdy_oce.F90 +++ b/src/OCE/BDY/bdy_oce.F90 @@ -30,8 +30,8 @@ MODULE bdy_oce REAL(wp), POINTER, DIMENSION(:,:) :: nbw REAL(wp), POINTER, DIMENSION(:,:) :: nbd REAL(wp), POINTER, DIMENSION(:,:) :: nbdout - REAL(dp), POINTER, DIMENSION(:,:) :: flagu - REAL(dp), POINTER, DIMENSION(:,:) :: flagv + REAL(wp), POINTER, DIMENSION(:,:) :: flagu + REAL(wp), POINTER, DIMENSION(:,:) :: flagv END TYPE OBC_INDEX !! Logicals in OBC_DATA structure are true if the chosen algorithm requires this @@ -46,23 +46,23 @@ MODULE bdy_oce LOGICAL :: lneed_dyn3d LOGICAL :: lneed_tra LOGICAL :: lneed_ice - REAL(dp), POINTER, DIMENSION(:) :: ssh - REAL(dp), POINTER, DIMENSION(:) :: u2d - REAL(dp), POINTER, DIMENSION(:) :: v2d - REAL(dp), POINTER, DIMENSION(:,:) :: u3d - REAL(dp), POINTER, DIMENSION(:,:) :: v3d - REAL(dp), POINTER, DIMENSION(:,:) :: tem - REAL(dp), POINTER, DIMENSION(:,:) :: sal - REAL(dp), POINTER, DIMENSION(:,:) :: a_i !: now ice leads fraction climatology - REAL(dp), POINTER, DIMENSION(:,:) :: h_i !: Now ice thickness climatology - REAL(dp), POINTER, DIMENSION(:,:) :: h_s !: now snow thickness - REAL(dp), POINTER, DIMENSION(:,:) :: t_i !: now ice temperature - REAL(dp), POINTER, DIMENSION(:,:) :: t_s !: now snow temperature - REAL(dp), POINTER, DIMENSION(:,:) :: tsu !: now surf temperature - REAL(dp), POINTER, DIMENSION(:,:) :: s_i !: now ice salinity - REAL(dp), POINTER, DIMENSION(:,:) :: aip !: now ice pond concentration - REAL(dp), POINTER, DIMENSION(:,:) :: hip !: now ice pond depth - REAL(dp), POINTER, DIMENSION(:,:) :: hil !: now ice pond lid depth + REAL(wp), POINTER, DIMENSION(:) :: ssh + REAL(wp), POINTER, DIMENSION(:) :: u2d + REAL(wp), POINTER, DIMENSION(:) :: v2d + REAL(wp), POINTER, DIMENSION(:,:) :: u3d + REAL(wp), POINTER, DIMENSION(:,:) :: v3d + REAL(wp), POINTER, DIMENSION(:,:) :: tem + REAL(wp), POINTER, DIMENSION(:,:) :: sal + REAL(wp), POINTER, DIMENSION(:,:) :: a_i !: now ice leads fraction climatology + REAL(wp), POINTER, DIMENSION(:,:) :: h_i !: Now ice thickness climatology + REAL(wp), POINTER, DIMENSION(:,:) :: h_s !: now snow thickness + REAL(wp), POINTER, DIMENSION(:,:) :: t_i !: now ice temperature + REAL(wp), POINTER, DIMENSION(:,:) :: t_s !: now snow temperature + REAL(wp), POINTER, DIMENSION(:,:) :: tsu !: now surf temperature + REAL(wp), POINTER, DIMENSION(:,:) :: s_i !: now ice salinity + REAL(wp), POINTER, DIMENSION(:,:) :: aip !: now ice pond concentration + REAL(wp), POINTER, DIMENSION(:,:) :: hip !: now ice pond depth + REAL(wp), POINTER, DIMENSION(:,:) :: hil !: now ice pond lid depth #if defined key_top CHARACTER(LEN=20) :: cn_obc !: type of boundary condition to apply REAL(wp) :: rn_fac !: multiplicative scaling factor @@ -102,29 +102,29 @@ MODULE bdy_oce !: = 1 read it in a NetCDF file LOGICAL , DIMENSION(jp_bdy) :: ln_tra_dmp !: =T Tracer damping LOGICAL , DIMENSION(jp_bdy) :: ln_dyn3d_dmp !: =T Baroclinic velocity damping - REAL(dp), DIMENSION(jp_bdy) :: rn_time_dmp !: Damping time scale in days - REAL(dp), DIMENSION(jp_bdy) :: rn_time_dmp_out !: Damping time scale in days at radiation outflow points + REAL(wp), DIMENSION(jp_bdy) :: rn_time_dmp !: Damping time scale in days + REAL(wp), DIMENSION(jp_bdy) :: rn_time_dmp_out !: Damping time scale in days at radiation outflow points CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_ice ! Choice of boundary condition for sea ice variables INTEGER , DIMENSION(jp_bdy) :: nn_ice_dta !: = 0 use the initial state as bdy dta ; !: = 1 read it in a NetCDF file ! ! !!** nambdy_dta ** - REAL(dp), DIMENSION(jp_bdy) :: rice_tem !: temperature of incoming sea ice - REAL(dp), DIMENSION(jp_bdy) :: rice_sal !: salinity of incoming sea ice - REAL(dp), DIMENSION(jp_bdy) :: rice_age !: age of incoming sea ice - REAL(dp), DIMENSION(jp_bdy) :: rice_apnd !: pond conc. of incoming sea ice - REAL(dp), DIMENSION(jp_bdy) :: rice_hpnd !: pond thick. of incoming sea ice - REAL(dp), DIMENSION(jp_bdy) :: rice_hlid !: pond lid thick. of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_tem !: temperature of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_sal !: salinity of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_age !: age of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_apnd !: pond conc. of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_hpnd !: pond thick. of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_hlid !: pond lid thick. of incoming sea ice ! !!---------------------------------------------------------------------- !! Global variables !!---------------------------------------------------------------------- - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdytmask !: Mask defining computational domain at T-points - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdyumask !: Mask defining computational domain at U-points - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdyvmask !: Mask defining computational domain at V-points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdytmask !: Mask defining computational domain at T-points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdyumask !: Mask defining computational domain at U-points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdyvmask !: Mask defining computational domain at V-points - REAL(dp) :: bdysurftot !: Lateral surface of unstructured open boundary + REAL(wp) :: bdysurftot !: Lateral surface of unstructured open boundary !!---------------------------------------------------------------------- !! open boundary data variables diff --git a/src/OCE/BDY/bdydta.F90 b/src/OCE/BDY/bdydta.F90 index fa7abea5524bf2c3cbddb87b0ee929ad7fbee28b..354822f21dd7b0c90e0d2e3a740c32618d4251fb 100644 --- a/src/OCE/BDY/bdydta.F90 +++ b/src/OCE/BDY/bdydta.F90 @@ -208,7 +208,7 @@ CONTAINS ! read/update all bdy data ! ------------------------ ! BDY: use pt_offset=0.5 as applied at the end of the step and fldread is referenced at the middle of the step - CALL fld_read( kt, 1, bf_alias, pt_offset = 0.5_dp, Kmm = Kmm ) + CALL fld_read( kt, 1, bf_alias, pt_offset = 0.5_wp, Kmm = Kmm ) ! apply some corrections in some specific cases... ! -------------------------------------------------- ! @@ -352,7 +352,7 @@ CONTAINS END DO ELSE ! Add tides if not split-explicit free surface else this is done in ts loop ! - CALL bdy_dta_tides( kt=kt, pt_offset = 1._dp ) + CALL bdy_dta_tides( kt=kt, pt_offset = 1._wp ) ENDIF ENDIF ! @@ -381,7 +381,7 @@ CONTAINS LOGICAL :: ln_full_vel ! =T => full velocities in 3D boundary data ! ! =F => baroclinic velocities in 3D boundary data LOGICAL :: ln_zinterp ! =T => requires a vertical interpolation of the bdydta - REAL(dp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid + REAL(wp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid INTEGER :: ipk,ipl ! INTEGER :: idvar ! variable ID INTEGER :: indims ! number of dimensions of the variable @@ -726,4 +726,4 @@ CONTAINS END SUBROUTINE bdy_dta_init !!============================================================================== -END MODULE bdydta +END MODULE bdydta \ No newline at end of file diff --git a/src/OCE/BDY/bdydyn.F90 b/src/OCE/BDY/bdydyn.F90 index 0e1b568d8811ad6a89eba9376e4b2f03f6ebb206..85077b9e3ac3310db5905ba243242c585e07b663 100644 --- a/src/OCE/BDY/bdydyn.F90 +++ b/src/OCE/BDY/bdydyn.F90 @@ -52,7 +52,7 @@ CONTAINS ! INTEGER :: jk, ii, ij, ib_bdy, ib, igrd ! Loop counter LOGICAL :: ll_dyn2d, ll_dyn3d, ll_orlanski - REAL(dp), DIMENSION(jpi,jpj) :: zua2d, zva2d ! after barotropic velocities + REAL(wp), DIMENSION(jpi,jpj) :: zua2d, zva2d ! after barotropic velocities !!---------------------------------------------------------------------- ! ll_dyn2d = .true. diff --git a/src/OCE/BDY/bdydyn2d.F90 b/src/OCE/BDY/bdydyn2d.F90 index 461e0dc7d6d398fd1bf2be2e541e22041a80c469..1872bd06e343713df89b3af8ce5dde5617d398ba 100644 --- a/src/OCE/BDY/bdydyn2d.F90 +++ b/src/OCE/BDY/bdydyn2d.F90 @@ -43,9 +43,9 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: kt ! Main time step counter - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pub2d, pvb2d - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: phur, phvr + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pub2d, pvb2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: phur, phvr REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh !! INTEGER :: ib_bdy, ir ! BDY set index, rim index @@ -110,10 +110,10 @@ CONTAINS END SELECT END DO IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction - CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1.0_dp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) + CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) END IF IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction - CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1.0_dp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) + CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) END IF ! END DO ! ir @@ -134,11 +134,11 @@ CONTAINS TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data INTEGER, INTENT(in) :: ib_bdy ! BDY set index - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d !! INTEGER :: jb ! dummy loop indices INTEGER :: ii, ij, igrd ! local integers - REAL(dp) :: zwgt ! boundary weight + REAL(wp) :: zwgt ! boundary weight !!---------------------------------------------------------------------- ! igrd = 2 ! Relaxation of zonal velocity @@ -182,18 +182,19 @@ CONTAINS TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data INTEGER, INTENT(in) :: ib_bdy ! BDY set index - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pssh, phur, phvr + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phur, phvr + REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pssh LOGICAL , INTENT(in) :: llrim0 ! indicate if rim 0 is treated INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) INTEGER :: jb, igrd ! dummy loop indices INTEGER :: ii, ij ! 2D addresses INTEGER :: iiTrim, ijTrim ! T pts i/j-indice on the rim INTEGER :: iiToce, ijToce, iiUoce, ijVoce ! T, U and V pts i/j-indice of the ocean next to the rim - REAL(dp) :: flagu, flagv ! short cuts - REAL(dp) :: zfla ! Flather correction - REAL(dp) :: z1_2 ! - REAL(dp), DIMENSION(jpi,jpj) :: sshdta ! 2D version of dta%ssh + REAL(wp) :: flagu, flagv ! short cuts + REAL(wp) :: zfla ! Flather correction + REAL(wp) :: z1_2 ! + REAL(wp), DIMENSION(jpi,jpj) :: sshdta ! 2D version of dta%ssh !!---------------------------------------------------------------------- z1_2 = 0.5_wp @@ -286,8 +287,8 @@ CONTAINS TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data INTEGER, INTENT(in) :: ib_bdy ! number of current open boundary set - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d LOGICAL, INTENT(in) :: ll_npo ! flag for NPO version LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated INTEGER :: ib, igrd ! dummy loop indices diff --git a/src/OCE/BDY/bdydyn3d.F90 b/src/OCE/BDY/bdydyn3d.F90 index 29b16ab752ad78b1f0ac90a738e264ed444115b6..db3d30485ad6badcf36bd01d5beb7ec5f41c715b 100644 --- a/src/OCE/BDY/bdydyn3d.F90 +++ b/src/OCE/BDY/bdydyn3d.F90 @@ -274,7 +274,7 @@ CONTAINS ! INTEGER :: jb, jk ! dummy loop indices INTEGER :: ii, ij, igrd ! local integers - REAL(dp) :: zwgt ! boundary weight + REAL(wp) :: zwgt ! boundary weight !!---------------------------------------------------------------------- ! igrd = 2 ! Relaxation of zonal velocity @@ -348,7 +348,7 @@ CONTAINS INTEGER :: jb, jk ! dummy loop indices INTEGER :: ib_bdy ! loop index INTEGER :: ii, ij, igrd ! local integers - REAL(dp) :: zwgt ! boundary weight + REAL(wp) :: zwgt ! boundary weight !!---------------------------------------------------------------------- IF( l_istiled .AND. ntile /= 1 ) RETURN ! Do only for the full domain ! diff --git a/src/OCE/BDY/bdyini.F90 b/src/OCE/BDY/bdyini.F90 index 3ce42378fec8ff094a72be79bb3bc3c6eb986245..1b32ec371401d16c0dd17ae1564b423f1a357b5f 100644 --- a/src/OCE/BDY/bdyini.F90 +++ b/src/OCE/BDY/bdyini.F90 @@ -163,11 +163,11 @@ CONTAINS INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbidta, nbjdta ! Index arrays: i and j indices of bdy dta INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbrdta ! Discrete distance from rim points CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zz_read ! work space for 2D global boundary data - REAL(dp), POINTER , DIMENSION(:,:) :: zmask ! pointer to 2D mask fields - REAL(dp) , DIMENSION(jpi,jpj) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) - REAL(dp) , DIMENSION(jpi,jpj) :: ztmask, zumask, zvmask ! temporary u/v mask array - REAL(dp) , DIMENSION(jpi,jpj) :: zzbdy + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zz_read ! work space for 2D global boundary data + REAL(wp), POINTER , DIMENSION(:,:) :: zmask ! pointer to 2D mask fields + REAL(wp) , DIMENSION(jpi,jpj) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) + REAL(wp) , DIMENSION(jpi,jpj) :: ztmask, zumask, zvmask ! temporary u/v mask array + REAL(wp) , DIMENSION(jpi,jpj) :: zzbdy !!---------------------------------------------------------------------- ! cgrid = (/'t','u','v'/) @@ -704,7 +704,7 @@ CONTAINS zfmask(ji,jj) = ztmask(ji,jj ) * ztmask(ji+1,jj ) & & * ztmask(ji,jj+1) * ztmask(ji+1,jj+1) END_2D - CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_dp ) + CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp ) ! Read global 2D mask at T-points: bdytmask ! ----------------------------------------- @@ -718,7 +718,7 @@ CONTAINS bdyumask(ji,jj) = bdytmask(ji,jj) * bdytmask(ji+1,jj ) bdyvmask(ji,jj) = bdytmask(ji,jj) * bdytmask(ji ,jj+1) END_2D - CALL lbc_lnk( 'bdyini', bdyumask, 'U', 1.0_dp , bdyvmask, 'V', 1.0_dp ) ! Lateral boundary cond. + CALL lbc_lnk( 'bdyini', bdyumask, 'U', 1.0_wp , bdyvmask, 'V', 1.0_wp ) ! Lateral boundary cond. ! bdy masks are now set to zero on rim 0 points: DO ib_bdy = 1, nb_bdy @@ -757,7 +757,7 @@ CONTAINS zfmask(ji,jj) = ztmask(ji,jj ) * ztmask(ji+1,jj ) & & * ztmask(ji,jj+1) * ztmask(ji+1,jj+1) END_2D - CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_dp ) + CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp ) ! bdy masks are now set to zero on rim1 points: DO ib_bdy = 1, nb_bdy @@ -1045,17 +1045,17 @@ CONTAINS !! mask array values on both sides to compute flagu and flagv !! - and look at the ocean neighbours to compute ntreat !!---------------------------------------------------------------------- - REAL(dp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pumask, pvmask ! temporary u/v mask array - REAL(dp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pfmask ! temporary fmask excluding coastal boundary condition (shlat) + REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pumask, pvmask ! temporary u/v mask array + REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pfmask ! temporary fmask excluding coastal boundary condition (shlat) LOGICAL , INTENT (in ) :: lrim0 ! .true. -> rim 0 .false. -> rim 1 INTEGER :: ib_bdy, ii, ij, igrd, ib, icount ! dummy loop indices INTEGER :: i_offset, j_offset, inn ! local integer INTEGER :: ibeg, iend ! local integer LOGICAL :: llnon, llson, llean, llwen ! local logicals indicating the presence of a ocean neighbour - REAL(dp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields - REAL(dp) :: zefl, zwfl, znfl, zsfl ! local scalars + REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields + REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars CHARACTER(LEN=1), DIMENSION(jpbgrd) :: cgrid - REAL(dp) , DIMENSION(jpi,jpj) :: ztmp + REAL(wp) , DIMENSION(jpi,jpj) :: ztmp !!---------------------------------------------------------------------- cgrid = (/'t','u','v'/) @@ -1101,9 +1101,9 @@ CONTAINS CALL ctl_stop( ctmp1 ) ENDIF SELECT CASE( igrd ) - CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_dp ) - CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_dp ) - CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_dp ) + CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) END SELECT DO ib = ibeg, iend ii = idx_bdy(ib_bdy)%nbi(ib,igrd) @@ -1142,9 +1142,9 @@ CONTAINS CALL ctl_stop( ctmp1 ) ENDIF SELECT CASE( igrd ) - CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_dp ) - CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_dp ) - CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_dp ) + CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) END SELECT DO ib = ibeg, iend ii = idx_bdy(ib_bdy)%nbi(ib,igrd) @@ -1221,9 +1221,9 @@ CONTAINS END IF END DO SELECT CASE( igrd ) - CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_dp ) - CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_dp ) - CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_dp ) + CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) END SELECT DO ib = ibeg, iend ii = idx_bdy(ib_bdy)%nbi(ib,igrd) @@ -1397,7 +1397,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: ib, ib1, ib2, ji ,jj, itest INTEGER, DIMENSION(jp_nseg,2) :: icorne, icornw, icornn, icorns - REAL(dp), DIMENSION(2) :: ztestmask + REAL(wp), DIMENSION(2) :: ztestmask !!---------------------------------------------------------------------- ! IF (lwp) WRITE(numout,*) ' ' @@ -1959,7 +1959,7 @@ CONTAINS INTEGER :: ib_bdy, ii, ij, igrd, ib ! dummy loop indices INTEGER :: inum ! - - REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields - REAL(dp) , DIMENSION(jpi,jpj) :: ztmp + REAL(wp) , DIMENSION(jpi,jpj) :: ztmp CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid !!---------------------------------------------------------------------- cgrid = (/'t','u','v'/) @@ -1975,7 +1975,7 @@ CONTAINS DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) ! nbr deined for all rims ii = idx_bdy(ib_bdy)%nbi(ib,igrd) ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%nbr(ib,igrd),dp) + 10. + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%nbr(ib,igrd), wp) + 10. IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) END DO END DO @@ -1985,7 +1985,7 @@ CONTAINS DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagu defined only for rims 0 and 1 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagu(ib,igrd),dp) + 10. + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagu(ib,igrd), wp) + 10. IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) END DO END DO @@ -1995,7 +1995,7 @@ CONTAINS DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagv defined only for rims 0 and 1 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagv(ib,igrd),dp) + 10. + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagv(ib,igrd), wp) + 10. IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) END DO END DO @@ -2005,7 +2005,7 @@ CONTAINS DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! ntreat defined only for rims 0 and 1 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%ntreat(ib,igrd),dp) + 10. + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%ntreat(ib,igrd), wp) + 10. IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) END DO END DO @@ -2016,4 +2016,4 @@ CONTAINS END SUBROUTINE bdy_meshwri !!================================================================================= -END MODULE bdyini +END MODULE bdyini \ No newline at end of file diff --git a/src/OCE/BDY/bdylib.F90 b/src/OCE/BDY/bdylib.F90 index d9ba5ad84b960594d79332907ec7350fdd5c205e..b3776e4ab14b49a12635b2b385a934cf1340530a 100644 --- a/src/OCE/BDY/bdylib.F90 +++ b/src/OCE/BDY/bdylib.F90 @@ -43,10 +43,10 @@ CONTAINS !! Reference : Engedahl H., 1995, Tellus, 365-382. !!---------------------------------------------------------------------- TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices - REAL(dp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data + REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend !! - REAL(dp) :: zwgt ! boundary weight + REAL(wp) :: zwgt ! boundary weight INTEGER :: ib, ik, igrd ! dummy loop indices INTEGER :: ii, ij ! 2D addresses !!---------------------------------------------------------------------- @@ -72,7 +72,7 @@ CONTAINS !! !!---------------------------------------------------------------------- TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices - REAL(dp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data + REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend !! INTEGER :: ib, ik, igrd ! dummy loop indices @@ -100,7 +100,7 @@ CONTAINS !! !!---------------------------------------------------------------------- TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices - REAL(dp), DIMENSION(:,:), POINTER, INTENT(in ) :: dta ! OBC external data + REAL(wp), DIMENSION(:,:), POINTER, INTENT(in ) :: dta ! OBC external data REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phib ! before tracer field REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated @@ -129,9 +129,9 @@ CONTAINS !!---------------------------------------------------------------------- TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices INTEGER , INTENT(in ) :: igrd ! grid index - REAL(dp), DIMENSION(:,:), INTENT(in ) :: phib ! model before 2D field - REAL(dp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated) - REAL(dp), DIMENSION(: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data + REAL(wp), DIMENSION(:,:), INTENT(in ) :: phib ! model before 2D field + REAL(wp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated) + REAL(wp), DIMENSION(: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version ! @@ -142,11 +142,11 @@ CONTAINS INTEGER :: ii_offset, ij_offset ! offsets for mask indices INTEGER :: flagu, flagv ! short cuts INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) - REAL(dp) :: zmask_x, zmask_y1, zmask_y2 - REAL(dp) :: zex1, zex2, zey, zey1, zey2 - REAL(dp) :: zdt, zdx, zdy, znor2, zrx, zry ! intermediate calculations + REAL(wp) :: zmask_x, zmask_y1, zmask_y2 + REAL(wp) :: zex1, zex2, zey, zey1, zey2 + REAL(wp) :: zdt, zdx, zdy, znor2, zrx, zry ! intermediate calculations REAL(dp) :: zout, zwgt, zdy_centred - REAL(dp) :: zdy_1, zdy_2, zsign_ups + REAL(wp) :: zdy_1, zdy_2, zsign_ups REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! land/sea mask for field REAL(wp), POINTER, DIMENSION(:,:) :: zmask_xdif ! land/sea mask for x-derivatives @@ -293,7 +293,7 @@ CONTAINS INTEGER , INTENT(in ) :: igrd ! grid index REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: phib ! model before 3D field REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated) - REAL(dp), DIMENSION(:,: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data + REAL(wp), DIMENSION(:,: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version ! @@ -304,11 +304,11 @@ CONTAINS INTEGER :: ii_offset, ij_offset ! offsets for mask indices INTEGER :: flagu, flagv ! short cuts INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) - REAL(dp) :: zmask_x, zmask_y1, zmask_y2 - REAL(dp) :: zex1, zex2, zey, zey1, zey2 - REAL(dp) :: zdt, zdx, zdy, znor2, zrx, zry ! intermediate calculations + REAL(wp) :: zmask_x, zmask_y1, zmask_y2 + REAL(wp) :: zex1, zex2, zey, zey1, zey2 + REAL(wp) :: zdt, zdx, zdy, znor2, zrx, zry ! intermediate calculations REAL(dp) :: zout, zwgt, zdy_centred - REAL(dp) :: zdy_1, zdy_2, zsign_ups + REAL(wp) :: zdy_1, zdy_2, zsign_ups REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask ! land/sea mask for field REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask_xdif ! land/sea mask for x-derivatives @@ -461,7 +461,7 @@ CONTAINS TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated !! - REAL(dp) :: zweight + REAL(wp) :: zweight REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask ! land/sea mask for field INTEGER :: ib, ik ! dummy loop indices INTEGER :: ii, ij ! 2D addresses diff --git a/src/OCE/BDY/bdytides.F90 b/src/OCE/BDY/bdytides.F90 index e0d898c369db00e79a1bd5bfe16535080ca0305a..fa5268095263fecc9c4a4594040cbaf06367a756 100644 --- a/src/OCE/BDY/bdytides.F90 +++ b/src/OCE/BDY/bdytides.F90 @@ -75,8 +75,8 @@ CONTAINS INTEGER :: nbdy_rdstart, nbdy_loc CHARACTER(LEN=50) :: cerrmsg ! error string CHARACTER(len=80) :: clfile ! full file name for tidal input file - REAL(dp),ALLOCATABLE, DIMENSION(:,:,:) :: dta_read ! work space to read in tidal harmonics data - REAL(dp),ALLOCATABLE, DIMENSION(:,:) :: ztr, zti ! 35A87HK 5ZDCJ 7SOYO 4QZ4OFSF + REAL(wp),ALLOCATABLE, DIMENSION(:,:,:) :: dta_read ! work space to read in tidal harmonics data + REAL(wp),ALLOCATABLE, DIMENSION(:,:) :: ztr, zti ! " " " " " " " " !! TYPE(TIDES_DATA), POINTER :: td ! local short cut TYPE( OBC_DATA), POINTER :: dta ! local short cut @@ -282,11 +282,11 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: kt ! Main timestep counter INTEGER, OPTIONAL, INTENT(in) :: kit ! Barotropic timestep counter (for timesplitting option) - REAL(dp),OPTIONAL, INTENT(in) :: pt_offset ! time offset in units of timesteps + REAL(wp),OPTIONAL, INTENT(in) :: pt_offset ! time offset in units of timesteps ! LOGICAL :: lk_first_btstp ! =.TRUE. if time splitting and first barotropic step INTEGER :: itide, ib_bdy, ib ! loop indices - REAL(dp) :: z_arg, z_sarg, zramp, zoff, z_cost, z_sist, zt_offset + REAL(wp) :: z_arg, z_sarg, zramp, zoff, z_cost, z_sist, zt_offset !!---------------------------------------------------------------------- ! lk_first_btstp=.TRUE. @@ -297,14 +297,14 @@ CONTAINS ! Absolute time from model initialization: IF( PRESENT(kit) ) THEN - z_arg = ( REAL(kt,dp) + ( REAL(kit,dp) + zt_offset - 1. ) / REAL(nn_e,dp) ) * rn_Dt + z_arg = ( REAL(kt, wp) + ( REAL(kit, wp) + zt_offset - 1. ) / REAL(nn_e, wp) ) * rn_Dt ELSE - z_arg = ( REAL(kt,dp) + zt_offset ) * rn_Dt + z_arg = ( REAL(kt, wp) + zt_offset ) * rn_Dt ENDIF ! Linear ramp on tidal component at open boundaries zramp = 1. - IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg - REAL(nit000,dp)*rn_Dt)/(rn_tide_ramp_dt*rday),0.),1.) + IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg - REAL(nit000,wp)*rn_Dt)/(rn_tide_ramp_dt*rday),0.),1.) DO ib_bdy = 1,nb_bdy ! @@ -314,7 +314,7 @@ CONTAINS ! This should be done somewhere else IF ( ( nsec_day == NINT(0.5_wp * rn_Dt) .OR. kt==nit000 ) .AND. lk_first_btstp ) THEN ! - kt_tide = kt - NINT((REAL(nsec_day,dp) - 0.5_wp * rn_Dt)/rn_Dt) + kt_tide = kt - NINT((REAL(nsec_day,wp) - 0.5_wp * rn_Dt)/rn_Dt) ! IF(lwp) THEN WRITE(numout,*) @@ -326,7 +326,7 @@ CONTAINS CALL tide_init_velocities( idx=idx_bdy(ib_bdy), td=tides(ib_bdy) ) ! ENDIF - zoff = REAL(-kt_tide,dp) * rn_Dt ! time offset relative to nodal factor computation time + zoff = REAL(-kt_tide,wp) * rn_Dt ! time offset relative to nodal factor computation time ! ! If time splitting, initialize arrays from slow varying open boundary data: IF ( PRESENT(kit) ) THEN @@ -381,7 +381,7 @@ CONTAINS TYPE(TIDES_DATA), INTENT(inout) :: td ! tidal harmonics data ! INTEGER :: itide, isz, ib ! dummy loop indices - REAL(dp),ALLOCATABLE, DIMENSION(:) :: mod_tide, phi_tide + REAL(wp),ALLOCATABLE, DIMENSION(:) :: mod_tide, phi_tide !!---------------------------------------------------------------------- ! IF( ASSOCIATED(td%ssh0) ) THEN ! SSH on tracer grid. @@ -419,7 +419,7 @@ CONTAINS TYPE(TIDES_DATA), INTENT(inout) :: td ! tidal harmonics data ! INTEGER :: itide, isz, ib ! dummy loop indices - REAL(dp),ALLOCATABLE, DIMENSION(:) :: mod_tide, phi_tide + REAL(wp),ALLOCATABLE, DIMENSION(:) :: mod_tide, phi_tide !!---------------------------------------------------------------------- ! IF( ASSOCIATED(td%u0) ) THEN ! U grid. we use bdy u2d on this mpi subdomain diff --git a/src/OCE/BDY/bdytra.F90 b/src/OCE/BDY/bdytra.F90 index 4189bbef76bffd37e9984f3be9841469edcb9f47..a4cf4117beab1194b14813bdf20d3fa7eea8123e 100644 --- a/src/OCE/BDY/bdytra.F90 +++ b/src/OCE/BDY/bdytra.F90 @@ -27,7 +27,7 @@ MODULE bdytra ! Local structure to rearrange tracers data TYPE, PUBLIC :: ztrabdy - REAL(dp), POINTER, DIMENSION(:,:) :: tra + REAL(wp), POINTER, DIMENSION(:,:) :: tra END TYPE PUBLIC bdy_tra ! called in tranxt.F90 @@ -151,8 +151,8 @@ CONTAINS INTEGER , INTENT(in) :: Kbb, Krhs ! time level indices REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation ! - REAL(dp) :: zwgt ! boundary weight - REAL(dp) :: zta, zsa, ztime + REAL(wp) :: zwgt ! boundary weight + REAL(wp) :: zta, zsa, ztime INTEGER :: ib, ik, igrd ! dummy loop indices INTEGER :: ii, ij ! 2D addresses INTEGER :: ib_bdy ! Loop index diff --git a/src/OCE/BDY/bdyvol.F90 b/src/OCE/BDY/bdyvol.F90 index d6b502cf0edfd177fb264fe5e0d378bf571ef1fd..1ff413e63b8cad8212f8822f7edbd6ef60c690c1 100644 --- a/src/OCE/BDY/bdyvol.F90 +++ b/src/OCE/BDY/bdyvol.F90 @@ -67,10 +67,10 @@ CONTAINS ! INTEGER :: ji, jj, jk, jb, jgrd INTEGER :: ib_bdy, ii, ij - REAL(dp) :: zubtpecor, ztranst - REAL(dp), SAVE :: z_cflxemp ! cumulated emp flux - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d ! Barotropic velocities - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: phu, phv ! Ocean depth at U- and V-points + REAL(wp) :: zubtpecor, ztranst + REAL(wp), SAVE :: z_cflxemp ! cumulated emp flux + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d ! Barotropic velocities + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phu, phv ! Ocean depth at U- and V-points TYPE(OBC_INDEX), POINTER :: idx !!----------------------------------------------------------------------------- ! @@ -179,7 +179,7 @@ CONTAINS ! END SUBROUTINE bdy_vol2d ! - REAL(dp) FUNCTION bdy_segs_surf(phu, phv) + REAL(wp) FUNCTION bdy_segs_surf(phu, phv) !!---------------------------------------------------------------------- !! *** ROUTINE bdy_ctl_seg *** !! @@ -187,10 +187,10 @@ CONTAINS !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: phu, phv ! water column thickness at U and V points + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phu, phv ! water column thickness at U and V points INTEGER :: igrd, ib_bdy, ib ! loop indexes INTEGER , POINTER :: nbi, nbj ! short cuts - REAL(dp), POINTER :: zflagu, zflagv ! - - + REAL(wp), POINTER :: zflagu, zflagv ! - - ! Compute total lateral surface for volume correction: ! ---------------------------------------------------- diff --git a/src/OCE/C1D/c1d.F90 b/src/OCE/C1D/c1d.F90 index e9e28daf19003a57cc87cf01322d1e5d032a8aed..0a8b533a1e4dd3af367baef7b35acf998f695a54 100644 --- a/src/OCE/C1D/c1d.F90 +++ b/src/OCE/C1D/c1d.F90 @@ -21,8 +21,8 @@ MODULE c1d PUBLIC c1d_init ! called by nemogcm.F90 - REAL(dp), PUBLIC :: rn_lat1d !: Column latitude - REAL(dp), PUBLIC :: rn_lon1d !: Column longitude + REAL(wp), PUBLIC :: rn_lat1d !: Column latitude + REAL(wp), PUBLIC :: rn_lon1d !: Column longitude !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) diff --git a/src/OCE/C1D/dtauvd.F90 b/src/OCE/C1D/dtauvd.F90 index ca370d505d64a4659823155e27489b072c3d96d9..ba3401741ed1c1d9af2f88670619e712796ef119 100644 --- a/src/OCE/C1D/dtauvd.F90 +++ b/src/OCE/C1D/dtauvd.F90 @@ -139,8 +139,8 @@ CONTAINS ! INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers - REAL(dp):: zl, zi ! local floats - REAL(dp), ALLOCATABLE, DIMENSION(:) :: zup, zvp ! 1D workspace + REAL(wp):: zl, zi ! local floats + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zup, zvp ! 1D workspace !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('dta_uvd') diff --git a/src/OCE/C1D/dyndmp.F90 b/src/OCE/C1D/dyndmp.F90 index 887f7617a1ecdbfee354e9320863f87b11e7117d..37b0e57ab0ba8eb9d713bc005ca9921df7b6ad8e 100644 --- a/src/OCE/C1D/dyndmp.F90 +++ b/src/OCE/C1D/dyndmp.F90 @@ -37,9 +37,9 @@ MODULE dyndmp LOGICAL, PUBLIC :: ln_dyndmp !: Flag for Newtonian damping - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: utrdmp !: damping U current trend (m/s2) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vtrdmp !: damping V current trend (m/s2) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto_uv !: restoring coeff. on U & V current + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: utrdmp !: damping U current trend (m/s2) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vtrdmp !: damping V current trend (m/s2) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto_uv !: restoring coeff. on U & V current !! * Substitutions # include "do_loop_substitute.h90" @@ -151,7 +151,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation !! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zua, zva ! local scalars + REAL(wp) :: zua, zva ! local scalars REAL(dp), DIMENSION(jpi,jpj,jpk,2) :: zuv_dta ! Read in data !!---------------------------------------------------------------------- ! @@ -215,4 +215,4 @@ CONTAINS END SUBROUTINE dyn_dmp !!====================================================================== -END MODULE dyndmp +END MODULE dyndmp \ No newline at end of file diff --git a/src/OCE/CRS/crs.F90 b/src/OCE/CRS/crs.F90 index 58a9bfb941a23a2ec7475fbf879d541510101815..5cfaf57a03fc11a822949d53e79f9073a3c48fac 100644 --- a/src/OCE/CRS/crs.F90 +++ b/src/OCE/CRS/crs.F90 @@ -62,32 +62,32 @@ MODULE crs ! Masks - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_crs, umask_crs, vmask_crs, fmask_crs - REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: rnfmsk_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_crs, umask_crs, vmask_crs, fmask_crs + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: rnfmsk_crs ! Scale factors - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: e1t_crs, e2t_crs, e1e2t_crs ! horizontal scale factors grid type T - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: e1u_crs, e2u_crs ! horizontal scale factors grid type U - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: e1v_crs, e2v_crs ! horizontal scale factors grid type V - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: e1f_crs, e2f_crs ! horizontal scale factors grid type F - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_crs, e3u_crs, e3v_crs, e3f_crs, e3w_crs - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_max_crs, e3u_max_crs, e3v_max_crs, e3f_max_crs, e3w_max_crs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1t_crs, e2t_crs, e1e2t_crs ! horizontal scale factors grid type T + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1u_crs, e2u_crs ! horizontal scale factors grid type U + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1v_crs, e2v_crs ! horizontal scale factors grid type V + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1f_crs, e2f_crs ! horizontal scale factors grid type F + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_crs, e3u_crs, e3v_crs, e3f_crs, e3w_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_max_crs, e3u_max_crs, e3v_max_crs, e3f_max_crs, e3w_max_crs ! Surface - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: e1e2w_crs, e2e3u_crs, e1e3v_crs - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: e1e2w_msk, e2e3u_msk, e1e3v_msk + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e1e2w_crs, e2e3u_crs, e1e3v_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e1e2w_msk, e2e3u_msk, e1e3v_msk ! vertical scale factors ! Coordinates - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: gphit_crs, glamt_crs, gphif_crs, glamf_crs - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: gphiu_crs, glamu_crs, gphiv_crs, glamv_crs - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: ff_crs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphit_crs, glamt_crs, gphif_crs, glamf_crs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphiu_crs, glamu_crs, gphiv_crs, glamv_crs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ff_crs INTEGER, DIMENSION(:,:), ALLOCATABLE :: mbathy_crs, mbkt_crs, mbku_crs, mbkv_crs - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: gdept_crs, gdepu_crs, gdepv_crs, gdepw_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: gdept_crs, gdepu_crs, gdepv_crs, gdepw_crs ! Weights - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: facsurfv, facsurfu, facvol_t, facvol_w - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ocean_volume_crs_t, ocean_volume_crs_w, bt_crs, r1_bt_crs - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: crs_surfu_wgt, crs_surfv_wgt, crs_surfw_wgt, crs_volt_wgt + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: facsurfv, facsurfu, facvol_t, facvol_w + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ocean_volume_crs_t, ocean_volume_crs_w, bt_crs, r1_bt_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: crs_surfu_wgt, crs_surfv_wgt, crs_surfw_wgt, crs_volt_wgt ! CRS Namelist INTEGER :: nn_factx = 3 !: reduction factor of x-dimension of the parent grid @@ -103,25 +103,25 @@ MODULE crs ! Grid reduction factors - REAL(dp) :: rfactx_r !: inverse of x-dim reduction factor - REAL(dp) :: rfacty_r !: inverse of y-dim reduction factor - REAL(dp) :: rfactxy + REAL(wp) :: rfactx_r !: inverse of x-dim reduction factor + REAL(wp) :: rfacty_r !: inverse of y-dim reduction factor + REAL(wp) :: rfactxy ! Physical and dynamical ocean fields for output or passing to TOP, time-mean fields - REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: tsn_crs - REAL(dp), DIMENSION(:,:,:) , ALLOCATABLE :: un_crs, vn_crs, wn_crs - REAL(dp), DIMENSION(:,:,:) , ALLOCATABLE :: hdivn_crs - REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: sshn_crs + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tsn_crs + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: un_crs, vn_crs, wn_crs + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: hdivn_crs + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: sshn_crs ! ! Surface fluxes to pass to TOP - REAL(dp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: qsr_crs, fr_i_crs, wndm_crs - REAL(dp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: emp_crs, emp_b_crs, sfx_crs - REAL(dp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: utau_crs, vtau_crs - REAL(dp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: rnf_crs + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: qsr_crs, fr_i_crs, wndm_crs + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: emp_crs, emp_b_crs, sfx_crs + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: utau_crs, vtau_crs + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: rnf_crs ! Vertical diffusion - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_crs !: temperature vertical diffusivity coeff. [m2/s] at w-point - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avs_crs !: salinity vertical diffusivity coeff. [m2/s] at w-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_crs !: temperature vertical diffusivity coeff. [m2/s] at w-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avs_crs !: salinity vertical diffusivity coeff. [m2/s] at w-point ! Mixing and Mixed Layer Depth INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: nmln_crs, hmld_crs, hmlp_crs, hmlpt_crs diff --git a/src/OCE/CRS/crsdom.F90 b/src/OCE/CRS/crsdom.F90 index 24cb7ccbc60822dc59387aa71f112cf8c5afea23..c4c47aae3989a1be498ae0dd809d14f61161906d 100644 --- a/src/OCE/CRS/crsdom.F90 +++ b/src/OCE/CRS/crsdom.F90 @@ -49,7 +49,7 @@ MODULE crsdom MODULE PROCEDURE crs_dom_ope_3d, crs_dom_ope_2d END INTERFACE - REAL(dp) :: r_inf = 1e+36 + REAL(wp) :: r_inf = 1e+36 !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -62,7 +62,7 @@ CONTAINS INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ijie,ijis,ijje,ijjs,ij,je_2 - REAL(dp) :: zmask + REAL(wp) :: zmask ! Initialize @@ -123,10 +123,10 @@ CONTAINS ENDDO ! - CALL crs_lbc_lnk( tmask_crs, 'T', 1.0_dp ) - CALL crs_lbc_lnk( vmask_crs, 'V', 1.0_dp ) - CALL crs_lbc_lnk( umask_crs, 'U', 1.0_dp ) - CALL crs_lbc_lnk( fmask_crs, 'F', 1.0_dp ) + CALL crs_lbc_lnk( tmask_crs, 'T', 1.0_wp ) + CALL crs_lbc_lnk( vmask_crs, 'V', 1.0_wp ) + CALL crs_lbc_lnk( umask_crs, 'U', 1.0_wp ) + CALL crs_lbc_lnk( fmask_crs, 'F', 1.0_wp ) ! END SUBROUTINE crs_dom_msk @@ -154,11 +154,11 @@ CONTAINS !! History. 1 Jun. !!---------------------------------------------------------------- !! Arguments - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_gphi ! Parent grid latitude - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_glam ! Parent grid longitude + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_gphi ! Parent grid latitude + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_glam ! Parent grid longitude CHARACTER(len=1), INTENT(in) :: cd_type ! grid type (T,U,V,F) - REAL(dp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs ! Coarse grid latitude - REAL(dp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs ! Coarse grid longitude + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs ! Coarse grid latitude + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs ! Coarse grid longitude !! Local variables INTEGER :: ji, jj, jk ! dummy loop indices @@ -205,8 +205,8 @@ CONTAINS END SELECT ! Retroactively add back the boundary halo cells. - CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0_dp ) - CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0_dp ) + CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0_wp ) + CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0_wp ) ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd SELECT CASE ( cd_type ) @@ -249,8 +249,8 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e2 ! Parent grid U,V scale factors (e2) CHARACTER(len=1) , INTENT(in) :: cd_type ! grid type U,V - REAL(dp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e1_crs ! Coarse grid box 2D quantity - REAL(dp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e2_crs ! Coarse grid box 2D quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e1_crs ! Coarse grid box 2D quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e2_crs ! Coarse grid box 2D quantity !! Local variables INTEGER :: ji, jj, jk ! dummy loop indices @@ -295,8 +295,8 @@ CONTAINS ENDDO ENDDO - CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0_dp, pfillval=1.0_dp ) - CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0_dp, pfillval=1.0_dp ) + CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) END SUBROUTINE crs_dom_hgr @@ -344,13 +344,13 @@ CONTAINS REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_mask ! Parent grid U,V mask REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: p_e1 ! Parent grid U,V scale factors (e1) REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: p_e2 ! Parent grid U,V scale factors (e2) - REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld1_crs ! Coarse grid box 3D quantity - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld2_crs ! Coarse grid box 3D quantity + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld1_crs ! Coarse grid box 3D quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld2_crs ! Coarse grid box 3D quantity ! INTEGER :: ji, jj, jk , ii, ij, je_2 - REAL(dp) :: zdAm - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zvol, zmask + REAL(wp) :: zdAm + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvol, zmask !!---------------------------------------------------------------- ! ! @@ -439,8 +439,8 @@ CONTAINS ENDDO ENDDO ! ! Retroactively add back the boundary halo cells. - CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0_dp ) - CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0_dp ) + CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0_wp ) + CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0_wp ) ! ! END SUBROUTINE crs_dom_facvol @@ -469,21 +469,21 @@ CONTAINS !! 4 Jun. Revision for WGT !! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights. !!---------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_fld ! T, U, V or W on parent grid + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_fld ! T, U, V or W on parent grid CHARACTER(len=3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask REAL(dp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2) - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V maska REAL(wp), INTENT(in) :: psgn ! sign - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld_crs ! Coarse grid box 3D quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld_crs ! Coarse grid box 3D quantity ! INTEGER :: ji, jj, jk INTEGER :: ii, ij, ijie, ijje, je_2 - REAL(dp) :: zflcrs, zsfcrs - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zsurf, zsurfmsk, zmask + REAL(wp) :: zflcrs, zsfcrs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zsurf, zsurfmsk, zmask !!---------------------------------------------------------------- ! p_fld_crs(:,:,:) = 0._wp @@ -1104,7 +1104,7 @@ CONTAINS ! END SELECT ! - CALL crs_lbc_lnk( p_fld_crs, cd_type, REAL(psgn,dp) ) + CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn ) ! END SUBROUTINE crs_dom_ope_3d @@ -1131,21 +1131,21 @@ CONTAINS !! 4 Jun. Revision for WGT !! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights. !!---------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: p_fld ! T, U, V or W on parent grid + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_fld ! T, U, V or W on parent grid CHARACTER(len=3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask REAL(dp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2) - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) - REAL(dp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V mask REAL(wp), INTENT(in) :: psgn - REAL(dp), DIMENSION(jpi_crs,jpj_crs) , INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ijie, ijje, ii, ij, je_2 - REAL(dp) :: zflcrs, zsfcrs - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zsurfmsk + REAL(wp) :: zflcrs, zsfcrs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsurfmsk !!---------------------------------------------------------------- ! p_fld_crs(:,:) = 0._wp @@ -1621,7 +1621,7 @@ CONTAINS ! END SELECT ! - CALL crs_lbc_lnk( p_fld_crs, cd_type, REAL(psgn,dp) ) + CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn ) ! END SUBROUTINE crs_dom_ope_2d @@ -1631,16 +1631,16 @@ CONTAINS CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T mask REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1, p_e2 ! 2D tracer T or W on parent grid - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in) :: p_sfc_crs ! Coarse grid box east or north face quantity - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in) :: p_sfc_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity !! Local variables INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ijie, ijje, ii, ij, je_2 - REAL(dp) :: ze3crs - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zmask, zsurf + REAL(wp) :: ze3crs + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask, zsurf !!---------------------------------------------------------------- @@ -1747,8 +1747,8 @@ CONTAINS ENDDO ENDDO - CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0_dp, pfillval=1.0_dp ) - CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0_dp, pfillval=1.0_dp ) + CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) ! ! END SUBROUTINE crs_dom_e3 @@ -1758,15 +1758,15 @@ CONTAINS !! Arguments CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_mask ! Parent grid T mask - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in), OPTIONAL :: p_e1, p_e2 ! 3D tracer T or W on parent grid - REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT(in), OPTIONAL :: p_e3 ! 3D tracer T or W on parent grid - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs ! Coarse grid box east or north face quantity - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs_msk ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in), OPTIONAL :: p_e1, p_e2 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in), OPTIONAL :: p_e3 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs_msk ! Coarse grid box east or north face quantity !! Local variables INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ii, ij, je_2 - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zsurf, zsurfmsk + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsurf, zsurfmsk !!---------------------------------------------------------------- ! Initialize @@ -1856,8 +1856,8 @@ CONTAINS ENDDO ENDDO - CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0_dp, pfillval=1.0_dp ) - CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0_dp, pfillval=1.0_dp ) + CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0_wp, pfillval=1.0_wp ) END SUBROUTINE crs_dom_sfc @@ -1916,10 +1916,10 @@ CONTAINS !!$ ! Calculs suivant une découpage en j !!$ DO jn = 1, jpnij, jpni !!$ IF( jn < ( jpnij - jpni + 1 ) ) THEN -!!$ nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty,dp ) ) & -!!$ & - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty,dp ) ) +!!$ nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) & +!!$ & - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) ) !!$ ELSE -!!$ nje0all_crs(jn) = AINT( REAL( nje0all(jn) / nn_facty,dp ) ) + 1 +!!$ nje0all_crs(jn) = AINT( REAL( nje0all(jn) / nn_facty, wp ) ) + 1 !!$ ENDIF !!$ IF( noso < 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 !!$ SELECT CASE( ibonjt(jn) ) @@ -1949,7 +1949,7 @@ CONTAINS !!$ IF(njs0all_crs(jn) == 1 ) THEN !!$ njmppt_crs(jn) = 1 !!$ ELSE -!!$ njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty,dp ) ) +!!$ njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) ) !!$ ENDIF !!$ !!$ DO jj = jn + 1, jn + jpni - 1 @@ -1967,10 +1967,10 @@ CONTAINS !!$ ! Calcul suivant un decoupage en i !!$ DO jn = 1, jpni !!$ IF( jn == 1 ) THEN -!!$ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx,dp) ) +!!$ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) !!$ ELSE -!!$ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx,dp) ) & -!!$ & - AINT( REAL( ( nimppt(jn-1) - 1 + jpiall(jn-1) ) / nn_factx,dp) ) +!!$ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) & +!!$ & - AINT( REAL( ( nimppt(jn-1) - 1 + jpiall(jn-1) ) / nn_factx, wp) ) !!$ ENDIF !!$ !!$ SELECT CASE( ibonit(jn) ) @@ -1994,7 +1994,7 @@ CONTAINS !!$ CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' ) !!$ END SELECT !!$ -!!$ nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx,dp ) ) + 1 +!!$ nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1 !!$ DO jj = jn + jpni , jpnij, jpni !!$ nie0all_crs(jj) = nie0all_crs(jn) !!$ jpiall_crs (jj) = jpiall_crs (jn) @@ -2221,7 +2221,7 @@ CONTAINS !! !! local variables INTEGER :: ji,jj,jk ! dummy indices - REAL(dp), DIMENSION(jpi_crs, jpj_crs) :: zmbk + REAL(wp), DIMENSION(jpi_crs, jpj_crs) :: zmbk !!---------------------------------------------------------------- mbathy_crs(:,:) = jpkm1 @@ -2241,7 +2241,7 @@ CONTAINS ENDDO zmbk(:,:) = 0.0 - zmbk(:,:) = REAL( mbathy_crs(:,:),dp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0_dp) ; mbathy_crs(:,:) = NINT( zmbk(:,:) ) + zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0_wp) ; mbathy_crs(:,:) = NINT( zmbk(:,:) ) ! @@ -2261,10 +2261,10 @@ CONTAINS ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk zmbk(:,:) = 1.e0; - zmbk(:,:) = REAL( mbku_crs(:,:),dp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0_dp) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) - zmbk(:,:) = REAL( mbkv_crs(:,:),dp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0_dp) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) + zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0_wp) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) + zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0_wp) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) ! END SUBROUTINE crs_dom_bat -END MODULE crsdom +END MODULE crsdom \ No newline at end of file diff --git a/src/OCE/CRS/crsdomwri.F90 b/src/OCE/CRS/crsdomwri.F90 index acb34860747986d3af1202d3472f1dfc19c3bd86..a51718999351c653b88d6b653e4df87ffb24a66a 100644 --- a/src/OCE/CRS/crsdomwri.F90 +++ b/src/OCE/CRS/crsdomwri.F90 @@ -51,8 +51,8 @@ CONTAINS INTEGER :: inum ! local units for 'mesh_mask.nc' file CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) ! ! workspace - REAL(dp), DIMENSION(jpi_crs,jpj_crs ) :: zprt, zprw - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk) :: zdepu, zdepv + REAL(wp), DIMENSION(jpi_crs,jpj_crs ) :: zprt, zprw + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk) :: zdepu, zdepv !!---------------------------------------------------------------------- ! ! @@ -113,7 +113,7 @@ CONTAINS !======================================================== ! ! vertical mesh ! ! note that mbkt is set to 1 over land ==> use surface tmask_crs - zprt(:,:) = tmask_crs(:,:,1) * REAL( mbkt_crs(:,:) ,dp ) + zprt(:,:) = tmask_crs(:,:,1) * REAL( mbkt_crs(:,:) , wp ) CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i2 ) ! ! nb of ocean T-points ! CALL iom_rstput( 0, 0, inum, 'e3t', e3t_crs ) @@ -130,7 +130,7 @@ CONTAINS END DO END DO END DO - CALL crs_lbc_lnk( zdepu,'U', 1.0_dp ) ; CALL crs_lbc_lnk( zdepv,'V', 1.0_dp ) + CALL crs_lbc_lnk( zdepu,'U', 1.0_wp ) ; CALL crs_lbc_lnk( zdepv,'V', 1.0_wp ) ! CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 ) CALL iom_rstput( 0, 0, inum, 'gdepv', zdepv, ktype = jp_r4 ) @@ -176,28 +176,28 @@ CONTAINS !! 2) check which elements have been changed !!---------------------------------------------------------------------- CHARACTER(len=1) , INTENT(in ) :: cdgrd ! - REAL(dp), DIMENSION(:,:), INTENT(inout) :: puniq ! + REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq ! ! - REAL(dp) :: zshift ! shift value link to the process number + REAL(wp) :: zshift ! shift value link to the process number INTEGER :: ji ! dummy loop indices LOGICAL , DIMENSION(jpi_crs,jpj_crs,1) :: lluniq ! store whether each point is unique or not - REAL(dp), DIMENSION(jpi_crs,jpj_crs ) :: ztstref + REAL(wp), DIMENSION(jpi_crs,jpj_crs ) :: ztstref !!---------------------------------------------------------------------- ! ! build an array with different values for each element ! in mpp: make sure that these values are different even between process ! -> apply a shift value according to the process number zshift = (jpi_crs+1.) * (jpj_crs+1.) * ( narea - 1 ) ! we should use jpimax_crs but not existing - ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,dp), ji = 1, jpi_crs*jpj_crs) /), (/ jpi_crs, jpj_crs /) ) + ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi_crs*jpj_crs) /), (/ jpi_crs, jpj_crs /) ) ! puniq(:,:) = ztstref(:,:) ! default definition - CALL crs_lbc_lnk( puniq,cdgrd, 1.0_dp ) ! apply boundary conditions + CALL crs_lbc_lnk( puniq,cdgrd, 1.0_wp ) ! apply boundary conditions lluniq(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed ! - puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ),dp ) + puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp ) ! END SUBROUTINE dom_uniq_crs !!====================================================================== -END MODULE crsdomwri +END MODULE crsdomwri \ No newline at end of file diff --git a/src/OCE/CRS/crsfld.F90 b/src/OCE/CRS/crsfld.F90 index 9eb5903c460d04e0df4b32c4bcc984f686c2130c..6bbb7c3b6bdb494ad1bfdbcd9ddf86cf591de54d 100644 --- a/src/OCE/CRS/crsfld.F90 +++ b/src/OCE/CRS/crsfld.F90 @@ -58,12 +58,12 @@ CONTAINS INTEGER, INTENT(in) :: Kmm ! time level index ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: z2dcrsu, z2dcrsv ! local scalars - REAL(dp) :: zztmp ! - - + REAL(wp) :: z2dcrsu, z2dcrsv ! local scalars + REAL(wp) :: zztmp ! - - ! - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, ze3w ! 3D workspace for e3 - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zt , zs , z3d - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk) :: zt_crs, zs_crs + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, ze3w ! 3D workspace for e3 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zt , zs , z3d + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk) :: zt_crs, zs_crs !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('crs_fld') @@ -117,30 +117,30 @@ CONTAINS CALL iom_put( "sss" , tsn_crs(:,:,1,jp_sal) ) ! sss ! U-velocity - CALL crs_dom_ope( uu(:,:,:,Kmm), 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( CASTSP(uu(:,:,:,Kmm)), 'SUM', 'U', umask, un_crs, p_e12=CASTDP(e2u), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) ! zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp DO_3D( 0, 0, 0, 0, 1, jpkm1 ) zt(ji,jj,jk) = uu(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) ) zs(ji,jj,jk) = uu(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) ) END_3D - CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) - CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=CASTDP(e2u), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=CASTDP(e2u), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) CALL iom_put( "uoce" , un_crs ) ! i-current CALL iom_put( "uocet" , zt_crs ) ! uT CALL iom_put( "uoces" , zs_crs ) ! uS ! V-velocity - CALL crs_dom_ope( vv(:,:,:,Kmm), 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( CASTSP(vv(:,:,:,Kmm)), 'SUM', 'V', vmask, vn_crs, p_e12=CASTDP(e1v), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) ! zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp DO_3D( 0, 0, 0, 0, 1, jpkm1 ) zt(ji,jj,jk) = vv(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) ) zs(ji,jj,jk) = vv(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) ) END_3D - CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) - CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=CASTDP(e1v), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=CASTDP(e1v), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) CALL iom_put( "voce" , vn_crs ) ! i-current CALL iom_put( "vocet" , zt_crs ) ! vT @@ -156,7 +156,7 @@ CONTAINS & + vv(ji,jj-1,jk,Kmm)**2 * e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) & & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) ) END_3D - CALL lbc_lnk( 'crsfld', z3d, 'T', 1.0_dp ) + CALL lbc_lnk( 'crsfld', z3d, 'T', 1.0_wp ) ! CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) CALL iom_put( "ke", zt_crs ) @@ -176,7 +176,7 @@ CONTAINS END DO END DO END DO - CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0_dp ) + CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0_wp ) ! CALL iom_put( "hdiv", hdivn_crs ) @@ -211,14 +211,14 @@ CONTAINS CALL iom_put( "avs", avs_crs ) ! Kz on S ! sbc fields - CALL crs_dom_ope( ssh(:,:,Kmm) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0_wp ) - CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u , p_surf_crs=e2u_crs , psgn=1.0_wp ) - CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v , p_surf_crs=e1v_crs , psgn=1.0_wp ) + CALL crs_dom_ope( CASTSP(ssh(:,:,Kmm)) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0_wp ) + CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=CASTDP(e2u) , p_surf_crs=e2u_crs , psgn=1.0_wp ) + CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=CASTDP(e1v) , p_surf_crs=e1v_crs , psgn=1.0_wp ) CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) CALL crs_dom_ope( rnf , 'MAX', 'T', tmask, rnf_crs , psgn=1.0_wp ) CALL crs_dom_ope( qsr , 'SUM', 'T', tmask, qsr_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) - CALL crs_dom_ope( CASTDP(emp) , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( emp , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) @@ -240,4 +240,4 @@ CONTAINS END SUBROUTINE crs_fld !!====================================================================== -END MODULE crsfld +END MODULE crsfld \ No newline at end of file diff --git a/src/OCE/CRS/crsini.F90 b/src/OCE/CRS/crsini.F90 index bac9c4d430ec811df08a13f16a7c2851a83de7ac..5f2ab0e01e7497fe8615a56014c91438d78339e0 100644 --- a/src/OCE/CRS/crsini.F90 +++ b/src/OCE/CRS/crsini.F90 @@ -28,6 +28,7 @@ MODULE crsini PUBLIC crs_init ! called by nemogcm.F90 module !! * Substitutions +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -74,7 +75,7 @@ CONTAINS INTEGER :: ji,jj,jk ! dummy indices INTEGER :: ierr ! allocation error status INTEGER :: ios ! Local integer output status for namelist read - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, ze3w + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, ze3w NAMELIST/namcrs/ nn_factx, nn_facty, nn_binref, ln_msh_crs, nn_crs_kz, ln_crs_wn !!---------------------------------------------------------------------- @@ -153,8 +154,8 @@ CONTAINS ! 3.c.1 Horizontal scale factors CALL crs_dom_hgr( e1t, e2t, 'T', e1t_crs, e2t_crs ) - CALL crs_dom_hgr( e1u, e2u, 'U', e1u_crs, e2u_crs ) - CALL crs_dom_hgr( e1v, e2v, 'V', e1v_crs, e2v_crs ) + CALL crs_dom_hgr( e1u, CASTDP(e2u), 'U', e1u_crs, e2u_crs ) + CALL crs_dom_hgr( CASTDP(e1v), e2v, 'V', e1v_crs, e2v_crs ) CALL crs_dom_hgr( e1f, e2f, 'F', e1f_crs, e2f_crs ) e1e2t_crs(:,:) = e1t_crs(:,:) * e2t_crs(:,:) @@ -183,7 +184,7 @@ CONTAINS END DO ! 3.d.2 Surfaces - CALL crs_dom_sfc( tmask, 'W', e1e2w_crs, e1e2w_msk, p_e1=e1t, p_e2=e2t ) + CALL crs_dom_sfc( tmask, 'W', e1e2w_crs, e1e2w_msk, p_e1=CASTSP(e1t), p_e2=CASTSP(e2t) ) CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=ze3u ) CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=ze3v ) @@ -193,8 +194,8 @@ CONTAINS ! 3.d.3 Vertical scale factors ! CALL crs_dom_e3( e1t, e2t, ze3t, e1e2w_crs, 'T', tmask, e3t_crs, e3t_max_crs) - CALL crs_dom_e3( e1u, e2u, ze3u, e2e3u_crs, 'U', umask, e3u_crs, e3u_max_crs) - CALL crs_dom_e3( e1v, e2v, ze3v, e1e3v_crs, 'V', vmask, e3v_crs, e3v_max_crs) + CALL crs_dom_e3( e1u, CASTDP(e2u), ze3u, e2e3u_crs, 'U', umask, e3u_crs, e3u_max_crs) + CALL crs_dom_e3( CASTDP(e1v), e2v, ze3v, e1e3v_crs, 'V', vmask, e3v_crs, e3v_max_crs) CALL crs_dom_e3( e1t, e2t, ze3w, e1e2w_crs, 'W', tmask, e3w_crs, e3w_max_crs) ! Replace 0 by e3t_0 or e3w_0 diff --git a/src/OCE/CRS/crslbclnk.F90 b/src/OCE/CRS/crslbclnk.F90 index c0b6f8b4a4fe8a30cf14fafa032d28a610fa16ee..b7e4d194b60494030977c2bb730f8f36750234ce 100644 --- a/src/OCE/CRS/crslbclnk.F90 +++ b/src/OCE/CRS/crslbclnk.F90 @@ -37,10 +37,10 @@ CONTAINS !! Upon exiting, switch back to full domain indices. !!---------------------------------------------------------------------- CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! grid type - REAL(dp) , INTENT(in ) :: psgn ! control of the sign - REAL(dp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 ! 3D array on which the lbc is applied + REAL(wp) , INTENT(in ) :: psgn ! control of the sign + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 ! 3D array on which the lbc is applied INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = cst) - REAL(dp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) ! LOGICAL :: ll_grid_crs !!---------------------------------------------------------------------- @@ -67,10 +67,10 @@ CONTAINS !! Upon exiting, switch back to full domain indices. !!---------------------------------------------------------------------- CHARACTER(len=1) , INTENT(in ) :: cd_type ! grid type - REAL(dp) , INTENT(in ) :: psgn ! control of the sign - REAL(dp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied + REAL(wp) , INTENT(in ) :: psgn ! control of the sign + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) - REAL(dp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) ! LOGICAL :: ll_grid_crs !!---------------------------------------------------------------------- @@ -86,4 +86,4 @@ CONTAINS END SUBROUTINE crs_lbc_lnk_2d !!====================================================================== -END MODULE crslbclnk +END MODULE crslbclnk \ No newline at end of file diff --git a/src/OCE/DIA/dia25h.F90 b/src/OCE/DIA/dia25h.F90 index 439886e27210693cf3d4ff96d36119cd7955a512..411a3f582cbcf37183153a7e2fe742cb9d7e5fda 100644 --- a/src/OCE/DIA/dia25h.F90 +++ b/src/OCE/DIA/dia25h.F90 @@ -24,12 +24,12 @@ MODULE dia25h ! variables for calculating 25-hourly means INTEGER , SAVE :: cnt_25h ! Counter for 25 hour means - REAL(dp), SAVE :: r1_25 = 0.04_wp ! =1/25 - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: tn_25h , sn_25h - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: sshn_25h - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: un_25h , vn_25h , wn_25h - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avt_25h , avm_25h - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: en_25h , rmxln_25h + REAL(wp), SAVE :: r1_25 = 0.04_wp ! =1/25 + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: tn_25h , sn_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: sshn_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: un_25h , vn_25h , wn_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avt_25h , avm_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: en_25h , rmxln_25h !! * Substitutions # include "do_loop_substitute.h90" @@ -142,9 +142,9 @@ CONTAINS LOGICAL :: ll_print = .FALSE. ! =T print and flush numout REAL(dp) :: zsto, zout, zmax, zjulian, zmdi ! local scalars INTEGER :: i_steps ! no of timesteps per hour - REAL(dp), DIMENSION(A2D(0) ) :: zw2d, un_dm, vn_dm ! workspace - REAL(dp), DIMENSION(A2D(0),jpk) :: zw3d ! workspace - REAL(dp), DIMENSION(A2D(0),3) :: zwtmb ! workspace + REAL(wp), DIMENSION(A2D(0) ) :: zw2d, un_dm, vn_dm ! workspace + REAL(wp), DIMENSION(A2D(0),jpk) :: zw3d ! workspace + REAL(wp), DIMENSION(A2D(0),3) :: zwtmb ! workspace !!---------------------------------------------------------------------- ! 0. Initialisation diff --git a/src/OCE/DIA/diaar5.F90 b/src/OCE/DIA/diaar5.F90 index c31cc023183fc790096147072737b6862d97b3ac..af124f74696dfa427cb1819238ecd988cd2731fe 100644 --- a/src/OCE/DIA/diaar5.F90 +++ b/src/OCE/DIA/diaar5.F90 @@ -29,15 +29,16 @@ MODULE diaar5 PUBLIC dia_ar5_alloc ! routine called in nemogcm.F90 module PUBLIC dia_ar5_hst ! heat/salt transport - REAL(dp) :: vol0 ! ocean volume (interior domain) - REAL(dp) :: area_tot ! total ocean surface (interior domain) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: thick0 ! ocean thickness (interior domain) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sn0 ! initial salinity + REAL(wp) :: vol0 ! ocean volume (interior domain) + REAL(wp) :: area_tot ! total ocean surface (interior domain) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: thick0 ! ocean thickness (interior domain) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sn0 ! initial salinity LOGICAL :: l_ar5 !! * Substitutions # include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -72,13 +73,13 @@ CONTAINS INTEGER, INTENT( in ) :: Kmm ! ocean time level index ! INTEGER :: ji, jj, jk, iks, ikb ! dummy loop arguments - REAL(dp) :: zvolssh, zvol, zssh_steric, zztmp, zarho, ztemp, zsal, zmass, zsst - REAL(dp) :: zaw, zbw, zrw + REAL(wp) :: zvolssh, zvol, zssh_steric, zztmp, zarho, ztemp, zsal, zmass, zsst + REAL(wp) :: zaw, zbw, zrw ! - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zarea_ssh , zbotpres ! 2D workspace - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: z2d, zpe ! 2D workspace - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d, zrhd, ztpot, zgdept ! 3D workspace (zgdept: needed to use the substitute) - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztsn ! 4D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zarea_ssh , zbotpres ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d, zpe ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d, zrhd, ztpot, zgdept ! 3D workspace (zgdept: needed to use the substitute) + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztsn ! 4D workspace !!-------------------------------------------------------------------- IF( ln_timing ) CALL timing_start('dia_ar5') @@ -118,7 +119,7 @@ CONTAINS ! IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) ) THEN ! ! total volume of liquid seawater - zvolssh = glob_sum( 'diaar5', zarea_ssh(:,:) ) + zvolssh =glob_sum( 'diaar5', CASTDP(zarea_ssh(:,:)) ) zvol = vol0 + zvolssh CALL iom_put( 'voltot', zvol ) @@ -135,7 +136,7 @@ CONTAINS DO jk = 1, jpk zgdept(:,:,jk) = gdept(:,:,jk,Kmm) END DO - CALL eos( ztsn, zrhd, zgdept) ! now in situ density using initial salinity + CALL eos( CASTDP(ztsn), zrhd, zgdept) ! now in situ density using initial salinity ! zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice DO jk = 1, jpkm1 @@ -213,8 +214,8 @@ CONTAINS END IF ENDIF ! - ztemp = glob_sum( 'diaar5', ztsn(:,:,1,jp_tem) ) - zsal = glob_sum( 'diaar5', ztsn(:,:,1,jp_sal) ) + ztemp =glob_sum( 'diaar5', CASTDP(ztsn(:,:,1,jp_tem)) ) + zsal =glob_sum( 'diaar5', CASTDP(ztsn(:,:,1,jp_sal)) ) zmass = rho0 * ( zarho + zvol ) ! CALL iom_put( 'masstot', zmass ) @@ -230,7 +231,7 @@ CONTAINS ALLOCATE( ztpot(jpi,jpj,jpk) ) ztpot(:,:,jpk) = 0._wp DO jk = 1, jpkm1 - ztpot(:,:,jk) = eos_pt_from_ct( ts(:,:,jk,jp_tem,Kmm), ts(:,:,jk,jp_sal,Kmm) ) + ztpot(:,:,jk) =eos_pt_from_ct( CASTSP(ts(:,:,jk,jp_tem,Kmm)), CASTSP(ts(:,:,jk,jp_sal,Kmm)) ) END DO ! CALL iom_put( 'toce_pot', ztpot(:,:,:) ) ! potential temperature (TEOS-10 case) @@ -241,7 +242,7 @@ CONTAINS DO jk = 1, jpkm1 z2d(:,:) = z2d(:,:) + e1e2t(:,:) * e3t(:,:,jk,Kmm) * ztpot(:,:,jk) END DO - ztemp = glob_sum( 'diaar5', z2d(:,:) ) + ztemp =glob_sum( 'diaar5', CASTDP(z2d(:,:)) ) CALL iom_put( 'temptot_pot', ztemp / zvol ) ENDIF ! @@ -313,11 +314,11 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: ktra ! tracer index CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf' - REAL(dp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: puflx ! u-flux of advection/diffusion - REAL(dp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! v-flux of advection/diffusion + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: puflx ! u-flux of advection/diffusion + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! v-flux of advection/diffusion ! INTEGER :: ji, jj, jk - REAL(dp), DIMENSION(A2D(nn_hls)) :: z2d + REAL(wp), DIMENSION(A2D(nn_hls)) :: z2d z2d(:,:) = puflx(:,:,1) DO_3D( 0, 0, 0, 0, 1, jpkm1 ) @@ -357,9 +358,9 @@ CONTAINS INTEGER :: inum INTEGER :: ik, idep INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zztmp - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zvol0 + REAL(wp) :: zztmp + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zvol0 ! !!---------------------------------------------------------------------- ! @@ -388,7 +389,7 @@ CONTAINS zvol0 (ji,jj) = zvol0 (ji,jj) + idep * e1e2t(ji,jj) thick0(ji,jj) = thick0(ji,jj) + idep END_3D - vol0 = glob_sum( 'diaar5', zvol0 ) + vol0 =glob_sum( 'diaar5', CASTDP(zvol0) ) DEALLOCATE( zvol0 ) IF( iom_use( 'sshthster' ) ) THEN diff --git a/src/OCE/DIA/diacfl.F90 b/src/OCE/DIA/diacfl.F90 index 2808baa7c61ab930affaf996b024003a318337f3..200e7d2d8174e7677d434cf8e4ad764e66c958b3 100644 --- a/src/OCE/DIA/diacfl.F90 +++ b/src/OCE/DIA/diacfl.F90 @@ -26,7 +26,7 @@ MODULE diacfl INTEGER :: numcfl ! outfile unit ! INTEGER, DIMENSION(3) :: nCu_loc, nCv_loc, nCw_loc ! U, V, and W run max locations in the global domain - REAL(dp) :: rCu_max, rCv_max, rCw_max ! associated run max Courant number + REAL(wp) :: rCu_max, rCv_max, rCw_max ! associated run max Courant number PUBLIC dia_cfl ! routine called by step.F90 PUBLIC dia_cfl_init ! routine called by nemogcm @@ -52,9 +52,9 @@ CONTAINS INTEGER, INTENT(in) :: Kmm ! ocean time level index ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zCu_max, zCv_max, zCw_max ! local scalars + REAL(wp) :: zCu_max, zCv_max, zCw_max ! local scalars INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc ! workspace - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace LOGICAL , DIMENSION(jpi,jpj,jpk) :: llmsk !!---------------------------------------------------------------------- ! @@ -87,11 +87,11 @@ CONTAINS ! ! calculate maximum values and locations llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain - CALL mpp_maxloc( 'diacfl', zCu_cfl, llmsk, zCu_max, iloc_u ) + CALL mpp_maxloc( 'diacfl', REAL(zCu_cfl,dp), llmsk, zCu_max, iloc_u ) llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain - CALL mpp_maxloc( 'diacfl', zCv_cfl, llmsk, zCv_max, iloc_v ) + CALL mpp_maxloc( 'diacfl', REAL(zCv_cfl,dp), llmsk, zCv_max, iloc_v ) llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain - CALL mpp_maxloc( 'diacfl', zCw_cfl, llmsk, zCw_max, iloc_w ) + CALL mpp_maxloc( 'diacfl', REAL(zCw_cfl,dp), llmsk, zCw_max, iloc_w ) ! IF( lwp ) THEN ! write out to file WRITE(numcfl,FMT='(2x,i6,3x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) @@ -158,4 +158,4 @@ CONTAINS END SUBROUTINE dia_cfl_init !!====================================================================== -END MODULE diacfl \ No newline at end of file +END MODULE diacfl diff --git a/src/OCE/DIA/diadct.F90 b/src/OCE/DIA/diadct.F90 index a9ad802e199afd376b24d251d97b040b6f858c39..eb57e5e86afbd1059e97c3b058ff62945315f2e3 100644 --- a/src/OCE/DIA/diadct.F90 +++ b/src/OCE/DIA/diadct.F90 @@ -85,11 +85,12 @@ MODULE diadct TYPE(SECTION),DIMENSION(nb_sec_max) :: secs ! Array of sections - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: transports_3d - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: transports_2d + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: transports_3d + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: transports_2d !! * Substitutions +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -200,8 +201,8 @@ CONTAINS LOGICAL :: lldebug =.FALSE. ! debug a section INTEGER , DIMENSION(1) :: ish ! work array for mpp_sum INTEGER , DIMENSION(3) :: ish2 ! " - REAL(dp), ALLOCATABLE, DIMENSION(:) :: zwork ! " - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:):: zsum ! " + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zwork ! " + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:):: zsum ! " !!--------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('dia_dct') @@ -585,9 +586,9 @@ CONTAINS INTEGER ,INTENT(IN) :: jsec ! numeric identifier of section ! INTEGER :: jk, jseg, jclass,jl, isgnu, isgnv ! loop on level/segment/classes/ice categories - REAL(dp):: zumid, zvmid, zumid_ice, zvmid_ice ! U/V ocean & ice velocity on a cell segment - REAL(dp):: zTnorm ! transport of velocity through one cell's sides - REAL(dp):: ztn, zsn, zrhoi, zrhop, zsshn, zdep ! temperature/salinity/potential density/ssh/depth at u/v point + REAL(wp):: zumid, zvmid, zumid_ice, zvmid_ice ! U/V ocean & ice velocity on a cell segment + REAL(wp):: zTnorm ! transport of velocity through one cell's sides + REAL(wp):: ztn, zsn, zrhoi, zrhop, zsshn, zdep ! temperature/salinity/potential density/ssh/depth at u/v point TYPE(POINT_SECTION) :: k !!-------------------------------------------------------- ! @@ -678,13 +679,13 @@ CONTAINS ztn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_tem,Kmm) ) zsn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_sal,Kmm) ) zrhop = interp(Kmm,k%I,k%J,jk,'V',rhop) - zrhoi = interp(Kmm,k%I,k%J,jk,'V',rhd*rho0+rho0) + zrhoi =interp(Kmm,k%I,k%J,jk,'V',CASTDP(rhd*rho0+rho0)) zsshn = 0.5*( ssh(k%I,k%J,Kmm) + ssh(k%I,k%J+1,Kmm) ) * vmask(k%I,k%J,1) CASE(2,3) ztn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_tem,Kmm) ) zsn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_sal,Kmm) ) zrhop = interp(Kmm,k%I,k%J,jk,'U',rhop) - zrhoi = interp(Kmm,k%I,k%J,jk,'U',rhd*rho0+rho0) + zrhoi =interp(Kmm,k%I,k%J,jk,'U',CASTDP(rhd*rho0+rho0)) zsshn = 0.5*( ssh(k%I,k%J,Kmm) + ssh(k%I+1,k%J,Kmm) ) * umask(k%I,k%J,1) END SELECT ! @@ -792,7 +793,7 @@ CONTAINS TYPE(POINT_SECTION) :: k INTEGER :: jk,jseg,jclass ! dummy variables for looping on level/segment/classes - REAL(dp) :: ztn, zsn, zrhoi, zrhop, zsshn, zdep ! temperature/salinity/ssh/potential density /depth at u/v point + REAL(wp) :: ztn, zsn, zrhoi, zrhop, zsshn, zdep ! temperature/salinity/ssh/potential density /depth at u/v point !!------------------------------------------------------------- !! Sum the relevant segments to obtain values for each class @@ -851,13 +852,13 @@ CONTAINS ztn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_tem,Kmm) ) zsn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_sal,Kmm) ) zrhop = interp(Kmm,k%I,k%J,jk,'V',rhop) - zrhoi = interp(Kmm,k%I,k%J,jk,'V',rhd*rho0+rho0) + zrhoi =interp(Kmm,k%I,k%J,jk,'V',CASTDP(rhd*rho0+rho0)) CASE(2,3) ztn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_tem,Kmm) ) zsn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_sal,Kmm) ) zrhop = interp(Kmm,k%I,k%J,jk,'U',rhop) - zrhoi = interp(Kmm,k%I,k%J,jk,'U',rhd*rho0+rho0) + zrhoi =interp(Kmm,k%I,k%J,jk,'U',CASTDP(rhd*rho0+rho0)) zsshn = 0.5*( ssh(k%I,k%J,Kmm) + ssh(k%I+1,k%J,Kmm) ) * umask(k%I,k%J,1) END SELECT @@ -985,10 +986,10 @@ CONTAINS !!local declarations INTEGER :: jclass ! Dummy loop CHARACTER(len=2) :: classe ! Classname - REAL(dp) :: zbnd1,zbnd2 ! Class bounds - REAL(dp) :: zslope ! section's slope coeff + REAL(wp) :: zbnd1,zbnd2 ! Class bounds + REAL(wp) :: zslope ! section's slope coeff ! - REAL(dp), DIMENSION(nb_type_class):: zsumclasses ! 1D workspace + REAL(wp), DIMENSION(nb_type_class):: zsumclasses ! 1D workspace !!------------------------------------------------------------- zsumclasses(:)=0._wp @@ -1169,14 +1170,14 @@ CONTAINS INTEGER, INTENT(IN) :: ki, kj, kk ! coordinate of point CHARACTER(len=1), INTENT(IN) :: cd_point ! type of point (U, V) REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(IN) :: ptab ! variable to compute at (ki, kj, kk ) - REAL(dp) :: interp ! interpolated variable + REAL(wp) :: interp ! interpolated variable !*local declations INTEGER :: ii1, ij1, ii2, ij2 ! local integer - REAL(dp):: ze3t, ze3, zwgt1, zwgt2, zbis, zdepu ! local real - REAL(dp):: zet1, zet2 ! weight for interpolation - REAL(dp):: zdep1,zdep2 ! differences of depth - REAL(dp):: zmsk ! mask value + REAL(wp):: ze3t, ze3, zwgt1, zwgt2, zbis, zdepu ! local real + REAL(wp):: zet1, zet2 ! weight for interpolation + REAL(wp):: zdep1,zdep2 ! differences of depth + REAL(wp):: zmsk ! mask value !!---------------------------------------------------------------------- IF( cd_point=='U' )THEN diff --git a/src/OCE/DIA/diadetide.F90 b/src/OCE/DIA/diadetide.F90 index c45caf4b8018b520629e240e25893ccb5fd2463d..7d277180446411cd2ac5aeab463aaf358a31d69f 100644 --- a/src/OCE/DIA/diadetide.F90 +++ b/src/OCE/DIA/diadetide.F90 @@ -21,7 +21,7 @@ MODULE diadetide LOGICAL, PUBLIC :: lk_diadetide INTEGER :: ndiadetide - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:) :: tdiadetide + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: tdiadetide PUBLIC :: dia_detide_init, dia_detide @@ -41,7 +41,7 @@ CONTAINS !! !!---------------------------------------------------------------------- - REAL(dp) :: zdt + REAL(wp) :: zdt INTEGER :: jn CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: ctide_selected = ' n/a ' TYPE(tide_harmonic), DIMENSION(:), POINTER :: stideconst @@ -91,8 +91,8 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: kt - REAL(dp), DIMENSION(jpi,jpj) :: zwght_2D - REAL(dp) :: zwght, ztmp + REAL(wp), DIMENSION(jpi,jpj) :: zwght_2D + REAL(wp) :: zwght, ztmp INTEGER :: jn ! Compute detiding weight at the current time-step; the daily total weight @@ -110,4 +110,4 @@ CONTAINS END SUBROUTINE dia_detide -END MODULE diadetide +END MODULE diadetide \ No newline at end of file diff --git a/src/OCE/DIA/diahsb.F90 b/src/OCE/DIA/diahsb.F90 index 5c1a643602a7860b486d42731c73913972f7360e..d189fd3ecea30cd9da32924355b30f2f702364ad 100644 --- a/src/OCE/DIA/diahsb.F90 +++ b/src/OCE/DIA/diahsb.F90 @@ -39,15 +39,18 @@ MODULE diahsb LOGICAL, PUBLIC :: ln_diahsb !: check the heat and salt budgets - REAL(dp) :: surf_tot ! ocean surface - REAL(dp) :: frc_t, frc_s, frc_v ! global forcing trends - REAL(dp) :: frc_wn_t, frc_wn_s ! global forcing trends + REAL(wp) :: surf_tot ! ocean surface + REAL(wp) :: frc_s! global forcing trends + REAL(dp) :: frc_t, frc_v! global forcing trends + REAL(wp) :: frc_wn_t, frc_wn_s ! global forcing trends ! REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: surf - REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: surf_ini , ssh_ini ! - REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: ssh_hc_loc_ini, ssh_sc_loc_ini ! - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: hc_loc_ini, sc_loc_ini, e3t_ini ! - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_ini + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ssh_ini! + REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: surf_ini! + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ssh_hc_loc_ini, ssh_sc_loc_ini ! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: hc_loc_ini! + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: sc_loc_ini, e3t_ini! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_ini !! * Substitutions # include "domzgr_substitute.h90" @@ -73,15 +76,15 @@ CONTAINS INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices ! INTEGER :: ji, jj, jk ! dummy loop indice - REAL(dp) :: zdiff_hc , zdiff_sc ! heat and salt content variations - REAL(dp) :: zdiff_hc1 , zdiff_sc1 ! - - - - + REAL(wp) :: zdiff_hc , zdiff_sc ! heat and salt content variations + REAL(wp) :: zdiff_hc1 , zdiff_sc1 ! - - - - REAL(dp) :: zdiff_v1 , zdiff_v2 ! volume variation - REAL(dp) :: zerr_hc1 , zerr_sc1 ! heat and salt content misfit - REAL(dp) :: zvol_tot ! volume - REAL(dp) :: z_frc_trd_t , z_frc_trd_s ! - - + REAL(wp) :: zerr_hc1 , zerr_sc1 ! heat and salt content misfit + REAL(wp) :: zvol_tot ! volume + REAL(wp) :: z_frc_trd_t , z_frc_trd_s ! - - REAL(dp) :: z_frc_trd_v ! - - - REAL(dp) :: z_wn_trd_t , z_wn_trd_s ! - - - REAL(dp) :: z_ssh_hc , z_ssh_sc ! - - + REAL(wp) :: z_wn_trd_t , z_wn_trd_s ! - - + REAL(wp) :: z_ssh_hc , z_ssh_sc ! - - REAL(dp), DIMENSION(jpi,jpj,13) :: ztmp REAL(dp), DIMENSION(jpi,jpj,jpkm1,4) :: ztmpk REAL(dp), DIMENSION(17) :: zbg @@ -241,8 +244,8 @@ CONTAINS CALL iom_put( 'bgheatfx' , zdiff_hc * rho0 * rcp / & ! Heat flux drift (W/m2) & ( surf_tot * kt * rn_Dt ) ) CALL iom_put( 'bgsaltco' , zdiff_sc * 1.e-9 ) ! Salt content drift (psu*km3) - CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9_dp ) ! volume ssh drift (km3) - CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9_dp ) ! volume e3t drift (km3) + CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9 ) ! volume ssh drift (km3) + CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9 ) ! volume e3t drift (km3) ! IF( kt == nitend .AND. lwp ) THEN WRITE(numout,*) @@ -440,4 +443,4 @@ CONTAINS END SUBROUTINE dia_hsb_init !!====================================================================== -END MODULE diahsb +END MODULE diahsb \ No newline at end of file diff --git a/src/OCE/DIA/diahth.F90 b/src/OCE/DIA/diahth.F90 index b4e22e1bb419a6d9ba58fc491a952bed24461afc..285d85e8b3a849807b510c366395681d3321bf14 100644 --- a/src/OCE/DIA/diahth.F90 +++ b/src/OCE/DIA/diahth.F90 @@ -30,13 +30,13 @@ MODULE diahth LOGICAL, SAVE :: l_hth !: thermocline-20d depths flag ! note: following variables should move to local variables once iom_put is always used - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hth !: depth of the max vertical temperature gradient [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd20 !: depth of 20 C isotherm [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd26 !: depth of 26 C isotherm [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd28 !: depth of 28 C isotherm [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc3 !: heat content of first 300 m [W] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc7 !: heat content of first 700 m [W] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc20 !: heat content of first 2000 m [W] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hth !: depth of the max vertical temperature gradient [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd20 !: depth of 20 C isotherm [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd26 !: depth of 26 C isotherm [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd28 !: depth of 28 C isotherm [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc3 !: heat content of first 300 m [W] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc7 !: heat content of first 700 m [W] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc20 !: heat content of first 2000 m [W] !! * Substitutions @@ -87,21 +87,21 @@ CONTAINS INTEGER, INTENT( in ) :: Kmm ! ocean time level index !! INTEGER :: ji, jj, jk ! dummy loop arguments - REAL(dp) :: zrho3 = 0.03_wp ! density criterion for mixed layer depth - REAL(dp) :: zrho1 = 0.01_wp ! density criterion for mixed layer depth - REAL(dp) :: ztem2 = 0.2_wp ! temperature criterion for mixed layer depth - REAL(dp) :: zztmp, zzdep ! temporary scalars inside do loop - REAL(dp) :: zu, zv, zw, zut, zvt ! temporary workspace - REAL(dp), DIMENSION(jpi,jpj) :: zabs2 ! MLD: abs( tn - tn(10m) ) = ztem2 - REAL(dp), DIMENSION(jpi,jpj) :: ztm2 ! Top of thermocline: tn = tn(10m) - ztem2 - REAL(dp), DIMENSION(jpi,jpj) :: zrho10_3 ! MLD: rho = rho10m + zrho3 - REAL(dp), DIMENSION(jpi,jpj) :: zpycn ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) - REAL(dp), DIMENSION(jpi,jpj) :: ztinv ! max of temperature inversion - REAL(dp), DIMENSION(jpi,jpj) :: zdepinv ! depth of temperature inversion - REAL(dp), DIMENSION(jpi,jpj) :: zrho0_3 ! MLD rho = rho(surf) = 0.03 - REAL(dp), DIMENSION(jpi,jpj) :: zrho0_1 ! MLD rho = rho(surf) = 0.01 - REAL(dp), DIMENSION(jpi,jpj) :: zmaxdzT ! max of dT/dz - REAL(dp), DIMENSION(jpi,jpj) :: zdelr ! delta rho equivalent to deltaT = 0.2 + REAL(wp) :: zrho3 = 0.03_wp ! density criterion for mixed layer depth + REAL(wp) :: zrho1 = 0.01_wp ! density criterion for mixed layer depth + REAL(wp) :: ztem2 = 0.2_wp ! temperature criterion for mixed layer depth + REAL(wp) :: zztmp, zzdep ! temporary scalars inside do loop + REAL(wp) :: zu, zv, zw, zut, zvt ! temporary workspace + REAL(wp), DIMENSION(jpi,jpj) :: zabs2 ! MLD: abs( tn - tn(10m) ) = ztem2 + REAL(wp), DIMENSION(jpi,jpj) :: ztm2 ! Top of thermocline: tn = tn(10m) - ztem2 + REAL(wp), DIMENSION(jpi,jpj) :: zrho10_3 ! MLD: rho = rho10m + zrho3 + REAL(wp), DIMENSION(jpi,jpj) :: zpycn ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) + REAL(wp), DIMENSION(jpi,jpj) :: ztinv ! max of temperature inversion + REAL(wp), DIMENSION(jpi,jpj) :: zdepinv ! depth of temperature inversion + REAL(wp), DIMENSION(jpi,jpj) :: zrho0_3 ! MLD rho = rho(surf) = 0.03 + REAL(wp), DIMENSION(jpi,jpj) :: zrho0_1 ! MLD rho = rho(surf) = 0.01 + REAL(wp), DIMENSION(jpi,jpj) :: zmaxdzT ! max of dT/dz + REAL(wp), DIMENSION(jpi,jpj) :: zdelr ! delta rho equivalent to deltaT = 0.2 !!---------------------------------------------------------------------- IF( ln_timing ) CALL timing_start('dia_hth') @@ -293,11 +293,11 @@ CONTAINS SUBROUTINE dia_hth_dep( Kmm, ptem, pdept ) ! INTEGER , INTENT(in) :: Kmm ! ocean time level index - REAL(dp), INTENT(in) :: ptem - REAL(dp), DIMENSION(jpi,jpj), INTENT(out) :: pdept + REAL(wp), INTENT(in) :: ptem + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pdept ! INTEGER :: ji, jj, jk, iid - REAL(dp) :: zztmp, zzdep + REAL(wp) :: zztmp, zzdep INTEGER, DIMENSION(jpi,jpj) :: iktem ! --------------------------------------- ! @@ -334,12 +334,12 @@ CONTAINS SUBROUTINE dia_hth_htc( Kmm, pdep, pt, phtc ) ! INTEGER , INTENT(in) :: Kmm ! ocean time level index - REAL(dp), INTENT(in) :: pdep ! depth over the heat content + REAL(wp), INTENT(in) :: pdep ! depth over the heat content REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pt - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: phtc + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phtc ! INTEGER :: ji, jj, jk, ik - REAL(dp), DIMENSION(jpi,jpj) :: zthick + REAL(wp), DIMENSION(jpi,jpj) :: zthick INTEGER , DIMENSION(jpi,jpj) :: ilevel diff --git a/src/OCE/DIA/diamlr.F90 b/src/OCE/DIA/diamlr.F90 index 9326fed5f7662a3fa46ee4081e6f3767d3347359..aa1a3f5ff23cc5db9233b7ce02d1176f26e02102 100644 --- a/src/OCE/DIA/diamlr.F90 +++ b/src/OCE/DIA/diamlr.F90 @@ -85,7 +85,7 @@ CONTAINS CHARACTER(LEN=32) :: clrepl INTEGER :: jl, jm, jn INTEGER :: itide ! Number of available tidal components - REAL(dp) :: ztide_phase ! Tidal-constituent phase at adatrj=0 + REAL(wp) :: ztide_phase ! Tidal-constituent phase at adatrj=0 CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: ctide_selected = 'n/a ' TYPE(tide_harmonic), DIMENSION(:), POINTER :: stideconst @@ -407,7 +407,7 @@ CONTAINS !! ** Purpose : update time used in multiple-linear-regression analysis !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: zadatrj2d + REAL(wp), DIMENSION(jpi,jpj) :: zadatrj2d !!---------------------------------------------------------------------- IF( ln_timing ) CALL timing_start('dia_mlr') @@ -425,4 +425,4 @@ CONTAINS END SUBROUTINE dia_mlr !!====================================================================== -END MODULE diamlr +END MODULE diamlr \ No newline at end of file diff --git a/src/OCE/DIA/dianam.F90 b/src/OCE/DIA/dianam.F90 index 8bbf009dcc878c5a1a697ed07e7bdf4eae260012..360b720b9b8e3d34e9cb08e15d6d1a64de5c8bf6 100644 --- a/src/OCE/DIA/dianam.F90 +++ b/src/OCE/DIA/dianam.F90 @@ -61,8 +61,7 @@ CONTAINS INTEGER :: iyyss, iddss, ihhss, immss ! number of seconds in 1 year, 1 day, 1 hour and 1 minute INTEGER :: iyymo ! number of months in 1 year REAL(dp) :: zsec1, zsec2 ! not used - REAL(wp) :: zjul! temporary scalars - REAL(dp) :: zdrun! temporary scalars + REAL(dp) :: zdrun, zjul ! temporary scalars !!---------------------------------------------------------------------- ! name for output frequency @@ -86,43 +85,43 @@ CONTAINS inbmo = -inbsec ! frequency in month IF( MOD( inbmo, iyymo ) == 0 ) THEN ! frequency in years inbyr = inbmo / iyymo - indg = INT(LOG10(REAL(inbyr,dp))) + 1 ! number of digits needed to write years frequency + indg = INT(LOG10(REAL(inbyr,wp))) + 1 ! number of digits needed to write years frequency WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbyr , 'y' ELSE ! frequency in month - indg = INT(LOG10(REAL(inbmo,dp))) + 1 ! number of digits needed to write months frequency + indg = INT(LOG10(REAL(inbmo,wp))) + 1 ! number of digits needed to write months frequency WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbmo, 'm' ENDIF ELSEIF( MOD( inbsec, iyyss ) == 0 ) THEN ! frequency in years inbyr = inbsec / iyyss - indg = INT(LOG10(REAL(inbyr ,dp))) + 1 ! number of digits needed to write years frequency + indg = INT(LOG10(REAL(inbyr ,wp))) + 1 ! number of digits needed to write years frequency WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbyr , 'y' ELSEIF( MOD( inbsec, iddss ) == 0 ) THEN ! frequency in days inbday = inbsec / iddss - indg = INT(LOG10(REAL(inbday,dp))) + 1 ! number of digits needed to write days frequency + indg = INT(LOG10(REAL(inbday,wp))) + 1 ! number of digits needed to write days frequency WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbday, 'd' IF( inbday == nmonth_len(nmonth) ) clave = '_1m' ELSEIF( MOD( inbsec, ihhss ) == 0 ) THEN ! frequency in hours inbhr = inbsec / ihhss - indg = INT(LOG10(REAL(inbhr ,dp))) + 1 ! number of digits needed to write hours frequency + indg = INT(LOG10(REAL(inbhr ,wp))) + 1 ! number of digits needed to write hours frequency WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbhr , 'h' ELSEIF( MOD( inbsec, immss ) == 0 ) THEN ! frequency in minutes inbmn = inbsec / immss - indg = INT(LOG10(REAL(inbmn ,dp))) + 1 ! number of digits needed to write minutes frequency + indg = INT(LOG10(REAL(inbmn ,wp))) + 1 ! number of digits needed to write minutes frequency WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbmn , 'mn' ELSE ! frequency in seconds - indg = INT(LOG10(REAL(inbsec,dp))) + 1 ! number of digits needed to write seconds frequency + indg = INT(LOG10(REAL(inbsec,wp))) + 1 ! number of digits needed to write seconds frequency WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbsec, 's' ENDIF ! date of the beginning and the end of the run - zdrun = rn_Dt / rday * REAL( nitend - nit000,dp ) ! length of the run in days + zdrun = rn_Dt / rday * REAL( nitend - nit000, wp ) ! length of the run in days zjul = fjulday - rn_Dt / rday - CALL ju2ymds(REAL(zjul,dp) , iyear1, imonth1, iday1, zsec1 ) ! year/month/day of the beginning of run - CALL ju2ymds( REAL(zjul,dp) + REAL(zdrun,dp), iyear2, imonth2, iday2, zsec2 ) ! year/month/day of the end of run + CALL ju2ymds( zjul , iyear1, imonth1, iday1, zsec1 ) ! year/month/day of the beginning of run + CALL ju2ymds( zjul + zdrun, iyear2, imonth2, iday2, zsec2 ) ! year/month/day of the end of run IF( iyear2 < 10000 ) THEN ; clfmt = "(i4.4,2i2.2)" ! format used to write the date - ELSE ; WRITE(clfmt, "('(i',i1,',2i2.2)')") INT(LOG10(REAL(iyear2,dp))) + 1 + ELSE ; WRITE(clfmt, "('(i',i1,',2i2.2)')") INT(LOG10(REAL(iyear2,wp))) + 1 ENDIF WRITE(cldate1, clfmt) iyear1, imonth1, iday1 ! date of the beginning of run @@ -134,4 +133,4 @@ CONTAINS END SUBROUTINE dia_nam !!====================================================================== -END MODULE dianam +END MODULE dianam \ No newline at end of file diff --git a/src/OCE/DIA/diaptr.F90 b/src/OCE/DIA/diaptr.F90 index 80f07bd82379334c8445738f1fd7bb393860c3bb..2f3caf8762222b2da19a3003f7ce0b0fce4e9a0b 100644 --- a/src/OCE/DIA/diaptr.F90 +++ b/src/OCE/DIA/diaptr.F90 @@ -43,20 +43,20 @@ MODULE diaptr PUBLIC dia_ptr ! call in step module PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: pvtr_int, pzon_int !: Other zonal integrals + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: pvtr_int, pzon_int !: Other zonal integrals LOGICAL, PUBLIC :: l_diaptr !: tracers trend flag INTEGER, PARAMETER :: jp_msk = 3 INTEGER, PARAMETER :: jp_vtr = 4 - REAL(dp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup - REAL(dp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rho0 x Cp) - REAL(dp) :: rc_ggram = 1.e-9_wp ! conversion from g to Gg (further x rho0) + REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup + REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rho0 x Cp) + REAL(wp) :: rc_ggram = 1.e-9_wp ! conversion from g to Gg (further x rho0) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) LOGICAL :: ll_init = .TRUE. !: tracers trend flag @@ -77,7 +77,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: kt ! ocean time-step index INTEGER , INTENT(in) :: Kmm ! time level index - REAL(dp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('dia_ptr') @@ -109,18 +109,18 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: kt ! ocean time-step index INTEGER , INTENT(in) :: Kmm ! time level index - REAL(dp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport ! INTEGER :: ji, jj, jk, jn ! dummy loop indices REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace - REAL(dp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace + REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace ! !overturning calculation - REAL(dp), DIMENSION(:,:,: ), ALLOCATABLE :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse - REAL(dp), DIMENSION(:,:,: ), ALLOCATABLE :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function + REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse + REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function - REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: z4d1, z4d2 - REAL(dp), DIMENSION(:,:,: ), ALLOCATABLE :: z3dtr + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: z4d1, z4d2 + REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: z3dtr !!---------------------------------------------------------------------- ! ALLOCATE( z3dtr(jpi,jpj,nbasin) ) @@ -347,12 +347,12 @@ CONTAINS !! pzon_int - terms for i mean temperature/salinity !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: Kmm ! time level index - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zmask ! 3D workspace - REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: zts ! 4D workspace - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: sjk, v_msf ! Zonal sum: i-k surface area, j-effective transport - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zt_jk, zs_jk ! Zonal sum: i-k surface area * (T, S) - REAL(dp) :: zsfc, zvfc ! i-k surface area + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmask ! 3D workspace + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zts ! 4D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: sjk, v_msf ! Zonal sum: i-k surface area, j-effective transport + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt_jk, zs_jk ! Zonal sum: i-k surface area * (T, S) + REAL(wp) :: zsfc, zvfc ! i-k surface area INTEGER :: ji, jj, jk, jn ! dummy loop indices !!---------------------------------------------------------------------- @@ -458,7 +458,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: inum, jn ! local integers !! - REAL(dp), DIMENSION(jpi,jpj) :: zmsk + REAL(wp), DIMENSION(jpi,jpj) :: zmsk !!---------------------------------------------------------------------- ! l_diaptr is defined with iom_use @@ -537,8 +537,8 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: ktra ! tracer index CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' - REAL(dp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! 3D input array of advection/diffusion - REAL(dp), DIMENSION(A1Dj(nn_hls),nbasin) :: zsj ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! 3D input array of advection/diffusion + REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin) :: zsj ! INTEGER :: jn ! DO jn = 1, nbasin @@ -573,13 +573,13 @@ CONTAINS !! !! ** Action : phstr !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpj,nbasin) , INTENT(inout) :: phstr ! - REAL(dp), DIMENSION(A1Dj(nn_hls),nbasin), INTENT(in) :: pva ! + REAL(wp), DIMENSION(jpj,nbasin) , INTENT(inout) :: phstr ! + REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin), INTENT(in) :: pva ! INTEGER :: jj #if ! defined key_mpi_off INTEGER, DIMENSION(1) :: ish1d INTEGER, DIMENSION(2) :: ish2d - REAL(dp), DIMENSION(jpj*nbasin) :: zwork + REAL(wp), DIMENSION(jpj*nbasin) :: zwork #endif DO jj = ntsj, ntej @@ -609,13 +609,13 @@ CONTAINS !! !! ** Action : phstr !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpj,jpk,nbasin) , INTENT(inout) :: phstr ! - REAL(dp), DIMENSION(A1Dj(nn_hls),jpk,nbasin), INTENT(in) :: pva ! + REAL(wp), DIMENSION(jpj,jpk,nbasin) , INTENT(inout) :: phstr ! + REAL(wp), DIMENSION(A1Dj(nn_hls),jpk,nbasin), INTENT(in) :: pva ! INTEGER :: jj, jk #if ! defined key_mpi_off INTEGER, DIMENSION(1) :: ish1d INTEGER, DIMENSION(3) :: ish3d - REAL(dp), DIMENSION(jpj*jpk*nbasin) :: zwork + REAL(wp), DIMENSION(jpj*jpk*nbasin) :: zwork #endif DO jk = 1, jpk @@ -674,11 +674,11 @@ CONTAINS !! !! ** Action : - p_fval: i-k-mean poleward flux of pvflx !!---------------------------------------------------------------------- - REAL(dp), INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pvflx ! mask flux array at V-point - REAL(dp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask + REAL(wp), INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pvflx ! mask flux array at V-point + REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask ! INTEGER :: ji, jj, jk ! dummy loop arguments - REAL(dp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value + REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value !!-------------------------------------------------------------------- ! p_fval(:) = 0._wp @@ -703,7 +703,7 @@ CONTAINS REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask ! INTEGER :: ji,jj ! dummy loop arguments - REAL(dp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value + REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value !!-------------------------------------------------------------------- ! p_fval(:) = 0._wp @@ -726,7 +726,7 @@ CONTAINS ! INTEGER :: ji,jj,jc ! dummy loop arguments INTEGER :: ijpj ! ??? - REAL(dp), DIMENSION(jpi,jpj) :: p_fval ! function value + REAL(wp), DIMENSION(jpi,jpj) :: p_fval ! function value !!-------------------------------------------------------------------- ! ijpj = jpj ! ??? @@ -753,11 +753,11 @@ CONTAINS !!---------------------------------------------------------------------- !! IMPLICIT none - REAL(dp) , INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pta ! mask flux array at V-point - REAL(dp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask + REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pta ! mask flux array at V-point + REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask !! INTEGER :: ji, jj, jk ! dummy loop arguments - REAL(dp), DIMENSION(A1Dj(nn_hls),jpk) :: p_fval ! return function value + REAL(wp), DIMENSION(A1Dj(nn_hls),jpk) :: p_fval ! return function value !!-------------------------------------------------------------------- ! p_fval(:,:) = 0._wp diff --git a/src/OCE/DIA/diawri.F90 b/src/OCE/DIA/diawri.F90 index ab9a44fb5d3d069b15de81f18388807cc27cae61..89c9e8860f52252a9f2175be98b9fa413d26b952 100644 --- a/src/OCE/DIA/diawri.F90 +++ b/src/OCE/DIA/diawri.F90 @@ -119,11 +119,11 @@ CONTAINS !! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ikbot ! local integer - REAL(dp):: zztmp , zztmpx ! local scalar - REAL(dp):: zztmp2, zztmpy ! - - - REAL(dp):: ze3 - REAL(dp), DIMENSION(A2D( 0)) :: z2d ! 2D workspace - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: z3d ! 3D workspace + 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') @@ -580,7 +580,7 @@ CONTAINS 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 @@ -1126,8 +1126,8 @@ CONTAINS !! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: inum - REAL(dp), DIMENSION(jpi,jpj) :: z2d - REAL(dp), DIMENSION(jpi,jpj,jpk) :: z3d + REAL(wp), DIMENSION(jpi,jpj) :: z2d + REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d !!---------------------------------------------------------------------- ! IF(lwp) THEN @@ -1160,18 +1160,18 @@ CONTAINS 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,dp) ) - CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,dp) ) - CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,dp), ktype = jp_i1 ) + 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,dp) ) + 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,dp) ) - CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,dp) ) - CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,dp), ktype = jp_i1 ) + 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 ! diff --git a/src/OCE/DIU/diu_bulk.F90 b/src/OCE/DIU/diu_bulk.F90 index 2fd50fc7a4b39b063819fdc253826c8e345e09df..b578c50a6dc7e52f26e3e530cfa789bef03fbdbf 100644 --- a/src/OCE/DIU/diu_bulk.F90 +++ b/src/OCE/DIU/diu_bulk.F90 @@ -30,8 +30,8 @@ MODULE diu_bulk REAL(wp), PRIVATE, PARAMETER :: pp_min_fvel = 1.e-10_wp ! Key variables - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_dsst ! Delta SST - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_solfrac ! Fraction of + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_dsst ! Delta SST + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_solfrac ! Fraction of ! ! absorbed radiation PUBLIC diurnal_sst_bulk_init, diurnal_sst_takaya_step @@ -93,11 +93,11 @@ CONTAINS !! temperature, Takaya et al, JGR, 2010 !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: kt ! time step - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: psolflux ! solar flux (Watts) - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: pqflux ! heat (non-solar) flux (Watts) - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: ptauflux ! wind stress (kg/ m s^2) + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: psolflux ! solar flux (Watts) + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: pqflux ! heat (non-solar) flux (Watts) + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: ptauflux ! wind stress (kg/ m s^2) REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: prho ! water density (kg/m^3) - REAL(dp) , INTENT(in) :: p_rdt ! time-step + REAL(wp) , INTENT(in) :: p_rdt ! time-step REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pla ! Langmuir number REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pthick ! warm layer thickness (m) REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pcoolthick ! cool skin thickness (m) @@ -107,10 +107,10 @@ CONTAINS ! INTEGER :: ji,jj LOGICAL :: ll_calcfrac - REAL(dp), DIMENSION(jpi,jpj) :: z_fvel ! friction velocity - REAL(dp), DIMENSION(jpi,jpj) :: zthick, zcoolthick, zmu, zla - REAL(dp), DIMENSION(jpi,jpj) :: z_abflux ! absorbed flux - REAL(dp), DIMENSION(jpi,jpj) :: z_fla ! Langmuir function value + REAL(wp), DIMENSION(jpi,jpj) :: z_fvel ! friction velocity + REAL(wp), DIMENSION(jpi,jpj) :: zthick, zcoolthick, zmu, zla + REAL(wp), DIMENSION(jpi,jpj) :: z_abflux ! absorbed flux + REAL(wp), DIMENSION(jpi,jpj) :: z_fla ! Langmuir function value !!---------------------------------------------------------------------- ! Set optional arguments to their defaults @@ -176,23 +176,23 @@ CONTAINS IMPLICIT NONE ! Function definition - REAL(dp), DIMENSION(jpi,jpj) :: t_imp + REAL(wp), DIMENSION(jpi,jpj) :: t_imp ! Dummy variables - REAL(dp), DIMENSION(jpi,jpj), INTENT(IN) :: p_dsst ! Delta SST - REAL(dp), INTENT(IN) :: p_rdt ! Time-step - REAL(dp), DIMENSION(jpi,jpj), INTENT(IN) :: p_abflux ! Heat forcing - REAL(dp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fvel ! Friction velocity - REAL(dp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fla ! Langmuir number - REAL(dp), DIMENSION(jpi,jpj), INTENT(IN) :: pmu ! Structure parameter - REAL(dp), DIMENSION(jpi,jpj), INTENT(IN) :: pthick ! Layer thickness + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_dsst ! Delta SST + REAL(wp), INTENT(IN) :: p_rdt ! Time-step + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_abflux ! Heat forcing + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fvel ! Friction velocity + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fla ! Langmuir number + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pmu ! Structure parameter + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pthick ! Layer thickness REAL(dp), DIMENSION(jpi,jpj), INTENT(IN) :: prho ! Water density ! Local variables - REAL(dp) :: z_olength ! Obukhov length - REAL(dp) :: z_sigma, z_sigma2 - REAL(dp) :: z_term1, z_term2 - REAL(dp) :: z_stabfunc ! stability function value - REAL(dp) :: z_fvel + REAL(wp) :: z_olength ! Obukhov length + REAL(wp) :: z_sigma, z_sigma2 + REAL(wp) :: z_term1, z_term2 + REAL(wp) :: z_stabfunc ! stability function value + REAL(wp) :: z_fvel CHARACTER(200) :: warn_string diff --git a/src/OCE/DIU/diu_coolskin.F90 b/src/OCE/DIU/diu_coolskin.F90 index 474c4af63425cb688b046215101175ef524600d3..e0d30c8a52ebebc2ded2825b995bb7dc3abc42d6 100644 --- a/src/OCE/DIU/diu_coolskin.F90 +++ b/src/OCE/DIU/diu_coolskin.F90 @@ -35,8 +35,8 @@ MODULE diu_coolskin REAL(wp), PRIVATE, PARAMETER :: pp_cda = 1.45e-3_wp ! assumed air-sea drag coefficient for calculating wind speed ! Key variables - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_csdsst ! Cool skin delta SST - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_csthick ! Cool skin thickness + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_csdsst ! Cool skin delta SST + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_csthick ! Cool skin thickness PUBLIC diurnal_sst_coolskin_step, diurnal_sst_coolskin_init !! * Substitutions @@ -77,19 +77,19 @@ MODULE diu_coolskin !! ** Reference : !!---------------------------------------------------------------------- ! Dummy variables - REAL(dp), INTENT(IN), DIMENSION(jpi,jpj) :: psqflux ! Heat (non-solar)(Watts) - REAL(dp), INTENT(IN), DIMENSION(jpi,jpj) :: pstauflux ! Wind stress (kg/ m s^2) + REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psqflux ! Heat (non-solar)(Watts) + REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: pstauflux ! Wind stress (kg/ m s^2) REAL(dp), INTENT(IN), DIMENSION(jpi,jpj) :: psrho ! Water density (kg/m^3) - REAL(dp), INTENT(IN) :: pDt ! Time-step + REAL(wp), INTENT(IN) :: pDt ! Time-step ! Local variables - REAL(dp), DIMENSION(jpi,jpj) :: z_fv ! Friction velocity - REAL(dp), DIMENSION(jpi,jpj) :: z_gamma ! Dimensionless function of wind speed - REAL(dp), DIMENSION(jpi,jpj) :: z_lamda ! Sauders (dimensionless) proportionality constant - REAL(dp), DIMENSION(jpi,jpj) :: z_wspd ! Wind speed (m/s) - REAL(dp) :: z_ztx ! Temporary u wind stress - REAL(dp) :: z_zty ! Temporary v wind stress - REAL(dp) :: z_zmod ! Temporary total wind stress + REAL(wp), DIMENSION(jpi,jpj) :: z_fv ! Friction velocity + REAL(wp), DIMENSION(jpi,jpj) :: z_gamma ! Dimensionless function of wind speed + REAL(wp), DIMENSION(jpi,jpj) :: z_lamda ! Sauders (dimensionless) proportionality constant + REAL(wp), DIMENSION(jpi,jpj) :: z_wspd ! Wind speed (m/s) + REAL(wp) :: z_ztx ! Temporary u wind stress + REAL(wp) :: z_zty ! Temporary v wind stress + REAL(wp) :: z_zmod ! Temporary total wind stress INTEGER :: ji,jj !!---------------------------------------------------------------------- diff --git a/src/OCE/DIU/solfrac_mod.F90 b/src/OCE/DIU/solfrac_mod.F90 index 09b8f776b6ae93a27da1c8809b3bb7e4eef7cf08..3fb80cdccaf231a57511a76a06de544d21e08864 100644 --- a/src/OCE/DIU/solfrac_mod.F90 +++ b/src/OCE/DIU/solfrac_mod.F90 @@ -39,7 +39,7 @@ CONTAINS !!---------------------------------------------------------------------- ! Dummy variabes - REAL(dp), INTENT(IN) :: ptop, pbottom ! Top and bottom of layer + REAL(wp), INTENT(IN) :: ptop, pbottom ! Top and bottom of layer ! local variables INTEGER :: jt diff --git a/src/OCE/DIU/step_diu.F90 b/src/OCE/DIU/step_diu.F90 index 032fa2b51eddf4215da3557cc7befeb4cede9055..afc6c589fb4f729c98cf9b0eb5705ffb7408a391 100644 --- a/src/OCE/DIU/step_diu.F90 +++ b/src/OCE/DIU/step_diu.F90 @@ -46,7 +46,7 @@ MODULE step_diu !!---------------------------------------------------------------------- INTEGER :: jk ! dummy loop indices INTEGER :: indic ! error indicator if < 0 - REAL(dp), DIMENSION(jpi,jpj) :: z_fvel_bkginc, z_hflux_bkginc + REAL(wp), DIMENSION(jpi,jpj) :: z_fvel_bkginc, z_hflux_bkginc INTEGER :: Nbb, Nnn, Naa, Nrhs ! local definitions as placeholders for now !! --------------------------------------------------------------------- diff --git a/src/OCE/DOM/closea.F90 b/src/OCE/DOM/closea.F90 index 5b803dfc3528cc4c9c419b0259f04e483eedefc0..58c4518298dcd5db053b55f1c1d08b66600e408c 100644 --- a/src/OCE/DOM/closea.F90 +++ b/src/OCE/DOM/closea.F90 @@ -173,10 +173,10 @@ CONTAINS !! ** Action : update (p_)mskrnf (set 1 at closed sea outflow) !!---------------------------------------------------------------------- !! subroutine parameter - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: p_rnfmsk ! river runoff mask (rnfmsk array) + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: p_rnfmsk ! river runoff mask (rnfmsk array) !! !! local variables - REAL(dp), DIMENSION(jpi,jpj) :: zmsk + REAL(wp), DIMENSION(jpi,jpj) :: zmsk !!---------------------------------------------------------------------- ! ! zmsk > 0 where cs river mouth defined (case rnf and emp) @@ -232,7 +232,7 @@ CONTAINS ! ! local variables INTEGER :: ics ! netcdf id - REAL(dp), DIMENSION(jpi,jpj) :: zdta ! netcdf data + REAL(wp), DIMENSION(jpi,jpj) :: zdta ! netcdf data !!---------------------------------------------------------------------- ! CALL iom_open ( cd_file, ics ) diff --git a/src/OCE/DOM/daymod.F90 b/src/OCE/DOM/daymod.F90 index ca4ece9cafa9312376d72ce21e0311be8263ef79..39e2db30aac49b48c8b8235742d8451e0d909f5e 100644 --- a/src/OCE/DOM/daymod.F90 +++ b/src/OCE/DOM/daymod.F90 @@ -94,7 +94,7 @@ CONTAINS isecrst = ( nhour * NINT(rhhmm) + nminute ) * NINT(rmmss) CALL ymds2ju( nyear, nmonth, nday, REAL(isecrst,dp), fjulday ) - IF( ABS(fjulday - REAL(NINT(fjulday),dp)) < 0.1 / rday ) fjulday = REAL(NINT(fjulday),dp) ! avoid truncation error + IF( ABS(fjulday - REAL(NINT(fjulday),wp)) < 0.1 / rday ) fjulday = REAL(NINT(fjulday),wp) ! avoid truncation error IF( nhour*NINT(rhhmm*rmmss) + nminute*NINT(rmmss) - ndt05 .LT. 0 ) fjulday = fjulday+1. ! move back to the day at nit000 (and not at nit000 - 1) nsec1jan000 = 0 @@ -116,6 +116,7 @@ CONTAINS !compute number of days between last Monday and today CALL ymds2ju( 1900, 01, 01, 0.0_dp, zjul ) ! compute julian day value of 01.01.1900 (our reference that was a Monday) + inbday = FLOOR(fjulday - zjul) ! compute nb day between 01.01.1900 and start of current day imonday = MOD(inbday, 7) ! compute nb day between last monday and current day IF (imonday .LT. 0) imonday = imonday + 7 ! Avoid negative values for dates before 01.01.1900 @@ -233,8 +234,8 @@ CONTAINS nsec_day = nsec_day + ndt adatrj = adatrj + rn_Dt / rday fjulday = fjulday + rn_Dt / rday - IF( ABS(fjulday - REAL(NINT(fjulday),dp)) < zprec ) fjulday = REAL(NINT(fjulday),dp) ! avoid truncation error - IF( ABS(adatrj - REAL(NINT(adatrj ),dp)) < zprec ) adatrj = REAL(NINT(adatrj ),dp) ! avoid truncation error + IF( ABS(fjulday - REAL(NINT(fjulday),wp)) < zprec ) fjulday = REAL(NINT(fjulday),wp) ! avoid truncation error + IF( ABS(adatrj - REAL(NINT(adatrj ),wp)) < zprec ) adatrj = REAL(NINT(adatrj ),wp) ! avoid truncation error IF( nsec_day > nsecd ) THEN ! New day ! @@ -342,7 +343,7 @@ CONTAINS CALL iom_get( numror, 'ntime' , ktime ) nn_time0 = NINT(ktime) ! calculate start time in hours and minutes - zdayfrac = adatrj - REAL(INT(adatrj),dp) + zdayfrac = adatrj - REAL(INT(adatrj), wp) ksecs = NINT(zdayfrac * rday) ! Nearest second to catch rounding errors in adatrj ihour = ksecs / NINT( rhhmm*rmmss ) iminute = ksecs / NINT(rmmss) - ihour*NINT(rhhmm) @@ -362,7 +363,7 @@ CONTAINS adatrj = adatrj + 1. ENDIF nn_time0 = nhour * 100 + nminute - adatrj = REAL(INT(adatrj),dp) ! adatrj set to integer as nn_time0 updated + adatrj = REAL(INT(adatrj), wp) ! adatrj set to integer as nn_time0 updated ELSE ! parameters corresponding to nit000 - 1 (as we start the step loop with a call to day) ndastp = ndate0 ! ndate0 read in the namelist in dom_nam @@ -370,7 +371,7 @@ CONTAINS nminute = ( nn_time0 - nhour * 100 ) isecond = ( nhour * NINT(rhhmm) + nminute ) * NINT(rmmss) IF( isecond - ndt05 .lt. 0 ) ndastp = ndastp - 1 ! Start hour is specified in the namelist (default 0) - adatrj = ( REAL( nit000-1,dp ) * rn_Dt ) / rday + adatrj = ( REAL( nit000-1, wp ) * rn_Dt ) / rday ! note this is wrong if time step has changed during run ENDIF ELSE @@ -380,9 +381,9 @@ CONTAINS nminute = ( nn_time0 - nhour * 100 ) isecond = ( nhour * NINT(rhhmm) + nminute ) * NINT(rmmss) IF( isecond - ndt05 .LT. 0 ) ndastp = ndastp - 1 ! Start hour is specified in the namelist (default 0) - adatrj = ( REAL( nit000-1,dp ) * rn_Dt ) / rday + adatrj = ( REAL( nit000-1, wp ) * rn_Dt ) / rday ENDIF - IF( ABS(adatrj - REAL(NINT(adatrj),dp)) < 0.1 / rday ) adatrj = REAL(NINT(adatrj),dp) ! avoid truncation error + IF( ABS(adatrj - REAL(NINT(adatrj),wp)) < 0.1 / rday ) adatrj = REAL(NINT(adatrj),wp) ! avoid truncation error ! IF(lwp) THEN WRITE(numout,*) ' *** Info used values : ' @@ -400,11 +401,11 @@ CONTAINS IF(lwp) WRITE(numout,*) '~~~~~~~' ENDIF ! calendar control - CALL iom_rstput( kt, nitrst, numrow, 'kt' , REAL( kt ,dp) ) ! time-step - CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp,dp) ) ! date + CALL iom_rstput( kt, nitrst, numrow, 'kt' , REAL( kt , wp) ) ! time-step + CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp) ) ! date CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj ) ! number of elapsed days since ! ! the begining of the run [s] - CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0,dp) ) ! time + CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp) ) ! time ENDIF ! END SUBROUTINE day_rst diff --git a/src/OCE/DOM/depth_e3.F90 b/src/OCE/DOM/depth_e3.F90 index e50d45cbdc012b3f30acce44b47cd368909b962b..67c495002866c3761afe9ff6fc01a64a3876682f 100644 --- a/src/OCE/DOM/depth_e3.F90 +++ b/src/OCE/DOM/depth_e3.F90 @@ -58,8 +58,8 @@ CONTAINS !! !! ** Action : - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:), INTENT(in ) :: pdept_1d, pdepw_1d ! depths [m] - REAL(dp), DIMENSION(:), INTENT( out) :: pe3t_1d , pe3w_1d ! e3.=dk[depth] [m] + REAL(wp), DIMENSION(:), INTENT(in ) :: pdept_1d, pdepw_1d ! depths [m] + REAL(wp), DIMENSION(:), INTENT( out) :: pe3t_1d , pe3w_1d ! e3.=dk[depth] [m] ! INTEGER :: jk ! dummy loop indices !!---------------------------------------------------------------------- @@ -93,7 +93,7 @@ CONTAINS !! ** Action : - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) !!---------------------------------------------------------------------- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdept_3d, pdepw_3d ! depth [m] - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pe3t_3d , pe3w_3d ! e3.=dk[depth] [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3t_3d , pe3w_3d ! e3.=dk[depth] [m] ! INTEGER :: jk ! dummy loop indices !!---------------------------------------------------------------------- @@ -117,8 +117,8 @@ CONTAINS !! !! ** Action : - pe3t_1d, pe3w_1d : scale factor of t- and w-point (m) !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:), INTENT(in ) :: pe3t_1d , pe3w_1d ! vert. scale factors [m] - REAL(dp), DIMENSION(:), INTENT( out) :: pdept_1d, pdepw_1d ! depth = SUM( e3 ) [m] + REAL(wp), DIMENSION(:), INTENT(in ) :: pe3t_1d , pe3w_1d ! vert. scale factors [m] + REAL(wp), DIMENSION(:), INTENT( out) :: pdept_1d, pdepw_1d ! depth = SUM( e3 ) [m] ! INTEGER :: jk ! dummy loop indices !!---------------------------------------------------------------------- @@ -143,8 +143,9 @@ CONTAINS !! !! ** Action : - pe3t_1d, pe3w_1d : scale factor of t- and w-point (m) !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pe3t_3d , pe3w_3d ! vert. scale factors [m] - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pdept_3d, pdepw_3d ! depth = SUM( e3 ) [m] + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pe3w_3d! vert. scale factors [m] + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pe3t_3d! vert. scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdept_3d, pdepw_3d ! depth = SUM( e3 ) [m] ! INTEGER :: jk ! dummy loop indices !!---------------------------------------------------------------------- diff --git a/src/OCE/DOM/dom_oce.F90 b/src/OCE/DOM/dom_oce.F90 index 469576240a6b182cce9d8120c357514b493bcfe8..57b4f237d287efd78e21a1da72f971c4ac89465e 100644 --- a/src/OCE/DOM/dom_oce.F90 +++ b/src/OCE/DOM/dom_oce.F90 @@ -33,8 +33,8 @@ MODULE dom_oce ! !!* Namelist namdom : time & space domain * LOGICAL , PUBLIC :: ln_linssh !: =T linear free surface ==>> model level are fixed in time LOGICAL , PUBLIC :: ln_meshmask !: =T create a mesh-mask file (mesh_mask.nc) - REAL(dp), PUBLIC :: rn_Dt !: time step for the dynamics and tracer - REAL(dp), PUBLIC :: rn_atfp !: asselin time filter parameter + REAL(wp), PUBLIC :: rn_Dt !: time step for the dynamics and tracer + REAL(wp), PUBLIC :: rn_atfp !: asselin time filter parameter LOGICAL , PUBLIC :: ln_1st_euler !: =T start with forward time step or not (=F) LOGICAL , PUBLIC :: ln_crs !: Apply grid coarsening to dynamical model output or online passive tracers LOGICAL , PUBLIC :: ln_c1d !: =T single column domain (1x1 pt) @@ -51,13 +51,13 @@ MODULE dom_oce LOGICAL, PUBLIC :: ln_bt_auto !: Set number of barotropic iterations automatically INTEGER, PUBLIC :: nn_bt_flt !: Filter choice INTEGER, PUBLIC :: nn_e !: Number of barotropic iterations during one baroclinic step (rn_Dt) - REAL(dp), PUBLIC :: rn_bt_cmax !: Maximum allowed courant number (used if ln_bt_auto=T) - REAL(dp), PUBLIC :: rn_bt_alpha !: Time stepping diffusion parameter + REAL(wp), PUBLIC :: rn_bt_cmax !: Maximum allowed courant number (used if ln_bt_auto=T) + REAL(wp), PUBLIC :: rn_bt_alpha !: Time stepping diffusion parameter ! !!! associated variables LOGICAL , PUBLIC :: l_1st_euler !: Euler 1st time-step flag (=T if ln_restart=F or ln_1st_euler=T) - REAL(dp), PUBLIC :: rDt, r1_Dt !: Current model timestep and reciprocal + REAL(wp), PUBLIC :: rDt, r1_Dt !: Current model timestep and reciprocal !: rDt = 2 * rn_Dt if leapfrog and l_1st_euler = F !: = rn_Dt if leapfrog and l_1st_euler = T !: = rn_Dt if RK3 @@ -98,19 +98,23 @@ MODULE dom_oce !!---------------------------------------------------------------------- !! horizontal curvilinear coordinate and scale factors !! --------------------------------------------------------------------- - REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: glamt , glamu, glamv , glamf !: longitude at t, u, v, f-points [degree] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: gphit , gphiu, gphiv , gphif !: latitude at t, u, v, f-points [degree] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1t , e2t , r1_e1t, r1_e2t !: t-point horizontal scale factors [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1u , e2u , r1_e1u, r1_e2u !: horizontal scale factors at u-point [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1v , e2v , r1_e1v, r1_e2v !: horizontal scale factors at v-point [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1f , e2f , r1_e1f, r1_e2f !: horizontal scale factors at f-point [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: glamt , glamu, glamv , glamf !: longitude at t, u, v, f-points [degree] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: gphit , gphiu, gphiv , gphif !: latitude at t, u, v, f-points [degree] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: r1_e1t, r1_e2t!: t-point horizontal scale factors [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1t, e2t!: t-point horizontal scale factors [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e2u, r1_e1u, r1_e2u!: horizontal scale factors at u-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1u!: horizontal scale factors at u-point [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1v, r1_e1v, r1_e2v!: horizontal scale factors at v-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e2v!: horizontal scale factors at v-point [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: r1_e1f, r1_e2f!: horizontal scale factors at f-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1f, e2f!: horizontal scale factors at f-point [m] ! REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2t , r1_e1e2t !: associated metrics at t-point - REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u !: associated metrics at u-point - REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v !: associated metrics at v-point - REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u !: associated metrics at u-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v !: associated metrics at v-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point ! - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ff_f , ff_t !: Coriolis factor at f- & t-points [1/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ff_f , ff_t !: Coriolis factor at f- & t-points [1/s] !!---------------------------------------------------------------------- !! vertical coordinate and scale factors @@ -131,12 +135,12 @@ MODULE dom_oce LOGICAL, PUBLIC :: ln_isfcav !: presence of ISF ! ! reference scale factors REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_0 !: t- vert. scale factor [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3u_0 !: u- vert. scale factor [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3v_0 !: v- vert. scale factor [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f_0 !: f- vert. scale factor [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3w_0 !: w- vert. scale factor [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3uw_0 !: uw-vert. scale factor [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_0 !: vw-vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3u_0 !: u- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3v_0 !: v- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f_0 !: f- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3w_0 !: w- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3uw_0 !: uw-vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_0 !: vw-vert. scale factor [m] ! ! time-dependent scale factors (domvvl) #if defined key_qco || defined key_linssh @@ -145,14 +149,16 @@ MODULE dom_oce REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f !: F-point vert. scale factor [m] #endif ! ! time-dependent ratio ssh / h_0 (domqco) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r3t, r3u, r3v !: time-dependent ratio at t-, u- and v-point [-] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3f !: mid-time-level ratio at f-point [-] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3t_f, r3u_f, r3v_f !: now time-filtered ratio at t-, u- and v-point [-] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r3u, r3v!: time-dependent ratio at t-, u- and v-point [-] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r3t!: time-dependent ratio at t-, u- and v-point [-] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3f !: mid-time-level ratio at f-point [-] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3u_f, r3v_f!: now time-filtered ratio at t-, u- and v-point [-] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3t_f!: now time-filtered ratio at t-, u- and v-point [-] ! ! reference depths of cells - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m] ! ! time-dependent depths of cells (domvvl) #if defined key_qco || defined key_linssh @@ -162,9 +168,9 @@ MODULE dom_oce #endif ! ! reference heights of ocean water column and its inverse REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0, r1_ht_0 !: t-depth [m] and [1/m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0, r1_hu_0 !: u-depth [m] and [1/m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0, r1_hv_0 !: v-depth [m] and [1/m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hf_0, r1_hf_0 !: f-depth [m] and [1/m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0, r1_hu_0 !: u-depth [m] and [1/m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0, r1_hv_0 !: v-depth [m] and [1/m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hf_0, r1_hf_0 !: f-depth [m] and [1/m] ! ! time-dependent heights of ocean water column (domvvl) #if defined key_qco || defined key_linssh @@ -178,10 +184,10 @@ MODULE dom_oce !! 1D reference vertical coordinate !! =-----------------====------ - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gdept_1d, gdepw_1d !: reference depth of t- and w-points (m) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_1d , e3w_1d !: reference vertical scale factors at T- and W-pts (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gdept_1d, gdepw_1d !: reference depth of t- and w-points (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_1d , e3w_1d !: reference vertical scale factors at T- and W-pts (m) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfdep, bathy + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfdep, bathy !!---------------------------------------------------------------------- !! masks, top and bottom ocean point position @@ -191,16 +197,15 @@ MODULE dom_oce ! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbk_t, mbk_u, mbk_v !: bottom last wet T-, U-, and V-level !!gm INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt, mbku, mbkv, mbkf !: bottom last wet T-, U-, V- and F-level - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior (excluding halos+duplicated points) domain T-point mask + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior (excluding halos+duplicated points) domain T-point mask INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts - REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask!: land/ocean mask at T-, U-, V-, W- and F-pts - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask!: land/ocean mask at T-, U-, V-, W- and F-pts - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WU- and WV-pts - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: fe3mask !: land/ocean mask at F-pts - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_upd, umask_upd, vmask_upd !: land/ocean mask at F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WU- and WV-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: fe3mask !: land/ocean mask at F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_upd, umask_upd, vmask_upd !: land/ocean mask at F-pts !!---------------------------------------------------------------------- !! calendar variables @@ -218,7 +223,7 @@ MODULE dom_oce INTEGER , PUBLIC :: nsec_day !: seconds between 00h of the current day and half of the current time step REAL(dp), PUBLIC :: fjulday !: current julian day REAL(dp), PUBLIC :: fjulstartyear !: first day of the current year in julian days - REAL(dp), PUBLIC :: adatrj !: number of elapsed days since the begining of the whole simulation + REAL(wp), PUBLIC :: adatrj !: number of elapsed days since the begining of the whole simulation ! !: (cumulative duration of previous runs that may have used different time-step size) INTEGER , PUBLIC, DIMENSION( 0: 2) :: nyear_len !: length in days of the previous/current/next year INTEGER , PUBLIC, DIMENSION(-11:25) :: nmonth_len !: length in days of the months of the current year @@ -351,4 +356,4 @@ CONTAINS END FUNCTION dom_oce_alloc !!====================================================================== -END MODULE dom_oce +END MODULE dom_oce \ No newline at end of file diff --git a/src/OCE/DOM/domain.F90 b/src/OCE/DOM/domain.F90 index b5a682ecb01185a4ab5cf472243faa0c082b338c..b7a34306340caa59e00436be9d867381eb7b2f50 100644 --- a/src/OCE/DOM/domain.F90 +++ b/src/OCE/DOM/domain.F90 @@ -61,6 +61,7 @@ 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) @@ -88,10 +89,10 @@ CONTAINS ! INTEGER :: ji, jj, jk, jt ! dummy loop indices INTEGER :: iconf = 0 ! local integers - REAL(dp):: zrdt + 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(dp), DIMENSION(jpi,jpj) :: z1_hu_0, z1_hv_0 + REAL(wp), DIMENSION(jpi,jpj) :: z1_hu_0, z1_hv_0 !!---------------------------------------------------------------------- ! IF(lwp) THEN ! Ocean domain Parameters (control print) @@ -148,7 +149,7 @@ CONTAINS 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._dp) + 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(:,:) @@ -257,7 +258,7 @@ CONTAINS USE ioipsl !! INTEGER :: ios ! Local integer - REAL(dp):: zrdt + REAL(wp):: zrdt !!---------------------------------------------------------------------- ! NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list, & @@ -529,17 +530,17 @@ CONTAINS !!---------------------------------------------------------------------- LOGICAL, DIMENSION(jpi,jpj) :: llmsk INTEGER, DIMENSION(2) :: imil, imip, imi1, imi2, imal, imap, ima1, ima2 - REAL(dp) :: zglmin, zglmax, zgpmin, zgpmax, ze1min, ze1max, ze2min, ze2max + 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_minloc( 'domain', REAL(glamt(:,:),dp), llmsk, zglmin, imil ) + CALL mpp_minloc( 'domain', REAL(gphit(:,:),dp), 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 ) ! @@ -577,8 +578,8 @@ CONTAINS ! CHARACTER(len=7) :: catt ! 'T', 'F', '-' or 'UNKNOWN' INTEGER :: inum, iperio, iatt ! local integer - REAL(dp) :: zorca_res ! local scalars - REAL(dp) :: zperio ! - - + REAL(wp) :: zorca_res ! local scalars + REAL(wp) :: zperio ! - - INTEGER, DIMENSION(4) :: idvar, idimsz ! size of dimensions !!---------------------------------------------------------------------- ! @@ -667,7 +668,7 @@ CONTAINS INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: inum ! local units CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) - REAL(dp), DIMENSION(jpi,jpj) :: z2d ! workspace + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! workspace !!---------------------------------------------------------------------- ! IF(lwp) WRITE(numout,*) @@ -742,8 +743,8 @@ CONTAINS ! ! !== wet top and bottom level ==! (caution: multiplied by ssmask) ! - CALL iom_rstput( 0, 0, inum, 'top_level' , REAL( mikt,dp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points (ISF) - CALL iom_rstput( 0, 0, inum, 'bottom_level' , REAL( mbkt,dp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points + 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 ) diff --git a/src/OCE/DOM/domhgr.F90 b/src/OCE/DOM/domhgr.F90 index 52bb9da7b9b5e162b58ba8a02250d99fd8f37abb..2906154376ac724e86fe1206dc4a1803eae0c58a 100644 --- a/src/OCE/DOM/domhgr.F90 +++ b/src/OCE/DOM/domhgr.F90 @@ -112,11 +112,11 @@ CONTAINS & ie1e2u_v , e1e2u , e1e2v ) ! u- & v-surfaces (if gridsize reduction is used in strait(s)) ! ! make sure that periodicities are properly applied - CALL lbc_lnk( 'dom_hgr', glamt, 'T', 1._dp, glamu, 'U', 1._dp, glamv, 'V', 1._dp, glamf, 'F', 1._dp, & - & gphit, 'T', 1._dp, gphiu, 'U', 1._dp, gphiv, 'V', 1._dp, gphif, 'F', 1._dp, & - & e1t, 'T', 1._dp, e1u, 'U', 1._dp, e1v, 'V', 1._dp, e1f, 'F', 1._dp, & - & e2t, 'T', 1._dp, e2u, 'U', 1._dp, e2v, 'V', 1._dp, e2f, 'F', 1._dp, & - & kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries + CALL lbc_lnk( 'dom_hgr', glamt, 'T', 1._wp, glamu, 'U', 1._wp, glamv, 'V', 1._wp, glamf, 'F', 1._wp, & + & gphit, 'T', 1._wp, gphiu, 'U', 1._wp, gphiv, 'V', 1._wp, gphif, 'F', 1._wp, & + & e2u, 'U', 1._wp, e1v, 'V', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries + CALL lbc_lnk( 'dom_hgr', e1t, 'T', 1._dp, e2t, 'T', 1._dp, e1u, 'U', 1._dp, e2v, 'V', 1._dp, & + & e1f, 'F', 1._dp, e2f, 'F', 1._dp, kfillmode = jpfillcopy) ! ENDIF ! @@ -130,7 +130,7 @@ CONTAINS IF( ln_read_cfg ) THEN IF(lwp) WRITE(numout,*) ' Coriolis parameter have been read in ', TRIM( cn_domcfg ), ' file' ELSE - CALL lbc_lnk( 'dom_hgr', ff_t, 'T', 1._dp, ff_f, 'F', 1._dp, kfillmode = jpfillcopy ) ! do not put 0 if closed + CALL lbc_lnk( 'dom_hgr', ff_t, 'T', 1._wp, ff_f, 'F', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 if closed IF(lwp) WRITE(numout,*) ' Coriolis parameter have been set in usr_def_hgr routine' ENDIF ENDIF @@ -153,7 +153,7 @@ CONTAINS IF(lwp) WRITE(numout,*) ' u- & v-surfaces have been read in ', TRIM( cn_domcfg ), ' file:' IF(lwp) WRITE(numout,*) ' grid size reduction in strait(s) is used' ELSE - CALL lbc_lnk( 'dom_hgr', e1e2u, 'U', 1._dp, e1e2v, 'V', 1._dp, kfillmode = jpfillcopy ) ! do not put 0 if closed + CALL lbc_lnk( 'dom_hgr', e1e2u, 'U', 1._wp, e1e2v, 'V', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 if closed IF(lwp) WRITE(numout,*) ' u- & v-surfaces have been have been set in usr_def_hgr routine' ENDIF ENDIF @@ -180,14 +180,16 @@ CONTAINS !! ** Purpose : Read a mesh_mask file in NetCDF format using IOM !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:), INTENT(out) :: plamt, plamu, plamv, plamf ! longitude outputs - REAL(dp), DIMENSION(:,:), INTENT(out) :: pphit, pphiu, pphiv, pphif ! latitude outputs + REAL(wp), DIMENSION(:,:), INTENT(out) :: plamt, plamu, plamv, plamf ! longitude outputs + REAL(wp), DIMENSION(:,:), INTENT(out) :: pphit, pphiu, pphiv, pphif ! latitude outputs INTEGER , INTENT(out) :: kff ! =1 Coriolis parameter read here, =0 otherwise - REAL(dp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point (if found in file) - REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1v, pe1f ! i-scale factors - REAL(dp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2u, pe2v, pe2f ! j-scale factors + REAL(wp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point (if found in file) + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1v! i-scale factors + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1f! i-scale factors + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2u! j-scale factors + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2v, pe2f! j-scale factors INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces read here, =0 otherwise - REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if found in file) + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if found in file) ! INTEGER :: inum ! logical unit !!---------------------------------------------------------------------- diff --git a/src/OCE/DOM/dommsk.F90 b/src/OCE/DOM/dommsk.F90 index 9aaa38886a8398b67bccbb5448e31b89525e5a90..79964837c1184dafdedb7faede597a138e597948 100644 --- a/src/OCE/DOM/dommsk.F90 +++ b/src/OCE/DOM/dommsk.F90 @@ -40,7 +40,7 @@ MODULE dommsk PUBLIC dom_msk ! routine called by inidom.F90 ! !!* Namelist namlbc : lateral boundary condition * - REAL(dp) :: rn_shlat ! type of lateral boundary condition on velocity + REAL(wp) :: rn_shlat ! type of lateral boundary condition on velocity LOGICAL, PUBLIC :: ln_vorlat ! consistency of vorticity boundary condition ! with analytical eqs. @@ -186,7 +186,7 @@ CONTAINS ssfmask(ji,jj) = MAX( ssmask(ji,jj+1), ssmask(ji+1,jj+1), & & ssmask(ji,jj ), ssmask(ji+1,jj ) ) END_2D - CALL lbc_lnk( 'dommsk', ssfmask, 'F', 1.0_dp ) + CALL lbc_lnk( 'dommsk', ssfmask, 'F', 1.0_wp ) ENDIF fe3mask(:,:,:) = fmask(:,:,:) @@ -230,4 +230,4 @@ CONTAINS END SUBROUTINE dom_msk !!====================================================================== -END MODULE dommsk +END MODULE dommsk \ No newline at end of file diff --git a/src/OCE/DOM/domqco.F90 b/src/OCE/DOM/domqco.F90 index 8400be177d1b3943f8038b050c66c44312e80e28..2588bda517278e0ba3bb5b14550276c3382bdcfd 100644 --- a/src/OCE/DOM/domqco.F90 +++ b/src/OCE/DOM/domqco.F90 @@ -54,10 +54,10 @@ MODULE domqco ! =1 linear with bottom correction over steps ! =2 "qco like", i.e. proportional to thicknesses at rest ! - REAL(dp) :: rn_ahe3 ! thickness diffusion coefficient - REAL(dp) :: rn_rst_e3t ! ztilde to zstar restoration timescale [days] - REAL(dp) :: rn_lf_cutoff ! cutoff frequency for low-pass filter [days] - REAL(dp) :: rn_zdef_max ! maximum fractional e3t deformation + REAL(wp) :: rn_ahe3 ! thickness diffusion coefficient + REAL(wp) :: rn_rst_e3t ! ztilde to zstar restoration timescale [days] + REAL(wp) :: rn_lf_cutoff ! cutoff frequency for low-pass filter [days] + REAL(wp) :: rn_zdef_max ! maximum fractional e3t deformation LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE. ! debug control prints !! * Substitutions @@ -129,8 +129,8 @@ CONTAINS CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm), r3f(:,:) ) #endif ! dom_qco_r3c defines over [nn_hls, nn_hls-1, nn_hls, nn_hls-1] - IF( nn_hls == 2 ) CALL lbc_lnk( 'dom_qco_zgr', r3u(:,:,Kbb), 'U', 1._dp, r3v(:,:,Kbb), 'V', 1._dp, & - & r3u(:,:,Kmm), 'U', 1._dp, r3v(:,:,Kmm), 'V', 1._dp, r3f(:,:), 'F', 1._dp ) + IF( nn_hls == 2 ) CALL lbc_lnk( 'dom_qco_zgr', r3u(:,:,Kbb), 'U', 1._wp, r3v(:,:,Kbb), 'V', 1._wp, & + & r3u(:,:,Kmm), 'U', 1._wp, r3v(:,:,Kmm), 'V', 1._wp, r3f(:,:), 'F', 1._wp ) ! ! r3f is needed for agrif END SUBROUTINE dom_qco_zgr @@ -147,8 +147,9 @@ CONTAINS !! - compute the ratio ssh/h_0 at t-,u-,v-pts, (f-pt optional) !!---------------------------------------------------------------------- REAL(dp), DIMENSION(:,:) , INTENT(in ) :: pssh ! sea surface height [m] - REAL(dp), DIMENSION(:,:) , INTENT( out) :: pr3t, pr3u, pr3v ! ssh/h0 ratio at t-, u-, v-,points [-] - REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT( out) :: pr3f ! ssh/h0 ratio at f-point [-] + REAL(wp), DIMENSION(:,:) , INTENT( out) :: pr3u, pr3v! ssh/h0 ratio at t-, u-, v-,points [-] + REAL(dp), DIMENSION(:,:) , INTENT( out) :: pr3t! ssh/h0 ratio at t-, u-, v-,points [-] + REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT( out) :: pr3f ! ssh/h0 ratio at f-point [-] ! INTEGER :: ji, jj ! dummy loop indices !!---------------------------------------------------------------------- @@ -180,7 +181,7 @@ CONTAINS #endif ! IF( .NOT.PRESENT( pr3f ) ) THEN !- lbc on ratio at u-, v-points only - IF (nn_hls==1) CALL lbc_lnk( 'dom_qco_r3c', pr3u, 'U', 1._dp, pr3v, 'V', 1._dp ) + IF (nn_hls==1) CALL lbc_lnk( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp ) ! ! ELSE !== ratio at f-point ==! @@ -213,7 +214,7 @@ CONTAINS !!st ENDIF #endif ! ! lbc on ratio at u-,v-,f-points - IF (nn_hls==1) CALL lbc_lnk( 'dom_qco_r3c', pr3u, 'U', 1._dp, pr3v, 'V', 1._dp, pr3f, 'F', 1._dp ) + IF (nn_hls==1) CALL lbc_lnk( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp, pr3f, 'F', 1._wp ) ! ENDIF ! @@ -291,4 +292,4 @@ CONTAINS END SUBROUTINE qco_ctl !!====================================================================== -END MODULE domqco +END MODULE domqco \ No newline at end of file diff --git a/src/OCE/DOM/domutl.F90 b/src/OCE/DOM/domutl.F90 index 5a9f3718e316d2199d34f1f41a966827896d85a9..a3976e8fc0fa19f423c97a775101f6221f6a7366 100644 --- a/src/OCE/DOM/domutl.F90 +++ b/src/OCE/DOM/domutl.F90 @@ -51,8 +51,8 @@ CONTAINS ! INTEGER :: ik ! working level INTEGER , DIMENSION(2) :: iloc - REAL(dp) :: zlon, zmini - REAL(dp), DIMENSION(jpi,jpj) :: zglam, zgphi, zdist + REAL(wp) :: zlon, zmini + REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zdist LOGICAL , DIMENSION(jpi,jpj) :: llmsk !!-------------------------------------------------------------------- ! @@ -75,7 +75,7 @@ CONTAINS zgphi(:,:) = zgphi(:,:) - plat zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:) ! - CALL mpp_minloc( 'domngb', zdist(:,:), llmsk, zmini, iloc, ldhalo = .TRUE. ) + CALL mpp_minloc( 'domngb', REAL(zdist(:,:),dp), llmsk, zmini, iloc, ldhalo = .TRUE. ) kii = iloc(1) kjj = iloc(2) ! @@ -92,25 +92,25 @@ CONTAINS !! 2) check which elements have been changed !!---------------------------------------------------------------------- CHARACTER(len=1) , INTENT(in ) :: cdgrd ! - REAL(dp), DIMENSION(:,:), INTENT(inout) :: puniq ! + REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq ! ! - REAL(dp) :: zshift ! shift value link to the process number + REAL(wp) :: zshift ! shift value link to the process number INTEGER :: ji ! dummy loop indices LOGICAL , DIMENSION(jpi,jpj,1) :: lluniq ! store whether each point is unique or not - REAL(dp), DIMENSION(jpi,jpj ) :: ztstref + REAL(wp), DIMENSION(jpi,jpj ) :: ztstref !!---------------------------------------------------------------------- ! ! build an array with different values for each element ! in mpp: make sure that these values are different even between process ! -> apply a shift value according to the process number zshift = jpimax * jpjmax * ( narea - 1 ) - ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,dp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) ) + ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) ) ! puniq(:,:) = ztstref(:,:) ! default definition - CALL lbc_lnk( 'domwri', puniq, cdgrd, 1._dp ) ! apply boundary conditions + CALL lbc_lnk( 'domwri', puniq, cdgrd, 1._wp ) ! apply boundary conditions lluniq(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have not been changed ! - puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ),dp ) + puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp ) ! END SUBROUTINE dom_uniq diff --git a/src/OCE/DOM/domvvl.F90 b/src/OCE/DOM/domvvl.F90 index 746b5b8a08224e451e98cb1f5721a1aa692c3c84..7dbd05800ea8ac0aa6016393c852f548d06e32a8 100644 --- a/src/OCE/DOM/domvvl.F90 +++ b/src/OCE/DOM/domvvl.F90 @@ -42,18 +42,18 @@ MODULE domvvl ! =2 "qco like", i.e. proportional to thicknesses at rest ! ! ! conservation: not used yet - REAL(dp) :: rn_ahe3 ! thickness diffusion coefficient - REAL(dp) :: rn_rst_e3t ! ztilde to zstar restoration timescale [days] - REAL(dp) :: rn_lf_cutoff ! cutoff frequency for low-pass filter [days] - REAL(dp) :: rn_zdef_max ! maximum fractional e3t deformation + REAL(wp) :: rn_ahe3 ! thickness diffusion coefficient + REAL(wp) :: rn_rst_e3t ! ztilde to zstar restoration timescale [days] + REAL(wp) :: rn_lf_cutoff ! cutoff frequency for low-pass filter [days] + REAL(wp) :: rn_zdef_max ! maximum fractional e3t deformation LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE. ! debug control prints - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_td, vn_td ! thickness diffusion transport - REAL(dp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv_lf ! low frequency part of hz divergence - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_b, tilde_e3t_n ! baroclinic scale factors - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_a, dtilde_e3t_a ! baroclinic scale factors - REAL(dp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_e3t ! retoring period for scale factors - REAL(dp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_td, vn_td ! thickness diffusion transport + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv_lf ! low frequency part of hz divergence + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_b, tilde_e3t_n ! baroclinic scale factors + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_a, dtilde_e3t_a ! baroclinic scale factors + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_e3t ! retoring period for scale factors + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence #if defined key_qco || defined key_linssh !!---------------------------------------------------------------------- diff --git a/src/OCE/DOM/domwri.F90 b/src/OCE/DOM/domwri.F90 index 278f6d3cfd9e9e8d6966cafdb1db062094c0a852..b54592446ee80f3b74d2b4cd54c3e7191a068a07 100644 --- a/src/OCE/DOM/domwri.F90 +++ b/src/OCE/DOM/domwri.F90 @@ -57,8 +57,8 @@ CONTAINS INTEGER :: inum ! temprary units for 'mesh_mask.nc' file CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp), DIMENSION(jpi,jpj) :: zprt, zprw ! 2D workspace - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zdepu, zdepv ! 3D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zprt, zprw ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepu, zdepv ! 3D workspace !!---------------------------------------------------------------------- ! IF(lwp) WRITE(numout,*) @@ -142,9 +142,9 @@ CONTAINS CALL iom_rstput( 0, 0, inum, 'ff_t', ff_t, ktype = jp_r8 ) ! note that mbkt is set to 1 over land ==> use surface tmask - zprt(:,:) = REAL( mbkt(:,:) ,dp ) + zprt(:,:) = REAL( mbkt(:,:) , wp ) CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points - zprt(:,:) = REAL( mikt(:,:) ,dp ) + zprt(:,:) = REAL( mikt(:,:) , wp ) CALL iom_rstput( 0, 0, inum, 'misf', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points ! ! vertical mesh CALL iom_rstput( 0, 0, inum, 'e3t_1d', e3t_1d, ktype = jp_r8 ) ! ! scale factors @@ -188,12 +188,12 @@ CONTAINS !! !! Haney, 1991, J. Phys. Oceanogr., 21, 610-619. !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:), INTENT(out), OPTIONAL :: px1 ! stiffness + REAL(wp), DIMENSION(:,:), INTENT(out), OPTIONAL :: px1 ! stiffness ! INTEGER :: ji, jj, jk - REAL(dp) :: zrxmax - REAL(dp), DIMENSION(4) :: zr1 - REAL(dp), DIMENSION(jpi,jpj) :: zx1 + REAL(wp) :: zrxmax + REAL(wp), DIMENSION(4) :: zr1 + REAL(wp), DIMENSION(jpi,jpj) :: zx1 !!---------------------------------------------------------------------- zx1(:,:) = 0._wp zrxmax = 0._wp @@ -223,7 +223,7 @@ CONTAINS zrxmax = MAXVAL( zr1(1:4) ) zx1(ji,jj) = MAX( zx1(ji,jj) , zrxmax ) END_3D - CALL lbc_lnk( 'domwri', zx1, 'T', 1.0_dp ) + CALL lbc_lnk( 'domwri', zx1, 'T', 1.0_wp ) ! IF( PRESENT( px1 ) ) px1 = zx1 ! @@ -240,4 +240,4 @@ CONTAINS END SUBROUTINE dom_stiff !!====================================================================== -END MODULE domwri +END MODULE domwri \ No newline at end of file diff --git a/src/OCE/DOM/domzgr.F90 b/src/OCE/DOM/domzgr.F90 index 0f56f524c4b80262a749badcd797a17fea9461af..9d4d21dc4280baf5c4ac52af2dbc0d2e5fc2b3a7 100644 --- a/src/OCE/DOM/domzgr.F90 +++ b/src/OCE/DOM/domzgr.F90 @@ -74,9 +74,9 @@ CONTAINS INTEGER :: ikt, ikb ! top/bot index INTEGER :: ioptio, ibat, ios ! local integer INTEGER :: is_mbkuvf ! ==0 if mbku, mbkv, mbkf to be computed - REAL(dp) :: zrefdep ! depth of the reference level (~10m) - REAL(dp), DIMENSION(jpi,jpj ) :: zmsk - REAL(dp), DIMENSION(jpi,jpj,2) :: ztopbot + 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 @@ -113,13 +113,14 @@ CONTAINS & k_top , k_bot ) ! 1st & last ocean level ! ! make sure that periodicities are properly applied - CALL lbc_lnk( 'dom_zgr', gdept_0, 'T', 1._dp, gdepw_0, 'W', 1._dp, & - & e3t_0, 'T', 1._dp, e3u_0, 'U', 1._dp, e3v_0, 'V', 1._dp, e3f_0, 'F', 1._dp, & - & e3w_0, 'W', 1._dp, e3uw_0, 'U', 1._dp, e3vw_0, 'V', 1._dp, & + 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 - ztopbot(:,:,1) = REAL(k_top,dp) - ztopbot(:,:,2) = REAL(k_bot,dp) - CALL lbc_lnk( 'dom_zgr', ztopbot, 'T', 1._dp, 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)) ! @@ -139,7 +140,7 @@ CONTAINS 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. ) ! set halos + 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 @@ -232,19 +233,20 @@ CONTAINS !!---------------------------------------------------------------------- LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag - REAL(dp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] - REAL(dp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] - REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] - REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] - REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! - - - + 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) :: 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 :: ji,jj,jk ! dummy loop index INTEGER :: inum, iatt - REAL(dp) :: z_zco, z_zps, z_sco, z_cav - REAL(dp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + 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' !!---------------------------------------------------------------------- ! @@ -367,7 +369,7 @@ CONTAINS INTEGER , INTENT(in) :: k_mbkuvf ! flag to recompute mbku, mbkv, mbkf ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp), DIMENSION(jpi,jpj) :: zk ! workspace + REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace !!---------------------------------------------------------------------- ! IF(lwp) WRITE(numout,*) @@ -405,39 +407,39 @@ CONTAINS 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),dp ) + zk(ji,jj) = REAL( miku(ji,jj), wp ) END_2D - CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_dp ) + 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),dp ) + zk(ji,jj) = REAL( mikv(ji,jj), wp ) END_2D - CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_dp ) + 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),dp ) + zk(ji,jj) = REAL( mikf(ji,jj), wp ) END_2D - CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_dp ) + CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) ! DO_2D( 0, 0, 0, 0 ) - zk(ji,jj) = REAL( mbku(ji,jj),dp ) + zk(ji,jj) = REAL( mbku(ji,jj), wp ) END_2D - CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_dp ) + 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),dp ) + zk(ji,jj) = REAL( mbkv(ji,jj), wp ) END_2D - CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_dp ) + 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),dp ) + zk(ji,jj) = REAL( mbkf(ji,jj), wp ) END_2D - CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_dp ) + CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) mbkf(:,:) = MAX( NINT( zk(:,:) ), 1 ) ! END SUBROUTINE zgr_top_bot diff --git a/src/OCE/DOM/istate.F90 b/src/OCE/DOM/istate.F90 index 6e8b0dd057165c4da57892640bf8d2bc689317c9..f9d2163393334da683bad84dab1d2f9cab841976 100644 --- a/src/OCE/DOM/istate.F90 +++ b/src/OCE/DOM/istate.F90 @@ -66,9 +66,9 @@ CONTAINS INTEGER, INTENT( in ) :: Kbb, Kmm, Kaa ! ocean time level indices ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zgdept ! 3D table for qco substitute + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgdept ! 3D table for qco substitute !!gm see comment further down - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace !!gm end !!---------------------------------------------------------------------- ! diff --git a/src/OCE/DOM/phycst.F90 b/src/OCE/DOM/phycst.F90 index bcb4b42d210b8caf2e5d5d3f596dc9cfd76be907..27ebf4e95fc79b1ca1e2b70ff2eeb609b99edde9 100644 --- a/src/OCE/DOM/phycst.F90 +++ b/src/OCE/DOM/phycst.F90 @@ -22,50 +22,50 @@ MODULE phycst PUBLIC phy_cst ! routine called by inipar.F90 - REAL(dp), PUBLIC :: rpi = 3.141592653589793_wp !: pi - REAL(dp), PUBLIC :: rad = 3.141592653589793_wp / 180._wp !: conversion from degre into radian - REAL(dp), PUBLIC :: rsmall = 0.5 * EPSILON( 1.e0 ) !: smallest real computer value - - REAL(dp), PUBLIC :: rday = 24.*60.*60. !: day [s] - REAL(dp), PUBLIC :: rsiyea !: sideral year [s] - REAL(dp), PUBLIC :: rsiday !: sideral day [s] - REAL(dp), PUBLIC :: raamo = 12._wp !: number of months in one year - REAL(dp), PUBLIC :: rjjhh = 24._wp !: number of hours in one day - REAL(dp), PUBLIC :: rhhmm = 60._wp !: number of minutes in one hour - REAL(dp), PUBLIC :: rmmss = 60._wp !: number of seconds in one minute - REAL(dp), PUBLIC :: omega !: earth rotation parameter [s-1] - REAL(dp), PUBLIC :: ra = 6371229._wp !: earth radius [m] - REAL(dp), PUBLIC :: grav = 9.80665_wp !: gravity [m/s2] - REAL(dp), PUBLIC :: rt0 = 273.15_wp !: freezing point of fresh water [Kelvin] - - REAL(dp), PUBLIC :: rho0 !: volumic mass of reference [kg/m3] - REAL(dp), PUBLIC :: r1_rho0 !: = 1. / rho0 [m3/kg] - REAL(dp), PUBLIC :: rcp !: ocean specific heat [J/Kelvin] - REAL(dp), PUBLIC :: r1_rcp !: = 1. / rcp [Kelvin/J] - REAL(dp), PUBLIC :: rho0_rcp !: = rho0 * rcp - REAL(dp), PUBLIC :: r1_rho0_rcp !: = 1. / ( rho0 * rcp ) - - REAL(dp), PUBLIC :: emic = 0.97_wp !: emissivity of snow or ice (not used?) - - REAL(dp), PUBLIC :: sice = 6.0_wp !: salinity of ice (for pisces) [psu] - REAL(dp), PUBLIC :: soce = 34.7_wp !: salinity of sea (for pisces and isf) [psu] - REAL(dp), PUBLIC :: rLevap = 2.5e+6_wp !: latent heat of evaporation (water) - REAL(dp), PUBLIC :: vkarmn = 0.4_wp !: von Karman constant - REAL(dp), PUBLIC :: vkarmn2 = 0.4_wp*0.4_wp !: square of von Karman constant - REAL(dp), PUBLIC :: stefan = 5.67e-8_wp !: Stefan-Boltzmann constant - - REAL(dp), PUBLIC :: rhos = 330._wp !: volumic mass of snow [kg/m3] - REAL(dp), PUBLIC :: rhoi = 917._wp !: volumic mass of sea ice [kg/m3] - REAL(dp), PUBLIC :: rhow = 1000._wp !: volumic mass of freshwater in melt ponds [kg/m3] - REAL(dp), PUBLIC :: rcnd_i = 2.034396_wp !: thermal conductivity of fresh ice [W/m/K] - REAL(dp), PUBLIC :: rcpi = 2067.0_wp !: specific heat of fresh ice [J/kg/K] - REAL(dp), PUBLIC :: rLsub = 2.834e+6_wp !: pure ice latent heat of sublimation [J/kg] - REAL(dp), PUBLIC :: rLfus = 0.334e+6_wp !: latent heat of fusion of fresh ice [J/kg] - REAL(dp), PUBLIC :: rTmlt = 0.054_wp !: decrease of seawater meltpoint with salinity - - REAL(dp), PUBLIC :: r1_rhoi !: 1 / rhoi - REAL(dp), PUBLIC :: r1_rhos !: 1 / rhos - REAL(dp), PUBLIC :: r1_rcpi !: 1 / rcpi + REAL(wp), PUBLIC :: rpi = 3.141592653589793_wp !: pi + REAL(wp), PUBLIC :: rad = 3.141592653589793_wp / 180._wp !: conversion from degre into radian + REAL(wp), PUBLIC :: rsmall = 0.5 * EPSILON( 1.e0 ) !: smallest real computer value + + REAL(wp), PUBLIC :: rday = 24.*60.*60. !: day [s] + REAL(wp), PUBLIC :: rsiyea !: sideral year [s] + REAL(wp), PUBLIC :: rsiday !: sideral day [s] + REAL(wp), PUBLIC :: raamo = 12._wp !: number of months in one year + REAL(wp), PUBLIC :: rjjhh = 24._wp !: number of hours in one day + REAL(wp), PUBLIC :: rhhmm = 60._wp !: number of minutes in one hour + REAL(wp), PUBLIC :: rmmss = 60._wp !: number of seconds in one minute + REAL(wp), PUBLIC :: omega !: earth rotation parameter [s-1] + REAL(wp), PUBLIC :: ra = 6371229._wp !: earth radius [m] + REAL(wp), PUBLIC :: grav = 9.80665_wp !: gravity [m/s2] + REAL(wp), PUBLIC :: rt0 = 273.15_wp !: freezing point of fresh water [Kelvin] + + REAL(wp), PUBLIC :: rho0 !: volumic mass of reference [kg/m3] + REAL(wp), PUBLIC :: r1_rho0 !: = 1. / rho0 [m3/kg] + REAL(wp), PUBLIC :: rcp !: ocean specific heat [J/Kelvin] + REAL(wp), PUBLIC :: r1_rcp !: = 1. / rcp [Kelvin/J] + REAL(wp), PUBLIC :: rho0_rcp !: = rho0 * rcp + REAL(wp), PUBLIC :: r1_rho0_rcp !: = 1. / ( rho0 * rcp ) + + REAL(wp), PUBLIC :: emic = 0.97_wp !: emissivity of snow or ice (not used?) + + REAL(wp), PUBLIC :: sice = 6.0_wp !: salinity of ice (for pisces) [psu] + REAL(wp), PUBLIC :: soce = 34.7_wp !: salinity of sea (for pisces and isf) [psu] + REAL(wp), PUBLIC :: rLevap = 2.5e+6_wp !: latent heat of evaporation (water) + REAL(wp), PUBLIC :: vkarmn = 0.4_wp !: von Karman constant + REAL(wp), PUBLIC :: vkarmn2 = 0.4_wp*0.4_wp !: square of von Karman constant + REAL(wp), PUBLIC :: stefan = 5.67e-8_wp !: Stefan-Boltzmann constant + + REAL(wp), PUBLIC :: rhos = 330._wp !: volumic mass of snow [kg/m3] + REAL(wp), PUBLIC :: rhoi = 917._wp !: volumic mass of sea ice [kg/m3] + REAL(wp), PUBLIC :: rhow = 1000._wp !: volumic mass of freshwater in melt ponds [kg/m3] + REAL(wp), PUBLIC :: rcnd_i = 2.034396_wp !: thermal conductivity of fresh ice [W/m/K] + REAL(wp), PUBLIC :: rcpi = 2067.0_wp !: specific heat of fresh ice [J/kg/K] + REAL(wp), PUBLIC :: rLsub = 2.834e+6_wp !: pure ice latent heat of sublimation [J/kg] + REAL(wp), PUBLIC :: rLfus = 0.334e+6_wp !: latent heat of fusion of fresh ice [J/kg] + REAL(wp), PUBLIC :: rTmlt = 0.054_wp !: decrease of seawater meltpoint with salinity + + REAL(wp), PUBLIC :: r1_rhoi !: 1 / rhoi + REAL(wp), PUBLIC :: r1_rhos !: 1 / rhos + REAL(wp), PUBLIC :: r1_rcpi !: 1 / rcpi !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) diff --git a/src/OCE/DYN/divhor.F90 b/src/OCE/DYN/divhor.F90 index 83948ebed2de963771a0affe9a7b325b855fdfca..f485276d9d0be3e93be65a2d25e92ecf9d504fef 100644 --- a/src/OCE/DYN/divhor.F90 +++ b/src/OCE/DYN/divhor.F90 @@ -98,11 +98,11 @@ CONTAINS #endif IF( ln_isf ) CALL isf_hdiv( kt, Kmm, hdiv ) !== ice shelf ==! (update hdiv field) ! - IF( nn_hls==1 ) CALL lbc_lnk( 'divhor', hdiv, 'T', 1.0_dp ) ! (no sign change) + IF( nn_hls==1 ) CALL lbc_lnk( 'divhor', hdiv, 'T', 1.0_wp ) ! (no sign change) ! ! needed for ww in sshwzv IF( ln_timing ) CALL timing_stop('div_hor') ! END SUBROUTINE div_hor !!====================================================================== -END MODULE divhor +END MODULE divhor \ No newline at end of file diff --git a/src/OCE/DYN/dynadv_cen2.F90 b/src/OCE/DYN/dynadv_cen2.F90 index a65cc0396083e0c6835639eb79c9eaba71451e23..e261420b26b0a3afcfa5000dbd187f7b8e2e95ed 100644 --- a/src/OCE/DYN/dynadv_cen2.F90 +++ b/src/OCE/DYN/dynadv_cen2.F90 @@ -51,8 +51,10 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfu_t, zfu_f, zfu_uw, zfu - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfv_t, zfv_f, zfv_vw, zfv, zfw + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfu_f, zfu + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfu_t, zfu_uw + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfv_f, zfv, zfw + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfv_t, zfv_vw !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -139,4 +141,4 @@ CONTAINS END SUBROUTINE dyn_adv_cen2 !!============================================================================== -END MODULE dynadv_cen2 +END MODULE dynadv_cen2 \ No newline at end of file diff --git a/src/OCE/DYN/dynadv_ubs.F90 b/src/OCE/DYN/dynadv_ubs.F90 index 4e0d0ed0c23dcbb7e0378b48a72ae14ac60e8076..84c23ac7bcc943f263fd2135046fafca88c49fb1 100644 --- a/src/OCE/DYN/dynadv_ubs.F90 +++ b/src/OCE/DYN/dynadv_ubs.F90 @@ -73,11 +73,13 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zui, zvj, zfuj, zfvi, zl_u, zl_v ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfu_t, zfu_f, zfu_uw, zfu - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfv_t, zfv_f, zfv_vw, zfv, zfw - REAL(dp), DIMENSION(A2D(nn_hls),jpk,2) :: zlu_uu, zlu_uv - REAL(dp), DIMENSION(A2D(nn_hls),jpk,2) :: zlv_vv, zlv_vu + REAL(wp) :: zui, zvj, zfuj, zfvi, zl_u, zl_v ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfu_f, zfu + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfu_t, zfu_uw + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfv_f, zfv, zfw + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfv_t, zfv_vw + REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: zlu_uu, zlu_uv + REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: zlv_vv, zlv_vu !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -147,10 +149,10 @@ CONTAINS & - ( zfv(ji ,jj ,jk) - zfv(ji-1,jj ,jk) ) * fmask(ji-1,jj ,jk) END_2D END DO - IF( nn_hls == 1 ) CALL lbc_lnk( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', -1.0_dp , zlu_uv(:,:,:,1), 'U', -1.0_dp, & - & zlu_uu(:,:,:,2), 'U', -1.0_dp , zlu_uv(:,:,:,2), 'U', -1.0_dp, & - & zlv_vv(:,:,:,1), 'V', -1.0_dp , zlv_vu(:,:,:,1), 'V', -1.0_dp, & - & zlv_vv(:,:,:,2), 'V', -1.0_dp , zlv_vu(:,:,:,2), 'V', -1.0_dp ) + IF( nn_hls == 1 ) CALL lbc_lnk( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', -1.0_wp , zlu_uv(:,:,:,1), 'U', -1.0_wp, & + & zlu_uu(:,:,:,2), 'U', -1.0_wp , zlu_uv(:,:,:,2), 'U', -1.0_wp, & + & zlv_vv(:,:,:,1), 'V', -1.0_wp , zlv_vu(:,:,:,1), 'V', -1.0_wp, & + & zlv_vv(:,:,:,2), 'V', -1.0_wp , zlv_vu(:,:,:,2), 'V', -1.0_wp ) ! ! ! ====================== ! ! ! Horizontal advection ! @@ -252,4 +254,4 @@ CONTAINS END SUBROUTINE dyn_adv_ubs !!============================================================================== -END MODULE dynadv_ubs +END MODULE dynadv_ubs \ No newline at end of file diff --git a/src/OCE/DYN/dynatf.F90 b/src/OCE/DYN/dynatf.F90 index 09a6871c995c87fcd7acfe495ee8d87a25711d87..16af0645e404027ad228399f1e01d0ce362a8fff 100644 --- a/src/OCE/DYN/dynatf.F90 +++ b/src/OCE/DYN/dynatf.F90 @@ -70,8 +70,8 @@ CONTAINS SUBROUTINE dyn_atf( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v ) INTEGER , INTENT(in ) :: kt ! ocean time-step index INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! before and after time level indices - REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered - REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: pe3t, pe3u, pe3v ! scale factors to be time filtered + REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered + REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: pe3t, pe3u, pe3v ! scale factors to be time filtered WRITE(*,*) 'dyn_atf: You should not have seen this print! error?', kt END SUBROUTINE dyn_atf @@ -366,4 +366,4 @@ CONTAINS #endif !!========================================================================= -END MODULE dynatf +END MODULE dynatf \ No newline at end of file diff --git a/src/OCE/DYN/dynatf_qco.F90 b/src/OCE/DYN/dynatf_qco.F90 index 9e3aba2deef443f4fedc53346ad8d383fba5a76e..0c7b593e6349d26e0fc0a3c6693ecda9a72c542e 100644 --- a/src/OCE/DYN/dynatf_qco.F90 +++ b/src/OCE/DYN/dynatf_qco.F90 @@ -97,11 +97,11 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zue3a, zue3n, zue3b, zcoef ! local scalars - REAL(dp) :: zve3a, zve3n, zve3b ! - - - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve + REAL(wp) :: zue3a, zue3n, zue3b, zcoef ! local scalars + REAL(wp) :: zve3a, zve3n, zve3b ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zua, zva - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zutau, zvtau + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zutau, zvtau !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('dyn_atf_qco') diff --git a/src/OCE/DYN/dynhpg.F90 b/src/OCE/DYN/dynhpg.F90 index 242c1c4bb0f653de4c971c99f400f9b89ce54504..9537472f995a068771378518b6289d47817e0bc9 100644 --- a/src/OCE/DYN/dynhpg.F90 +++ b/src/OCE/DYN/dynhpg.F90 @@ -75,7 +75,7 @@ MODULE dynhpg INTEGER, PUBLIC :: nhpg !: type of pressure gradient scheme used ! (deduced from ln_hpg_... flags) (PUBLIC for TAM) ! LOGICAL :: ln_hpg_djc_vnh, ln_hpg_djc_vnv ! flag to specify hpg_djc boundary condition type - REAL(dp), PUBLIC :: aco_bc_hor, bco_bc_hor, aco_bc_vrt, bco_bc_vrt !: coefficients for hpg_djc hor and vert boundary conditions + REAL(wp), PUBLIC :: aco_bc_hor, bco_bc_hor, aco_bc_vrt, bco_bc_vrt !: coefficients for hpg_djc hor and vert boundary conditions !! * Substitutions # include "do_loop_substitute.h90" @@ -130,7 +130,7 @@ CONTAINS ENDIF ! !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' hpg - Ua: ', mask1=umask, & - ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) ! IF( ln_timing ) CALL timing_stop('dyn_hpg') ! @@ -153,9 +153,9 @@ CONTAINS INTEGER :: ios ! Local integer output status for namelist read !! INTEGER :: ji, jj, jk, ikt ! dummy loop indices ISF - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zts_top, zrhd ! hypothesys on isf density - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zrhdtop_isf ! density at bottom of ISF - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: ziceload ! density at bottom of ISF + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zts_top, zrhd ! hypothesys on isf density + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zrhdtop_isf ! density at bottom of ISF + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ziceload ! density at bottom of ISF !! NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco, & & ln_hpg_djc, ln_hpg_prj, ln_hpg_isf, & @@ -259,8 +259,8 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zcoef0, zcoef1 ! temporary scalars - REAL(dp), DIMENSION(A2D(nn_hls)) :: zhpi, zhpj + REAL(wp) :: zcoef0, zcoef1 ! temporary scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zhpi, zhpj !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -313,10 +313,10 @@ CONTAINS !! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: iku, ikv ! temporary integers - REAL(dp) :: zcoef0, zcoef1, zcoef2, zcoef3 ! temporary scalars - REAL(dp), DIMENSION(A2D(nn_hls),jpk ) :: zhpi, zhpj - REAL(dp), DIMENSION(A2D(nn_hls),jpts) :: zgtsu, zgtsv - REAL(dp), DIMENSION(A2D(nn_hls) ) :: zgru, zgrv + REAL(wp) :: zcoef0, zcoef1, zcoef2, zcoef3 ! temporary scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk ) :: zhpi, zhpj + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zgtsu, zgtsv + REAL(wp), DIMENSION(A2D(nn_hls) ) :: zgru, zgrv !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -406,10 +406,10 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation !! INTEGER :: ji, jj, jk, jii, jjj ! dummy loop indices - REAL(dp) :: zcoef0, zuap, zvap, ztmp ! local scalars + REAL(wp) :: zcoef0, zuap, zvap, ztmp ! local scalars LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zhpi, zhpj - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zhpi, zhpj + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter !!---------------------------------------------------------------------- ! IF( ln_wd_il ) ALLOCATE(zcpx(A2D(nn_hls)), zcpy(A2D(nn_hls))) @@ -545,11 +545,11 @@ CONTAINS !! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ikt , ikti1, iktj1 ! local integer - REAL(dp) :: ze3w, ze3wi1, ze3wj1 ! local scalars - REAL(dp) :: zcoef0, zuap, zvap ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpk ) :: zhpi, zhpj - REAL(dp), DIMENSION(A2D(nn_hls),jpts) :: zts_top - REAL(dp), DIMENSION(A2D(nn_hls)) :: zrhd_top, zdep_top + REAL(wp) :: ze3w, ze3wi1, ze3wj1 ! local scalars + REAL(wp) :: zcoef0, zuap, zvap ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk ) :: zhpi, zhpj + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zts_top + REAL(wp), DIMENSION(A2D(nn_hls)) :: zrhd_top, zdep_top !!---------------------------------------------------------------------- ! zcoef0 = - grav * 0.5_wp ! Local constant initialization @@ -633,20 +633,20 @@ CONTAINS !! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: iktb, iktt ! jk indices at tracer points for top and bottom points - REAL(dp) :: zcoef0, zep, cffw ! temporary scalars - REAL(dp) :: z_grav_10, z1_12, z1_cff - REAL(dp) :: cffu, cffx ! 7M10BJN23RZ - REAL(dp) :: cffv, cffy ! GORRC65JS9V + REAL(wp) :: zcoef0, zep, cffw ! temporary scalars + REAL(wp) :: z_grav_10, z1_12, z1_cff + REAL(wp) :: cffu, cffx ! " " + REAL(wp) :: cffv, cffy ! " " LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zhpi, zhpj - - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zdzx, zdzy, zdzz ! Primitive grid differences (D2D4KJT3AI5) - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zdz_i, zdz_j, zdz_k ! Harmonic average of primitive grid differences (G7OJWAE) - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zdrhox, zdrhoy, zdrhoz ! Primitive rho differences (QEITV8ODLLG) - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zdrho_i, zdrho_j, zdrho_k ! Harmonic average of primitive rho differences (CWZBD18) - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: z_rho_i, z_rho_j, z_rho_k ! Face intergrals - REAL(dp), DIMENSION(A2D(nn_hls)) :: zz_dz_i, zz_dz_j, zz_drho_i, zz_drho_j ! temporary arrays - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zhpi, zhpj + + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdzx, zdzy, zdzz ! Primitive grid differences ('delta_xyz') + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdz_i, zdz_j, zdz_k ! Harmonic average of primitive grid differences ('d_xyz') + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdrhox, zdrhoy, zdrhoz ! Primitive rho differences ('delta_rho') + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdrho_i, zdrho_j, zdrho_k ! Harmonic average of primitive rho differences ('d_rho') + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: z_rho_i, z_rho_j, z_rho_k ! Face intergrals + REAL(wp), DIMENSION(A2D(nn_hls)) :: zz_dz_i, zz_dz_j, zz_drho_i, zz_drho_j ! temporary arrays + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter !!---------------------------------------------------------------------- ! IF( ln_wd_il ) THEN @@ -797,7 +797,7 @@ CONTAINS zdzy (ji,jj,jk) = gde3w(ji ,jj ,jk) - gde3w(ji ,jj+1,jk) END_3D - IF( nn_hls == 1 ) CALL lbc_lnk( 'dynhpg', zdrhox, 'U', -1._dp, zdzx, 'U', -1._dp, zdrhoy, 'V', -1._dp, zdzy, 'V', -1._dp ) + IF( nn_hls == 1 ) CALL lbc_lnk( 'dynhpg', zdrhox, 'U', -1._wp, zdzx, 'U', -1._wp, zdrhoy, 'V', -1._wp, zdzy, 'V', -1._wp ) !------------------------------------------------------------------------- ! 6. compute harmonic averages using eq. 5.18 @@ -956,19 +956,19 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation !! INTEGER :: ji, jj, jk, jkk ! dummy loop indices - REAL(dp) :: zcoef0, znad ! local scalars + REAL(wp) :: zcoef0, znad ! local scalars ! !! The local variables for the correction term INTEGER :: jk1, jis, jid, jjs, jjd LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables - REAL(dp) :: zuijk, zvijk, zpwes, zpwed, zpnss, zpnsd, zdeps - REAL(dp) :: zrhdt1 - REAL(dp) :: zdpdx1, zdpdx2, zdpdy1, zdpdy2 - REAL(dp), DIMENSION(A2D(nn_hls)) :: zpgu, zpgv ! 2D workspace - REAL(dp), DIMENSION(A2D(nn_hls)) :: zsshu_n, zsshv_n - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zdept, zrhh - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter + REAL(wp) :: zuijk, zvijk, zpwes, zpwed, zpnss, zpnsd, zdeps + REAL(wp) :: zrhdt1 + REAL(wp) :: zdpdx1, zdpdx2, zdpdy1, zdpdy2 + REAL(wp), DIMENSION(A2D(nn_hls)) :: zpgu, zpgv ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls)) :: zsshu_n, zsshv_n + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdept, zrhh + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -1177,9 +1177,9 @@ CONTAINS zdpdx1 = zcoef0 * r1_e1u(ji,jj) * ( zhpi(ji+1,jj,jk) - zhpi(ji,jj,jk) ) IF( .NOT.ln_linssh ) THEN zdpdx2 = zcoef0 * r1_e1u(ji,jj) * & - & ( REAL(jis-jid,dp) * (zpwes + zpwed) + (ssh(ji+1,jj,Kmm)-ssh(ji,jj,Kmm)) ) + & ( REAL(jis-jid, wp) * (zpwes + zpwed) + (ssh(ji+1,jj,Kmm)-ssh(ji,jj,Kmm)) ) ELSE - zdpdx2 = zcoef0 * r1_e1u(ji,jj) * REAL(jis-jid,dp) * (zpwes + zpwed) + zdpdx2 = zcoef0 * r1_e1u(ji,jj) * REAL(jis-jid, wp) * (zpwes + zpwed) ENDIF IF( ln_wd_il ) THEN zdpdx1 = zdpdx1 * zcpx(ji,jj) * wdrampu(ji,jj) @@ -1234,9 +1234,9 @@ CONTAINS zdpdy1 = zcoef0 * r1_e2v(ji,jj) * ( zhpi(ji,jj+1,jk) - zhpi(ji,jj,jk) ) IF( .NOT.ln_linssh ) THEN zdpdy2 = zcoef0 * r1_e2v(ji,jj) * & - ( REAL(jjs-jjd,dp) * (zpnss + zpnsd) + (ssh(ji,jj+1,Kmm)-ssh(ji,jj,Kmm)) ) + ( REAL(jjs-jjd, wp) * (zpnss + zpnsd) + (ssh(ji,jj+1,Kmm)-ssh(ji,jj,Kmm)) ) ELSE - zdpdy2 = zcoef0 * r1_e2v(ji,jj) * REAL(jjs-jjd,dp) * (zpnss + zpnsd ) + zdpdy2 = zcoef0 * r1_e2v(ji,jj) * REAL(jjs-jjd, wp) * (zpnss + zpnsd ) ENDIF IF( ln_wd_il ) THEN zdpdy1 = zdpdy1 * zcpy(ji,jj) * wdrampv(ji,jj) @@ -1263,14 +1263,14 @@ CONTAINS !! !! Reference: CJC Kruger, Constrained Cubic Spline Interpoltation !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: fsp, xsp ! value and coordinate - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT( out) :: asp, bsp, csp, dsp ! coefficients of the interpoated function + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: fsp, xsp ! value and coordinate + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT( out) :: asp, bsp, csp, dsp ! coefficients of the interpoated function INTEGER , INTENT(in ) :: polynomial_type ! 1: cubic spline ; 2: Linear ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zdf1, zdf2, zddf1, zddf2, ztmp1, ztmp2, zdxtmp - REAL(dp) :: zdxtmp1, zdxtmp2, zalpha - REAL(dp), DIMENSION(jpk) :: zdf + REAL(wp) :: zdf1, zdf2, zddf1, zddf2, ztmp1, ztmp2, zdxtmp + REAL(wp) :: zdxtmp1, zdxtmp2, zalpha + REAL(wp), DIMENSION(jpk) :: zdf !!---------------------------------------------------------------------- ! IF (polynomial_type == 1) THEN ! Constrained Cubic Spline @@ -1355,9 +1355,10 @@ CONTAINS !! ** Method : interpolation is straight forward !! extrapolation is also permitted (no value limit) !!---------------------------------------------------------------------- - REAL(dp), INTENT(in) :: x, xl, xr, fl, fr - REAL(dp) :: f ! result of the interpolation (extrapolation) - REAL(dp) :: zdeltx + REAL(wp), INTENT(in) :: fl, fr + REAL(dp), INTENT(in) :: x, xl, xr + REAL(wp) :: f ! result of the interpolation (extrapolation) + REAL(wp) :: zdeltx !!---------------------------------------------------------------------- ! zdeltx = xr - xl @@ -1380,7 +1381,7 @@ CONTAINS !! !!---------------------------------------------------------------------- REAL(wp), INTENT(in) :: x, a, b, c, d - REAL(dp) :: f ! value from the interpolation + REAL(wp) :: f ! value from the interpolation !!---------------------------------------------------------------------- ! f = a + x* ( b + x * ( c + d * x ) ) @@ -1398,8 +1399,8 @@ CONTAINS !! ** Method : f=dy/dx=b+2*c*x+3*d*x^2 !! !!---------------------------------------------------------------------- - REAL(dp), INTENT(in) :: x, a, b, c, d - REAL(dp) :: f ! value from the interpolation + REAL(wp), INTENT(in) :: x, a, b, c, d + REAL(wp) :: f ! value from the interpolation !!---------------------------------------------------------------------- ! f = b + x * ( 2._wp * c + 3._wp * d * x) @@ -1416,9 +1417,9 @@ CONTAINS !! ** Method : integrate polynomial a+bx+cx^2+dx^3 from xl to xr !! !!---------------------------------------------------------------------- - REAL(dp), INTENT(in) :: xl, xr, a, b, c, d - REAL(dp) :: za1, za2, za3 - REAL(dp) :: f ! integration result + REAL(wp), INTENT(in) :: xl, xr, a, b, c, d + REAL(wp) :: za1, za2, za3 + REAL(wp) :: f ! integration result !!---------------------------------------------------------------------- ! za1 = 0.5_wp * b @@ -1431,4 +1432,4 @@ CONTAINS END FUNCTION integ_spline !!====================================================================== -END MODULE dynhpg +END MODULE dynhpg \ No newline at end of file diff --git a/src/OCE/DYN/dynkeg.F90 b/src/OCE/DYN/dynkeg.F90 index 9dcfd6976c181f6cb508e95c5b8458737b190417..3cbc60bf2e388cbb237128530afe0c05af68d55a 100644 --- a/src/OCE/DYN/dynkeg.F90 +++ b/src/OCE/DYN/dynkeg.F90 @@ -32,7 +32,7 @@ MODULE dynkeg INTEGER, PARAMETER, PUBLIC :: nkeg_C2 = 0 !: 2nd order centered scheme (standard scheme) INTEGER, PARAMETER, PUBLIC :: nkeg_HW = 1 !: Hollingsworth et al., QJRMS, 1983 ! - REAL(dp) :: r1_48 = 1._wp / 48._wp !: =1/(4*2*6) + REAL(wp) :: r1_48 = 1._wp / 48._wp !: =1/(4*2*6) !! * Substitutions # include "do_loop_substitute.h90" @@ -76,8 +76,8 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zu, zv ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zhke + REAL(wp) :: zu, zv ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zhke REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv !!---------------------------------------------------------------------- ! @@ -126,7 +126,7 @@ CONTAINS & ) ! bracket for halo 1 - halo 2 compatibility zhke(ji,jj,jk) = r1_48 * ( zv + zu ) END_3D - IF (nn_hls==1) CALL lbc_lnk( 'dynkeg', zhke, 'T', 1.0_dp ) + IF (nn_hls==1) CALL lbc_lnk( 'dynkeg', zhke, 'T', 1.0_wp ) ! END SELECT ! @@ -142,12 +142,12 @@ CONTAINS DEALLOCATE( ztrdu , ztrdv ) ENDIF ! - !IF(sn_cfctl%l_prtctl) !CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' keg - Ua: ', mask1=umask, & - ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' keg - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) ! IF( ln_timing ) CALL timing_stop('dyn_keg') ! END SUBROUTINE dyn_keg !!====================================================================== -END MODULE dynkeg +END MODULE dynkeg \ No newline at end of file diff --git a/src/OCE/DYN/dynldf.F90 b/src/OCE/DYN/dynldf.F90 index a9a21b881f0d9262d24c4a337de53aff3f157cd4..bfe4a4e510c6b5c37ea61ac2d8d6265b4a008c7b 100644 --- a/src/OCE/DYN/dynldf.F90 +++ b/src/OCE/DYN/dynldf.F90 @@ -80,7 +80,7 @@ CONTAINS ENDIF ! ! print sum trends (used for debugging) !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ldf - Ua: ', mask1=umask, & - ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) ! IF( ln_timing ) CALL timing_stop('dyn_ldf') ! @@ -113,4 +113,4 @@ CONTAINS END SUBROUTINE dyn_ldf_init !!====================================================================== -END MODULE dynldf +END MODULE dynldf \ No newline at end of file diff --git a/src/OCE/DYN/dynldf_iso.F90 b/src/OCE/DYN/dynldf_iso.F90 index f0dedb5dc3b39d9344c4cd0edf8ba769ec68fbb7..b036d6f6393545dd042d8b8d18e76fb7717d3214 100644 --- a/src/OCE/DYN/dynldf_iso.F90 +++ b/src/OCE/DYN/dynldf_iso.F90 @@ -37,7 +37,7 @@ MODULE dynldf_iso PUBLIC dyn_ldf_iso ! called by step.F90 PUBLIC dyn_ldf_iso_alloc ! called by nemogcm.F90 - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akzu, akzv !: vertical component of rotated lateral viscosity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akzu, akzv !: vertical component of rotated lateral viscosity !! * Substitutions # include "do_loop_substitute.h90" @@ -110,13 +110,13 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zabe1, zmskt, zmkt, zuav, zuwslpi, zuwslpj ! local scalars - REAL(dp) :: zabe2, zmskf, zmkf, zvav, zvwslpi, zvwslpj ! - - - REAL(dp) :: zcof0, zcof1, zcof2, zcof3, zcof4, zaht_0 ! - - - REAL(dp), DIMENSION(A2D(nn_hls)) :: ziut, zivf, zdku, zdk1u ! 2D workspace - REAL(dp), DIMENSION(A2D(nn_hls)) :: zjuf, zjvt, zdkv, zdk1v ! - - - REAL(dp), DIMENSION(A1Di(nn_hls),jpk) :: zfuw, zdiu, zdju, zdj1u ! - - - REAL(dp), DIMENSION(A1Di(nn_hls),jpk) :: zfvw, zdiv, zdjv, zdj1v ! - - + REAL(wp) :: zabe1, zmskt, zmkt, zuav, zuwslpi, zuwslpj ! local scalars + REAL(wp) :: zabe2, zmskf, zmkf, zvav, zvwslpi, zvwslpj ! - - + REAL(wp) :: zcof0, zcof1, zcof2, zcof3, zcof4, zaht_0 ! - - + REAL(wp), DIMENSION(A2D(nn_hls)) :: ziut, zivf, zdku, zdk1u ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls)) :: zjuf, zjvt, zdkv, zdk1v ! - - + REAL(wp), DIMENSION(A1Di(nn_hls),jpk) :: zfuw, zdiu, zdju, zdj1u ! - - + REAL(wp), DIMENSION(A1Di(nn_hls),jpk) :: zfvw, zdiv, zdjv, zdj1v ! - - !!---------------------------------------------------------------------- ! #if defined key_loop_fusion @@ -152,7 +152,7 @@ CONTAINS wslpj(ji,jj,jk) = - ( gdepw(ji,jj+1,jk,Kbb) - gdepw(ji,jj-1,jk,Kbb) ) * r1_e2t(ji,jj) * tmask(ji,jj,jk) * 0.5 END_3D ! Lateral boundary conditions on the slopes - IF (nn_hls == 1) CALL lbc_lnk( 'dynldf_iso', uslp , 'U', -1.0_dp, vslp , 'V', -1.0_dp, wslpi, 'W', -1.0_dp, wslpj, 'W', -1.0_dp ) + IF (nn_hls == 1) CALL lbc_lnk( 'dynldf_iso', uslp , 'U', -1.0_wp, vslp , 'V', -1.0_wp, wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) ! ENDIF @@ -303,7 +303,7 @@ CONTAINS ! print sum trends (used for debugging) !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ldfh - Ua: ', mask1=umask, & - !: & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) ! ! =============== @@ -420,4 +420,4 @@ CONTAINS END SUBROUTINE dyn_ldf_iso !!====================================================================== -END MODULE dynldf_iso +END MODULE dynldf_iso \ No newline at end of file diff --git a/src/OCE/DYN/dynldf_iso_lf.F90 b/src/OCE/DYN/dynldf_iso_lf.F90 index 5bf66371fc3e343d46dc3584c4482ca613dd8c95..e7a96697e34b85e3c0b90bb678b833358cf2f39e 100644 --- a/src/OCE/DYN/dynldf_iso_lf.F90 +++ b/src/OCE/DYN/dynldf_iso_lf.F90 @@ -34,7 +34,7 @@ MODULE dynldf_iso_lf PUBLIC dyn_ldf_iso_lf ! called by step.F90 PUBLIC dyn_ldf_iso_alloc_lf ! called by nemogcm.F90 - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akzu, akzv !: vertical component of rotated lateral viscosity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akzu, akzv !: vertical component of rotated lateral viscosity !! * Substitutions # include "do_loop_substitute.h90" @@ -104,19 +104,19 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT( in ) :: kt ! ocean time-step index INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices - REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zabe1, zmskt, zmkt, zuav, zuwslpi, zuwslpj ! local scalars - REAL(dp) :: zabe2, zmskf, zmkf, zvav, zvwslpi, zvwslpj ! - - - REAL(dp) :: zcof0, zcof1, zcof2, zcof3, zcof4, zaht_0 ! - - - REAL(dp) :: zdiu, zdiu_km1, zdiu_ip1, zdiu_ip1_km1 ! - - - REAL(dp) :: zdju, zdju_km1, zdj1u, zdj1u_km1 - REAL(dp) :: zdjv, zdjv_km1, zdj1v, zdj1v_km1 - REAL(dp) :: zdiv_im1_km1, zdiv, zdiv_im1, zdiv_km1 ! - - - REAL(dp), DIMENSION(A2D(nn_hls)) :: ziut, zivf, zdku, zdk1u ! 2D workspace - REAL(dp), DIMENSION(A2D(nn_hls)) :: zjuf, zjvt, zdkv, zdk1v ! - - - REAL(dp), DIMENSION(A1Di(nn_hls),jpk) :: zfuw, zfvw + REAL(wp) :: zabe1, zmskt, zmkt, zuav, zuwslpi, zuwslpj ! local scalars + REAL(wp) :: zabe2, zmskf, zmkf, zvav, zvwslpi, zvwslpj ! - - + REAL(wp) :: zcof0, zcof1, zcof2, zcof3, zcof4, zaht_0 ! - - + REAL(wp) :: zdiu, zdiu_km1, zdiu_ip1, zdiu_ip1_km1 ! - - + REAL(wp) :: zdju, zdju_km1, zdj1u, zdj1u_km1 + REAL(wp) :: zdjv, zdjv_km1, zdj1v, zdj1v_km1 + REAL(wp) :: zdiv_im1_km1, zdiv, zdiv_im1, zdiv_km1 ! - - + REAL(wp), DIMENSION(A2D(nn_hls)) :: ziut, zivf, zdku, zdk1u ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls)) :: zjuf, zjvt, zdkv, zdk1v ! - - + REAL(wp), DIMENSION(A1Di(nn_hls),jpk) :: zfuw, zfvw !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -287,7 +287,7 @@ CONTAINS ! print sum trends (used for debugging) !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ldfh - Ua: ', mask1=umask, & - ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) ! ! =============== @@ -398,4 +398,4 @@ CONTAINS END SUBROUTINE dyn_ldf_iso_lf !!====================================================================== -END MODULE dynldf_iso_lf +END MODULE dynldf_iso_lf \ No newline at end of file diff --git a/src/OCE/DYN/dynldf_lap_blp.F90 b/src/OCE/DYN/dynldf_lap_blp.F90 index c12c29c97a68e26099f026d088adab9e80966ef7..b67f70cae5c6ed3f2efabf46b41f689fe1ddab9c 100644 --- a/src/OCE/DYN/dynldf_lap_blp.F90 +++ b/src/OCE/DYN/dynldf_lap_blp.F90 @@ -81,10 +81,10 @@ CONTAINS ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: iij - REAL(dp) :: zsign ! local scalars - REAL(dp) :: zua, zva ! local scalars - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zcur, zdiv - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zten, zshe ! tension (diagonal) and shearing (anti-diagonal) terms + REAL(wp) :: zsign ! local scalars + REAL(wp) :: zua, zva ! local scalars + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zcur, zdiv + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zten, zshe ! tension (diagonal) and shearing (anti-diagonal) terms !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile diff --git a/src/OCE/DYN/dynldf_lap_blp_lf.F90 b/src/OCE/DYN/dynldf_lap_blp_lf.F90 index 4be668d6c23fa99cf12503baf0008515e9a7806d..a7be529e7afe1a9b7338d87c2c9437c86faac8ab 100644 --- a/src/OCE/DYN/dynldf_lap_blp_lf.F90 +++ b/src/OCE/DYN/dynldf_lap_blp_lf.F90 @@ -29,7 +29,6 @@ MODULE dynldf_lap_blp_lf !! * Substitutions # include "do_loop_substitute.h90" -# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -44,7 +43,7 @@ CONTAINS INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pu, pv ! before velocity [m/s] - REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2] + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2] !! CALL dyn_ldf_lap_lf_t( kt, Kbb, Kmm, pu, pv, is_tile(pu), pu_rhs, pv_rhs, is_tile(pu_rhs), kpass ) @@ -69,14 +68,14 @@ CONTAINS INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage INTEGER , INTENT(in ) :: ktuv, ktuv_rhs REAL(wp), DIMENSION(A2D_T(ktuv) ,JPK), INTENT(in ) :: pu, pv ! before velocity [m/s] - REAL(dp), DIMENSION(A2D_T(ktuv_rhs),JPK), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2] + REAL(wp), DIMENSION(A2D_T(ktuv_rhs),JPK), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2] ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: iij - REAL(dp) :: zsign ! local scalars - REAL(dp) :: zcur, zcur_im1, zcur_jm1 ! local scalars - REAL(dp) :: zdiv, zdiv_ip1, zdiv_jp1 ! local scalars - REAL(dp) :: zten, zten_ip1, zten_jp1, zshe, zshe_im1, zshe_jm1 ! tension (diagonal) and shearing (anti-diagonal) terms + REAL(wp) :: zsign ! local scalars + REAL(wp) :: zcur, zcur_im1, zcur_jm1 ! local scalars + REAL(wp) :: zdiv, zdiv_ip1, zdiv_jp1 ! local scalars + REAL(wp) :: zten, zten_ip1, zten_jp1, zshe, zshe_im1, zshe_jm1 ! tension (diagonal) and shearing (anti-diagonal) terms !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -202,9 +201,9 @@ CONTAINS INTEGER , INTENT(in ) :: kt ! ocean time-step index INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu, pv ! before velocity fields - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! momentum trend + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! momentum trend ! - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zulap, zvlap ! laplacian at u- and v-point + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zulap, zvlap ! laplacian at u- and v-point !!---------------------------------------------------------------------- ! IF( kt == nit000 ) THEN @@ -218,7 +217,7 @@ CONTAINS ! CALL dyn_ldf_lap_lf( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 ) ! rotated laplacian applied to pt (output in zlap,Kbb) ! - CALL dyn_ldf_lap_lf( kt, Kbb, Kmm, CASTSP(zulap), CASTSP(zvlap), pu_rhs, pv_rhs, 2 ) ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs)) + CALL dyn_ldf_lap_lf( kt, Kbb, Kmm, zulap, zvlap, pu_rhs, pv_rhs, 2 ) ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs)) ! END SUBROUTINE dyn_ldf_blp_lf diff --git a/src/OCE/DYN/dynspg.F90 b/src/OCE/DYN/dynspg.F90 index d499913bc7010d056f3505ce627951a6ae9ecaec..8b7f4c59c4f91a16820718f2ee678b84d02c08ed 100644 --- a/src/OCE/DYN/dynspg.F90 +++ b/src/OCE/DYN/dynspg.F90 @@ -45,7 +45,7 @@ MODULE dynspg INTEGER, PARAMETER :: np_EXP = 0 ! explicit time stepping INTEGER, PARAMETER :: np_NO =-1 ! no surface pressure gradient, no scheme ! - REAL(dp) :: zt0step ! Time of day at the beginning of the time step + REAL(wp) :: zt0step ! Time of day at the beginning of the time step !! * Substitutions # include "do_loop_substitute.h90" @@ -77,13 +77,14 @@ CONTAINS INTEGER , INTENT( in ) :: kt ! ocean time-step index INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation - REAL(dp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: pssh, puu_b, pvv_b ! SSH and barotropic velocities at main time levels + REAL(wp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: puu_b, pvv_b! SSH and barotropic velocities at main time levels + REAL(dp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: pssh! SSH and barotropic velocities at main time levels INTEGER , OPTIONAL , INTENT( in ) :: k_only_ADV ! only Advection in the RHS ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: z2dt, zg_2, zintp, zgrho0r, zld ! local scalars - REAL(dp) , DIMENSION(jpi,jpj) :: zpgu, zpgv ! 2D workspace - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zpice + REAL(wp) :: z2dt, zg_2, zintp, zgrho0r, zld ! local scalars + REAL(wp) , DIMENSION(jpi,jpj) :: zpgu, zpgv ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zpice REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv !!---------------------------------------------------------------------- ! @@ -119,7 +120,7 @@ CONTAINS IF( .NOT.ln_dynspg_ts .AND. ( ln_tide_pot .AND. ln_tide ) ) THEN ! N.B. added directly at sub-time-step in ts-case ! ! Update tide potential at the beginning of current time step - zt0step = REAL(nsec_day, dp)-0.5_dp*rn_Dt + zt0step = REAL(nsec_day, wp)-0.5_wp*rn_Dt CALL upd_tide(zt0step, Kmm) ! DO_2D( 0, 0, 0, 0 ) ! add tide potential forcing @@ -177,7 +178,7 @@ CONTAINS ENDIF ! ! print mean trends (used for debugging) !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' spg - Ua: ', mask1=umask, & - ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) ! IF( ln_timing ) CALL timing_stop('dyn_spg') ! @@ -240,4 +241,4 @@ CONTAINS END SUBROUTINE dyn_spg_init !!====================================================================== -END MODULE dynspg +END MODULE dynspg \ No newline at end of file diff --git a/src/OCE/DYN/dynspg_exp.F90 b/src/OCE/DYN/dynspg_exp.F90 index 624f32c8d2e53c77374e9f1686c72701cd87a4a6..ccbb111e116591d522ae8bc1212ddffb5c934164 100644 --- a/src/OCE/DYN/dynspg_exp.F90 +++ b/src/OCE/DYN/dynspg_exp.F90 @@ -59,7 +59,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation !! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp), DIMENSION(jpi,jpj) :: zpgu, zpgv ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zpgu, zpgv ! 2D workspace !!---------------------------------------------------------------------- ! IF( kt == nit000 ) THEN diff --git a/src/OCE/DYN/dynspg_ts.F90 b/src/OCE/DYN/dynspg_ts.F90 index f7c8ee7c4d9779399bddd718aaea1cdf230eba3f..369782f00a9cea6330d438ce78c9c126d18370c5 100644 --- a/src/OCE/DYN/dynspg_ts.F90 +++ b/src/OCE/DYN/dynspg_ts.F90 @@ -69,23 +69,25 @@ MODULE dynspg_ts PUBLIC dyn_spg_ts_init ! - - dyn_spg_init !! Time filtered arrays at baroclinic time step: - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_adv , vn_adv !: Advection vel. at HMWVK barocl. step + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_adv , vn_adv !: Advection vel. at "now" barocl. step ! INTEGER, SAVE :: icycle ! Number of barotropic sub-steps for each internal step nn_e <= 2.5 nn_e REAL(dp),SAVE :: rDt_e ! Barotropic time step ! - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:) :: wgtbtp1, wgtbtp2 ! 1st & 2nd weights used in time filtering of barotropic fields - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zwz ! ff_f/h at F points - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftnw, ftne ! triad of coriolis parameter - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftsw, ftse ! (only used with een vorticity scheme) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: wgtbtp2! 1st & 2nd weights used in time filtering of barotropic fields + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:) :: wgtbtp1! 1st & 2nd weights used in time filtering of barotropic fields + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zwz ! ff_f/h at F points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftnw, ftne ! triad of coriolis parameter + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftsw, ftse ! (only used with een vorticity scheme) - REAL(dp) :: r1_12 = 1._wp / 12._wp ! local ratios - REAL(dp) :: r1_8 = 0.125_wp ! - REAL(dp) :: r1_4 = 0.25_wp ! - REAL(dp) :: r1_2 = 0.5_wp ! + REAL(wp) :: r1_12 = 1._wp / 12._wp ! local ratios + REAL(wp) :: r1_8 = 0.125_wp ! + REAL(wp) :: r1_4 = 0.25_wp ! + REAL(wp) :: r1_2 = 0.5_wp ! !! * Substitutions # include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -144,37 +146,41 @@ CONTAINS INTEGER , INTENT( in ) :: kt ! ocean time-step index INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation - REAL(dp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: pssh, puu_b, pvv_b ! SSH and barotropic velocities at main time levels + REAL(wp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: puu_b, pvv_b! SSH and barotropic velocities at main time levels + REAL(dp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: pssh! SSH and barotropic velocities at main time levels INTEGER , OPTIONAL , INTENT( in ) :: k_only_ADV ! only Advection in the RHS ! INTEGER :: ji, jj, jk, jn ! dummy loop indices LOGICAL :: ll_fw_start ! =T : forward integration LOGICAL :: ll_init ! =T : special startup of 2d equations INTEGER :: noffset ! local integers : time offset for bdy update - REAL(dp) :: r1_Dt_b, z1_hu, z1_hv ! local scalars - REAL(dp) :: za0, za1, za2, za3 ! - - - REAL(dp) :: zztmp, zldg ! - - - REAL(dp) :: zhu_bck, zhv_bck, zhdiv ! - - - REAL(dp) :: zun_save, zvn_save ! - - - REAL(dp), DIMENSION(jpi,jpj) :: zu_trd, zu_frc, zu_spg - REAL(dp), DIMENSION(jpi,jpj) :: zv_trd, zv_frc, zv_spg - REAL(dp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhtp2_e - REAL(dp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zsshp2_e - REAL(dp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v ! top/bottom stress at u- & v-points - REAL(dp), DIMENSION(jpi,jpj) :: zhU, zhV ! fluxes + REAL(wp) :: r1_Dt_b, z1_hu, z1_hv ! local scalars + REAL(wp) :: za0, za2, za3! - - + REAL(dp) :: za1! - - + REAL(wp) :: zztmp, zldg ! - - + REAL(wp) :: zhu_bck, zhv_bck! - - + REAL(dp) :: zhdiv! - - + REAL(wp) :: zun_save, zvn_save ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zu_trd, zu_frc, zu_spg + REAL(wp), DIMENSION(jpi,jpj) :: zv_trd, zv_frc, zv_spg + REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhtp2_e + REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zsshp2_e + REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v ! top/bottom stress at u- & v-points + REAL(wp), DIMENSION(jpi,jpj) :: zhV! fluxes + REAL(dp), DIMENSION(jpi,jpj) :: zhU! fluxes !!st#if defined key_qco !!st REAL(wp), DIMENSION(jpi, jpj, jpk) :: ze3u, ze3v !!st#endif ! - REAL(dp) :: zwdramp ! local scalar - only used if ln_wd_dl = .True. + REAL(wp) :: zwdramp ! local scalar - only used if ln_wd_dl = .True. INTEGER :: iwdg, jwdg, kwdg ! short-hand values for the indices of the output point - REAL(dp) :: zepsilon, zgamma ! - - - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zcpx, zcpy ! Wetting/Dying gravity filter coef. - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: ztwdmask, zuwdmask, zvwdmask ! ROMS wetting and drying masks at t,u,v points - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: zuwdav2, zvwdav2 ! averages over the sub-steps of zuwdmask and zvwdmask - REAL(dp) :: zt0substep ! Time of day at the beginning of the time substep + REAL(wp) :: zepsilon, zgamma ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zcpx, zcpy ! Wetting/Dying gravity filter coef. + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztwdmask, zuwdmask, zvwdmask ! ROMS wetting and drying masks at t,u,v points + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zuwdav2, zvwdav2 ! averages over the sub-steps of zuwdmask and zvwdmask + REAL(wp) :: zt0substep ! Time of day at the beginning of the time substep !!---------------------------------------------------------------------- ! IF( ln_wd_il ) ALLOCATE( zcpx(jpi,jpj), zcpy(jpi,jpj) ) @@ -259,7 +265,7 @@ CONTAINS zhU(:,:) = puu_b(:,:,Kmm) * hu(:,:,Kmm) * e2u(:,:) ! now fluxes zhV(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:) ! NB: FULL domain : put a value in last row and column ! - CALL dyn_cor_2d( ht(:,:), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in + CALL dyn_cor_2d( CASTSP(ht(:,:)), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in & zu_trd, zv_trd ) ! ==>> out ! DO_2D( 0, 0, 0, 0 ) ! Remove coriolis term (and possibly spg) from barotropic trend @@ -425,10 +431,10 @@ CONTAINS ! ! !== Update the forcing ==! (BDY and tides) ! - IF( ln_bdy .AND. ln_tide ) CALL bdy_dta_tides( kt, kit=jn, pt_offset= REAL(noffset+1,dp) ) + IF( ln_bdy .AND. ln_tide ) CALL bdy_dta_tides( kt, kit=jn, pt_offset= REAL(noffset+1,wp) ) ! Update tide potential at the beginning of current time substep IF( ln_tide_pot .AND. ln_tide ) THEN - zt0substep = REAL(nsec_day, dp) - 0.5_dp*rn_Dt + (jn + noffset - 1) * rn_Dt / REAL(nn_e, dp) + zt0substep = REAL(nsec_day, wp) - 0.5_wp*rn_Dt + (jn + noffset - 1) * rn_Dt / REAL(nn_e, wp) CALL upd_tide(zt0substep, Kmm) END IF ! @@ -527,7 +533,8 @@ CONTAINS ssha_e(ji,jj) = ( sshn_e(ji,jj) - rDt_e * ( ssh_frc(ji,jj) + zhdiv ) ) * ssmask(ji,jj) END_2D ! - CALL lbc_lnk( 'dynspg_ts', ssha_e, 'T', 1._dp, zhU, 'U', -1._dp, zhV, 'V', -1._dp ) + CALL lbc_lnk( 'dynspg_ts', ssha_e, 'T', 1._dp, zhU, 'U', -1._dp) + CALL lbc_lnk( 'dynspg_ts', zhV, 'V', -1._wp ) ! ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) IF( ln_bdy ) CALL bdy_ssh( ssha_e ) @@ -688,11 +695,11 @@ CONTAINS ENDIF ! IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) - CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._dp, va_e , 'V', -1._dp & - & , hu_e , 'U', 1._dp, hv_e , 'V', 1._dp & - & , hur_e, 'U', 1._dp, hvr_e, 'V', 1._dp ) + CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp & + & , hu_e , 'U', 1._wp, hv_e , 'V', 1._wp & + & , hur_e, 'U', 1._wp, hvr_e, 'V', 1._wp ) ELSE - CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._dp, va_e , 'V', -1._dp ) + CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp ) ENDIF ! ! open boundaries IF( ln_bdy ) CALL bdy_dyn2d( jn, ua_e, va_e, un_e, vn_e, hur_e, hvr_e, ssha_e ) @@ -786,7 +793,7 @@ CONTAINS & + e1e2t(ji,jj+1) * pssh(ji,jj+1,Kaa) ) * ssvmask(ji,jj) END_2D #endif - CALL lbc_lnk( 'dynspg_ts', zsshu_a, 'U', 1._dp, zsshv_a, 'V', 1._dp ) ! Boundary conditions + CALL lbc_lnk( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions ! DO jk=1,jpkm1 puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + r1_hu(:,:,Kmm) & @@ -829,7 +836,7 @@ CONTAINS vb2_i_b(:,:) = 0._wp END IF ! - za1 = 1._dp / REAL(Agrif_rhot(), dp) + za1 = 1._wp / REAL(Agrif_rhot(), wp) ub2_i_b(:,:) = ub2_i_b(:,:) + za1 * ub2_b(:,:) vb2_i_b(:,:) = vb2_i_b(:,:) + za1 * vb2_b(:,:) ENDIF @@ -855,11 +862,13 @@ CONTAINS LOGICAL, INTENT(in) :: ll_av ! temporal averaging=.true. LOGICAL, INTENT(in) :: ll_fw ! forward time splitting =.true. INTEGER, INTENT(inout) :: jpit ! cycle length - REAL(dp), DIMENSION(3*nn_e), INTENT(inout) :: zwgt1, zwgt2 + REAL(wp), DIMENSION(3*nn_e), INTENT(inout) :: zwgt2 + REAL(dp), DIMENSION(3*nn_e), INTENT(inout) :: zwgt1 INTEGER :: jic, jn, ji ! temporary integers - REAL(dp) :: za1, za2 + REAL(wp) :: za2 + REAL(dp) :: za1 !!---------------------------------------------------------------------- zwgt1(:) = 0._wp @@ -1004,8 +1013,8 @@ CONTAINS !! ** Purpose : Set time splitting options !!---------------------------------------------------------------------- INTEGER :: ji ,jj ! dummy loop indices - REAL(dp) :: zxr2, zyr2, zcmax ! local scalar - REAL(dp), DIMENSION(jpi,jpj) :: zcu + REAL(wp) :: zxr2, zyr2, zcmax ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zcu !!---------------------------------------------------------------------- ! ! Max courant number for ext. grav. waves @@ -1103,7 +1112,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: Kmm ! Time index INTEGER :: ji ,jj, jk ! dummy loop indices - REAL(dp) :: z1_ht + REAL(wp) :: z1_ht !!---------------------------------------------------------------------- ! SELECT CASE( nvor_scheme ) @@ -1124,7 +1133,7 @@ CONTAINS IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) END_2D END SELECT - CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._dp ) + CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) END SELECT ! SELECT CASE( nvor_scheme ) @@ -1160,9 +1169,10 @@ CONTAINS !! ** Purpose : Compute u and v coriolis trends !!---------------------------------------------------------------------- INTEGER :: ji ,jj ! dummy loop indices - REAL(dp) :: zx1, zx2, zy1, zy2, z1_hu, z1_hv ! - - - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pht, phu, phv, punb, pvnb, zhU, zhV - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: zu_trd, zv_trd + REAL(wp) :: zx1, zx2, zy1, zy2, z1_hu, z1_hv ! - - + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pht, phu, phv, punb, pvnb, zhV + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: zhU + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: zu_trd, zv_trd !!---------------------------------------------------------------------- SELECT CASE( nvor_scheme ) CASE( np_ENT ) ! enstrophy conserving scheme (f-point) @@ -1227,8 +1237,8 @@ CONTAINS !! !! ** Action : ptmsk : wetting & drying t-mask !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh ! - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: ptmsk ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh ! + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: ptmsk ! ! INTEGER :: ji, jj ! dummy loop indices !!---------------------------------------------------------------------- @@ -1266,9 +1276,10 @@ CONTAINS !! !! ** Action : ptmsk : wetting & drying t-mask !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pTmsk ! W & D t-mask - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: phU, phV, pu, pv ! ocean velocities and transports - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: pUmsk, pVmsk ! W & D u- and v-mask + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pTmsk ! W & D t-mask + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phV, pu, pv! ocean velocities and transports + REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: phU! ocean velocities and transports + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pUmsk, pVmsk ! W & D u- and v-mask ! INTEGER :: ji, jj ! dummy loop indices !!---------------------------------------------------------------------- @@ -1300,8 +1311,8 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: ji ,jj ! dummy loop indices LOGICAL :: ll_tmp1, ll_tmp2 - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pshn - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pshn + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy !!---------------------------------------------------------------------- DO_2D( 0, 0, 0, 0 ) ll_tmp1 = MIN( pshn(ji,jj) , pshn(ji+1,jj) ) > & @@ -1357,14 +1368,14 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(in ) :: puu, pvv ! ocean velocities and RHS of momentum equation - REAL(dp), DIMENSION(jpi,jpj,jpt) , INTENT(in ) :: puu_b, pvv_b ! barotropic velocities at main time levels - REAL(dp), DIMENSION(jpi,jpj) , INTENT(inout) :: pu_RHSi, pv_RHSi ! baroclinic part of the barotropic RHS - REAL(dp), DIMENSION(jpi,jpj) , INTENT( out) :: pCdU_u , pCdU_v ! barotropic drag coefficients + REAL(wp), DIMENSION(jpi,jpj,jpt) , INTENT(in ) :: puu_b, pvv_b ! barotropic velocities at main time levels + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: pu_RHSi, pv_RHSi ! baroclinic part of the barotropic RHS + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pCdU_u , pCdU_v ! barotropic drag coefficients ! INTEGER :: ji, jj ! dummy loop indices INTEGER :: ikbu, ikbv, iktu, iktv - REAL(dp) :: zztmp - REAL(dp), DIMENSION(jpi,jpj) :: zu_i, zv_i + REAL(wp) :: zztmp + REAL(wp), DIMENSION(jpi,jpj) :: zu_i, zv_i !!---------------------------------------------------------------------- ! ! !== Set the barotropic drag coef. ==! @@ -1456,9 +1467,10 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER ,INTENT(in ) :: jn ! index of sub time step LOGICAL ,INTENT(in ) :: ll_init ! - REAL(dp),INTENT( out) :: za0, za1, za2, za3 ! Half-step back interpolation coefficient + REAL(wp),INTENT( out) :: za0, za2, za3! Half-step back interpolation coefficient + REAL(dp),INTENT( out) :: za1! Half-step back interpolation coefficient ! - REAL(dp) :: zepsilon, zgamma ! - - + REAL(wp) :: zepsilon, zgamma ! - - !!---------------------------------------------------------------------- ! ! set Half-step back interpolation coefficient IF ( jn==1 .AND. ll_init ) THEN !* Forward-backward diff --git a/src/OCE/DYN/dynvor.F90 b/src/OCE/DYN/dynvor.F90 index 1b8c0a96cee159f85ebc6f1a11978d2a3d4f1be1..2f03ce67bf5e130ce8c40ce0ea68a703f1feaff6 100644 --- a/src/OCE/DYN/dynvor.F90 +++ b/src/OCE/DYN/dynvor.F90 @@ -81,16 +81,16 @@ MODULE dynvor INTEGER, PUBLIC, PARAMETER :: np_CRV = 4 ! relative + planetary (total vorticity) INTEGER, PUBLIC, PARAMETER :: np_CME = 5 ! Coriolis + metric term - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: di_e2u_2 ! = di(e2u)/2 used in T-point metric term calculation - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1v_2 ! = dj(e1v)/2 - - - - - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2u)/(2*e1e2f) used in F-point metric term calculation - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1v)/(2*e1e2f) - - - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2u_2 ! = di(e2u)/2 used in T-point metric term calculation + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1v_2 ! = dj(e1v)/2 - - - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2u)/(2*e1e2f) used in F-point metric term calculation + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1v)/(2*e1e2f) - - - - ! - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: e3f_0vor ! e3f used in EEN, ENE and ENS cases (key_qco only) + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: e3f_0vor ! e3f used in EEN, ENE and ENS cases (key_qco only) - REAL(dp) :: r1_4 = 0.250_wp ! =1/4 - REAL(dp) :: r1_8 = 0.125_wp ! =1/8 - REAL(dp) :: r1_12 = 1._wp / 12._wp ! 1/12 + REAL(wp) :: r1_4 = 0.250_wp ! =1/4 + REAL(wp) :: r1_8 = 0.125_wp ! =1/8 + REAL(wp) :: r1_12 = 1._wp / 12._wp ! 1/12 !! * Substitutions # include "do_loop_substitute.h90" @@ -205,8 +205,8 @@ CONTAINS ENDIF ! ! ! print sum trends (used for debugging) - !IF(sn_cfctl%l_prtctl) !CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' vor - Ua: ', mask1=umask, & - ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' vor - Ua: ', mask1=umask, & + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) ! IF( ln_timing ) CALL timing_stop('dyn_vor') ! @@ -238,9 +238,9 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zx1, zy1, zx2, zy2 ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwt ! 2D workspace - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined + REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwt ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -267,7 +267,7 @@ CONTAINS END_2D ENDIF END DO - IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_dp ) + IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) ! END SELECT @@ -358,8 +358,8 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zx1, zy1, zx2, zy2, ze3f, zmsk ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwz ! 2D workspace + REAL(wp) :: zx1, zy1, zx2, zy2, ze3f, zmsk ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwz ! 2D workspace !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -491,8 +491,8 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zuav, zvau, ze3f, zmsk ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwz ! 2D workspace + REAL(wp) :: zuav, zvau, ze3f, zmsk ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwz ! 2D workspace !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -622,21 +622,18 @@ CONTAINS ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ierr ! local integer - REAL(dp) :: zua, zva ! local scalars - REAL(dp) :: zmsk, ze3f ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls)) :: z1_e3f + REAL(wp) :: zua, zva ! local scalars + REAL(wp) :: zmsk, ze3f ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: z1_e3f #if defined key_loop_fusion - REAL(wp) :: ztnw_ip1, ztse_jp1, ztsw_jp1, ztsw_ip1 - REAL(dp) :: ztnw, ztne, ztse - REAL(wp) :: zwx_im1, zwx_jp1, zwx_im1_jp1 - REAL(dp) :: zwx - REAL(wp) :: zwy_ip1, zwy_jm1, zwy_ip1_jm1 - REAL(dp) :: zwy + REAL(wp) :: ztne, ztnw, ztnw_ip1, ztse, ztse_jp1, ztsw_jp1, ztsw_ip1 + REAL(wp) :: zwx, zwx_im1, zwx_jp1, zwx_im1_jp1 + REAL(wp) :: zwy, zwy_ip1, zwy_jm1, zwy_ip1_jm1 #else REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx , zwy - REAL(dp), DIMENSION(A2D(nn_hls)) :: ztnw, ztne, ztsw, ztse + REAL(wp), DIMENSION(A2D(nn_hls)) :: ztnw, ztne, ztsw, ztse #endif - REAL(dp), DIMENSION(A2D(nn_hls),jpkm1) :: zwz ! 3D workspace, jpkm1 -> jpkm1 -> avoid lbc_lnk on jpk that is not defined + REAL(wp), DIMENSION(A2D(nn_hls),jpkm1) :: zwz ! 3D workspace, jpkm1 -> jpkm1 -> avoid lbc_lnk on jpk that is not defined !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -734,7 +731,7 @@ CONTAINS END DO ! End of slab ! ! =============== ! - IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_dp ) + IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) ! ! ! =============== ! ! Horizontal slab @@ -824,11 +821,11 @@ CONTAINS ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ierr ! local integer - REAL(dp) :: zua, zva ! local scalars - REAL(dp) :: zmsk, z1_e3t ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls)) :: zwx , zwy - REAL(dp), DIMENSION(A2D(nn_hls)) :: ztnw, ztne, ztsw, ztse - REAL(dp), DIMENSION(A2D(nn_hls),jpkm1) :: zwz ! 3D workspace, avoid lbc_lnk on jpk that is not defined + REAL(wp) :: zua, zva ! local scalars + REAL(wp) :: zmsk, z1_e3t ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx , zwy + REAL(wp), DIMENSION(A2D(nn_hls)) :: ztnw, ztne, ztsw, ztse + REAL(wp), DIMENSION(A2D(nn_hls),jpkm1) :: zwz ! 3D workspace, avoid lbc_lnk on jpk that is not defined !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -893,7 +890,7 @@ CONTAINS END DO ! End of slab ! ! =============== ! - IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_dp ) + IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) ! ! ! =============== DO jk = 1, jpkm1 ! Horizontal slab @@ -937,7 +934,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ioptio, ios ! local integer - REAL(dp) :: zmsk ! local scalars + REAL(wp) :: zmsk ! local scalars !! NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_enT, ln_dynvor_eeT, & & ln_dynvor_een, nn_e3f_typ , ln_dynvor_mix, ln_dynvor_msk @@ -1016,7 +1013,7 @@ CONTAINS di_e2u_2(ji,jj) = ( e2u(ji,jj) - e2u(ji-1,jj ) ) * 0.5_wp dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji ,jj-1) ) * 0.5_wp END_2D - CALL lbc_lnk( 'dynvor', di_e2u_2, 'T', -1.0_dp , dj_e1v_2, 'T', -1.0_dp ) ! Lateral boundary conditions + CALL lbc_lnk( 'dynvor', di_e2u_2, 'T', -1.0_wp , dj_e1v_2, 'T', -1.0_wp ) ! Lateral boundary conditions ! CASE DEFAULT !* F-point metric term : pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f) ALLOCATE( di_e2v_2e1e2f(jpi,jpj), dj_e1u_2e1e2f(jpi,jpj) ) @@ -1024,7 +1021,7 @@ CONTAINS di_e2v_2e1e2f(ji,jj) = ( e2v(ji+1,jj ) - e2v(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj) dj_e1u_2e1e2f(ji,jj) = ( e1u(ji ,jj+1) - e1u(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj) END_2D - CALL lbc_lnk( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_dp , dj_e1u_2e1e2f, 'F', -1.0_dp ) ! Lateral boundary conditions + CALL lbc_lnk( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp ) ! Lateral boundary conditions END SELECT ! END SELECT @@ -1057,7 +1054,7 @@ CONTAINS END_3D END SELECT ! - CALL lbc_lnk( 'dynvor', e3f_0vor, 'F', 1._dp ) + CALL lbc_lnk( 'dynvor', e3f_0vor, 'F', 1._wp ) ! ! insure e3f_0vor /= 0 WHERE( e3f_0vor(:,:,:) == 0._wp ) e3f_0vor(:,:,:) = e3f_0(:,:,:) ! @@ -1080,4 +1077,4 @@ CONTAINS END SUBROUTINE dyn_vor_init !!============================================================================== -END MODULE dynvor +END MODULE dynvor \ No newline at end of file diff --git a/src/OCE/DYN/dynzad.F90 b/src/OCE/DYN/dynzad.F90 index 09340bc5269dbc1c7dfca4b69d651883a7da6a30..db5c39f6b08e467b3225643a02a43d7848c69886 100644 --- a/src/OCE/DYN/dynzad.F90 +++ b/src/OCE/DYN/dynzad.F90 @@ -58,9 +58,9 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zua, zva ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls)) :: zww - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwuw, zwvw + REAL(wp) :: zua, zva ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zww + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwuw, zwvw REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv !!---------------------------------------------------------------------- ! @@ -118,11 +118,11 @@ CONTAINS ENDIF ! ! Control print !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' zad - Ua: ', mask1=umask, & - ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) ! IF( ln_timing ) CALL timing_stop('dyn_zad') ! END SUBROUTINE dyn_zad !!====================================================================== -END MODULE dynzad +END MODULE dynzad \ No newline at end of file diff --git a/src/OCE/DYN/dynzdf.F90 b/src/OCE/DYN/dynzdf.F90 index f4f14c72ba1d6a1959b2d9c94c91231e7dbdc2af..a970d704d0fbc9dec1db7d2b204fc236d96444eb 100644 --- a/src/OCE/DYN/dynzdf.F90 +++ b/src/OCE/DYN/dynzdf.F90 @@ -37,7 +37,7 @@ MODULE dynzdf PUBLIC dyn_zdf ! routine called by step.F90 - REAL(dp) :: r_vvl ! non-linear free surface indicator: =0 if ln_linssh=T, =1 otherwise + REAL(wp) :: r_vvl ! non-linear free surface indicator: =0 if ln_linssh=T, =1 otherwise !! * Substitutions # include "do_loop_substitute.h90" @@ -75,13 +75,13 @@ CONTAINS ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: iku, ikv ! local integers - REAL(dp) :: zzwi, ze3ua, zdt ! local scalars - REAL(dp) :: zzws, ze3va ! - - - REAL(dp) :: z1_e3ua, z1_e3va ! - - - REAL(dp) :: zWu , zWv ! - - - REAL(dp) :: zWui, zWvi ! - - - REAL(dp) :: zWus, zWvs ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwd, zws ! 3D workspace + REAL(wp) :: zzwi, ze3ua, zdt ! local scalars + REAL(wp) :: zzws, ze3va ! - - + REAL(wp) :: z1_e3ua, z1_e3va ! - - + REAL(wp) :: zWu , zWv ! - - + REAL(wp) :: zWui, zWvi ! - - + REAL(wp) :: zWus, zWvs ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwd, zws ! 3D workspace REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv ! - - !!--------------------------------------------------------------------- ! @@ -444,11 +444,11 @@ CONTAINS ENDIF ! ! print mean trends (used for debugging) !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' zdf - Ua: ', mask1=umask, & - ! & tab3d_2=pvv(:,:,:,Kaa), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! & tab3d_2=pvv(:,:,:,Kaa), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) ! IF( ln_timing ) CALL timing_stop('dyn_zdf') ! END SUBROUTINE dyn_zdf !!============================================================================== -END MODULE dynzdf +END MODULE dynzdf \ No newline at end of file diff --git a/src/OCE/DYN/sshwzv.F90 b/src/OCE/DYN/sshwzv.F90 index 978ffb5f6e2a39cf07c8b5e2f6fac9a4e30f14e0..0ecd399f84ca87030e0cdf5d02322cd30d351607 100644 --- a/src/OCE/DYN/sshwzv.F90 +++ b/src/OCE/DYN/sshwzv.F90 @@ -78,8 +78,8 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpt), INTENT(inout) :: pssh ! sea-surface height ! INTEGER :: ji, jj, jk ! dummy loop index - REAL(dp) :: zcoef ! local scalar - REAL(dp), DIMENSION(jpi,jpj) :: zhdiv ! 2D workspace + REAL(wp) :: zcoef ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zhdiv ! 2D workspace !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('ssh_nxt') @@ -154,10 +154,10 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: kt ! time step INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! time level indices - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pww ! vertical velocity at Kmm + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pww ! vertical velocity at Kmm ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zhdiv + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zhdiv !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('wzv') @@ -185,7 +185,7 @@ CONTAINS zhdiv(ji,jj,jk) = r1_e1e2t(ji,jj) * ( un_td(ji,jj,jk) - un_td(ji-1,jj,jk) + vn_td(ji,jj,jk) - vn_td(ji,jj-1,jk) ) END_2D END DO - IF( nn_hls == 1) CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.0_dp) ! - ML - Perhaps not necessary: not used for horizontal "connexions" + IF( nn_hls == 1) CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.0_wp) ! - ML - Perhaps not necessary: not used for horizontal "connexions" ! ! Is it problematic to have a wrong vertical velocity in boundary cells? ! ! Same question holds for hdiv. Perhaps just for security ! ! clem: yes it is a problem because ww is used in many other places where we need the halos @@ -287,7 +287,7 @@ CONTAINS INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! ocean time level indices REAL(dp), DIMENSION(jpi,jpj,jpt), INTENT(inout) :: pssh ! SSH field ! - REAL(dp) :: zcoef ! local scalar + REAL(wp) :: zcoef ! local scalar !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('ssh_atf') @@ -345,7 +345,7 @@ CONTAINS INTEGER, INTENT(in) :: Kmm ! time level index ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zCu, zcff, z1_e3t, zdt ! local scalars + REAL(wp) :: zCu, zcff, z1_e3t, zdt ! local scalars REAL(wp) , PARAMETER :: Cu_min = 0.15_wp ! local parameters REAL(wp) , PARAMETER :: Cu_max = 0.30_wp ! local parameters REAL(wp) , PARAMETER :: Cu_cut = 2._wp*Cu_max - Cu_min ! local parameters diff --git a/src/OCE/DYN/wet_dry.F90 b/src/OCE/DYN/wet_dry.F90 index c23e3b770add2dbdc792a0dd4fa25c0caaae01a7..b21148a86cfda7225419e3f6316c09e5835124d3 100644 --- a/src/OCE/DYN/wet_dry.F90 +++ b/src/OCE/DYN/wet_dry.F90 @@ -37,24 +37,24 @@ MODULE wet_dry !! critical depths,filters, limiters,and masks for Wetting and Drying !! --------------------------------------------------------------------- - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdmask !: u- and v- limiter + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdmask !: u- and v- limiter ! ! (can include negative depths) - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdramp, wdrampu, wdrampv !: for hpg limiting + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdramp, wdrampu, wdrampv !: for hpg limiting LOGICAL, PUBLIC :: ln_wd_il !: Wetting/drying il activation switch (T:on,F:off) LOGICAL, PUBLIC :: ln_wd_dl !: Wetting/drying dl activation switch (T:on,F:off) - REAL(dp), PUBLIC :: rn_wdmin0 !: depth at which wetting/drying starts - REAL(dp), PUBLIC :: rn_wdmin1 !: minimum water depth on dried cells - REAL(dp), PUBLIC :: r_rn_wdmin1 !: 1/minimum water depth on dried cells - REAL(dp), PUBLIC :: rn_wdmin2 !: tolerance of minimum water depth on dried cells - REAL(dp), PUBLIC :: rn_wd_sbcdep !: Depth at which to taper sbc fluxes - REAL(dp), PUBLIC :: rn_wd_sbcfra !: Fraction of SBC at taper depth - REAL(dp), PUBLIC :: rn_wdld !: land elevation below which wetting/drying will be considered + REAL(wp), PUBLIC :: rn_wdmin0 !: depth at which wetting/drying starts + REAL(wp), PUBLIC :: rn_wdmin1 !: minimum water depth on dried cells + REAL(wp), PUBLIC :: r_rn_wdmin1 !: 1/minimum water depth on dried cells + REAL(wp), PUBLIC :: rn_wdmin2 !: tolerance of minimum water depth on dried cells + REAL(wp), PUBLIC :: rn_wd_sbcdep !: Depth at which to taper sbc fluxes + REAL(wp), PUBLIC :: rn_wd_sbcfra !: Fraction of SBC at taper depth + REAL(wp), PUBLIC :: rn_wdld !: land elevation below which wetting/drying will be considered INTEGER , PUBLIC :: nn_wdit !: maximum number of iteration for W/D limiter LOGICAL, PUBLIC :: ln_wd_dl_bc !: DL scheme: True implies 3D velocities are set to the barotropic values at points !: where the flow is from wet points on less than half the barotropic sub-steps LOGICAL, PUBLIC :: ln_wd_dl_rmp !: use a ramp for the dl flux limiter between 2 rn_wdmin1 and rn_wdmin1 (rather than a cut-off at rn_wdmin1) - REAL(dp), PUBLIC :: ssh_ref !: height of z=0 with respect to the geoid; + REAL(wp), PUBLIC :: ssh_ref !: height of z=0 with respect to the geoid; LOGICAL, PUBLIC :: ll_wd = .FALSE. !: Wetting/drying activation switch (ln_wd_il or ln_wd_dl) <- default def if wad_init not called @@ -133,21 +133,21 @@ CONTAINS !! ** Action : - calculate flux limiter and W/D flag !!---------------------------------------------------------------------- REAL(dp), DIMENSION(:,:) , INTENT(inout) :: psshb1 - REAL(dp), DIMENSION(:,:) , INTENT(in ) :: psshemp - REAL(dp) , INTENT(in ) :: z2dt + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: psshemp + REAL(wp) , INTENT(in ) :: z2dt INTEGER , INTENT(in ) :: Kmm ! time level index REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocity arrays ! INTEGER :: ji, jj, jk, jk1 ! dummy loop indices INTEGER :: jflag ! local scalar - REAL(dp) :: zcoef, zdep1, zdep2 ! local scalars - REAL(dp) :: zzflxp, zzflxn ! local scalars - REAL(dp) :: zdepwd ! local scalar, always wet cell depth - REAL(dp) :: ztmp ! local scalars - REAL(dp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv ! W/D flux limiters - REAL(dp), DIMENSION(jpi,jpj) :: zflxp , zflxn ! local 2D workspace - REAL(dp), DIMENSION(jpi,jpj) :: zflxu , zflxv ! local 2D workspace - REAL(dp), DIMENSION(jpi,jpj) :: zflxu1 , zflxv1 ! local 2D workspace + REAL(wp) :: zcoef, zdep1, zdep2 ! local scalars + REAL(wp) :: zzflxp, zzflxn ! local scalars + REAL(wp) :: zdepwd ! local scalar, always wet cell depth + REAL(wp) :: ztmp ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv ! W/D flux limiters + REAL(wp), DIMENSION(jpi,jpj) :: zflxp , zflxn ! local 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zflxu , zflxv ! local 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zflxu1 , zflxv1 ! local 2D workspace !!---------------------------------------------------------------------- IF( ln_timing ) CALL timing_start('wad_lmt') ! ! @@ -242,7 +242,7 @@ CONTAINS IF( zflxv1(ji ,jj-1) < 0._wp ) zwdlmtv(ji ,jj-1) = zcoef ENDIF END_2D - CALL lbc_lnk( 'wet_dry', zwdlmtu, 'U', 1.0_dp, zwdlmtv, 'V', 1.0_dp ) + CALL lbc_lnk( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) ! CALL mpp_max('wet_dry', jflag) !max over the global domain ! @@ -259,7 +259,7 @@ CONTAINS ! !!gm TO BE SUPPRESSED ? these lbc_lnk are useless since zwdlmtu and zwdlmtv are defined everywhere ! CALL lbc_lnk( 'wet_dry', puu(:,:,:,Kmm) , 'U', -1.0_dp, pvv(:,:,:,Kmm) , 'V', -1.0_dp ) - CALL lbc_lnk( 'wet_dry', uu_b(:,:,Kmm), 'U', -1.0_dp, vv_b(:,:,Kmm), 'V', -1.0_dp ) + CALL lbc_lnk( 'wet_dry', uu_b(:,:,Kmm), 'U', -1.0_wp, vv_b(:,:,Kmm), 'V', -1.0_wp ) !!gm ! IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt!!!' @@ -282,18 +282,19 @@ CONTAINS !! ** Action : - calculate flux limiter and W/D flag !!---------------------------------------------------------------------- REAL(dp) , INTENT(in ) :: rDt_e ! ocean time-step index - REAL(dp), DIMENSION(:,:), INTENT(inout) :: zflxu, zflxv, sshn_e, zssh_frc + REAL(wp), DIMENSION(:,:), INTENT(inout) :: zflxv + REAL(dp), DIMENSION(:,:), INTENT(inout) :: zflxu, sshn_e, zssh_frc ! INTEGER :: ji, jj, jk, jk1 ! dummy loop indices INTEGER :: jflag ! local integer - REAL(dp) :: z2dt - REAL(dp) :: zcoef, zdep1, zdep2 ! local scalars - REAL(dp) :: zzflxp, zzflxn ! local scalars - REAL(dp) :: zdepwd ! local scalar, always wet cell depth - REAL(dp) :: ztmp ! local scalars - REAL(dp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv !: W/D flux limiters - REAL(dp), DIMENSION(jpi,jpj) :: zflxp, zflxn ! local 2D workspace - REAL(dp), DIMENSION(jpi,jpj) :: zflxu1, zflxv1 ! local 2D workspace + REAL(wp) :: z2dt + REAL(wp) :: zcoef, zdep1, zdep2 ! local scalars + REAL(wp) :: zzflxp, zzflxn ! local scalars + REAL(wp) :: zdepwd ! local scalar, always wet cell depth + REAL(wp) :: ztmp ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv !: W/D flux limiters + REAL(wp), DIMENSION(jpi,jpj) :: zflxp, zflxn ! local 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zflxu1, zflxv1 ! local 2D workspace !!---------------------------------------------------------------------- IF( ln_timing ) CALL timing_start('wad_lmt_bt') ! ! @@ -367,7 +368,7 @@ CONTAINS END IF END_2D ! - CALL lbc_lnk( 'wet_dry', zwdlmtu, 'U', 1.0_dp, zwdlmtv, 'V', 1.0_dp ) + CALL lbc_lnk( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) ! CALL mpp_max('wet_dry', jflag) !max over the global domain ! @@ -379,7 +380,8 @@ CONTAINS zflxv(:,:) = zflxv(:,:) * zwdlmtv(:, :) ! !!gm THIS lbc_lnk is useless since it is already done at the end of the jk1-loop - CALL lbc_lnk( 'wet_dry', zflxu, 'U', -1.0_dp, zflxv, 'V', -1.0_dp ) + CALL lbc_lnk( 'wet_dry', zflxu, 'U', -1.0_dp) + CALL lbc_lnk( 'wet_dry', zflxv, 'V', -1.0_wp) !!gm end ! IF( jflag == 1 .AND. lwp ) WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!' diff --git a/src/OCE/FLO/flo4rk.F90 b/src/OCE/FLO/flo4rk.F90 index 005b0e504afc08351aee157e192f001d925f184d..7ffe48f544d5e16280214894327b189859dd0e7b 100644 --- a/src/OCE/FLO/flo4rk.F90 +++ b/src/OCE/FLO/flo4rk.F90 @@ -19,11 +19,11 @@ MODULE flo4rk PUBLIC flo_4rk ! routine called by floats.F90 ! ! RK4 and Lagrange interpolation coefficients - REAL(dp), DIMENSION (4) :: tcoef1 = (/ 1.0 , 0.5 , 0.5 , 0.0 /) ! - REAL(dp), DIMENSION (4) :: tcoef2 = (/ 0.0 , 0.5 , 0.5 , 1.0 /) ! - REAL(dp), DIMENSION (4) :: scoef2 = (/ 1.0 , 2.0 , 2.0 , 1.0 /) ! - REAL(dp), DIMENSION (4) :: rcoef = (/-1./6. , 1./2. ,-1./2. , 1./6. /) ! - REAL(dp), DIMENSION (3) :: scoef1 = (/ 0.5 , 0.5 , 1.0 /) ! + REAL(wp), DIMENSION (4) :: tcoef1 = (/ 1.0 , 0.5 , 0.5 , 0.0 /) ! + REAL(wp), DIMENSION (4) :: tcoef2 = (/ 0.0 , 0.5 , 0.5 , 1.0 /) ! + REAL(wp), DIMENSION (4) :: scoef2 = (/ 1.0 , 2.0 , 2.0 , 1.0 /) ! + REAL(wp), DIMENSION (4) :: rcoef = (/-1./6. , 1./2. ,-1./2. , 1./6. /) ! + REAL(wp), DIMENSION (3) :: scoef1 = (/ 0.5 , 0.5 , 1.0 /) ! # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- @@ -51,9 +51,9 @@ CONTAINS INTEGER :: jfl, jind ! dummy loop indices INTEGER :: ierror ! error value - REAL(dp), DIMENSION(jpnfl) :: zgifl , zgjfl , zgkfl ! index RK positions - REAL(dp), DIMENSION(jpnfl) :: zufl , zvfl , zwfl ! interpolated velocity at the float position - REAL(dp), DIMENSION(jpnfl,4) :: zrkxfl, zrkyfl, zrkzfl ! RK coefficients + REAL(wp), DIMENSION(jpnfl) :: zgifl , zgjfl , zgkfl ! index RK positions + REAL(wp), DIMENSION(jpnfl) :: zufl , zvfl , zwfl ! interpolated velocity at the float position + REAL(wp), DIMENSION(jpnfl,4) :: zrkxfl, zrkyfl, zrkzfl ! RK coefficients !!--------------------------------------------------------------------- ! IF( ierror /= 0 ) THEN @@ -168,22 +168,22 @@ CONTAINS !! integrated with RK method. !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices - REAL(dp) , DIMENSION(jpnfl), INTENT(in ) :: pxt , pyt , pzt ! position of the float - REAL(dp) , DIMENSION(jpnfl), INTENT( out) :: pufl, pvfl, pwfl ! velocity at this position + REAL(wp) , DIMENSION(jpnfl), INTENT(in ) :: pxt , pyt , pzt ! position of the float + REAL(wp) , DIMENSION(jpnfl), INTENT( out) :: pufl, pvfl, pwfl ! velocity at this position INTEGER , INTENT(in ) :: ki ! !! INTEGER :: jfl, jind1, jind2, jind3 ! dummy loop indices - REAL(dp) :: zsumu, zsumv, zsumw ! local scalar + REAL(wp) :: zsumu, zsumv, zsumw ! local scalar INTEGER , DIMENSION(jpnfl) :: iilu, ijlu, iklu ! nearest neighbour INDEX-u INTEGER , DIMENSION(jpnfl) :: iilv, ijlv, iklv ! nearest neighbour INDEX-v INTEGER , DIMENSION(jpnfl) :: iilw, ijlw, iklw ! nearest neighbour INDEX-w INTEGER , DIMENSION(jpnfl,4) :: iidu, ijdu, ikdu ! 64 nearest neighbour INDEX-u INTEGER , DIMENSION(jpnfl,4) :: iidv, ijdv, ikdv ! 64 nearest neighbour INDEX-v INTEGER , DIMENSION(jpnfl,4) :: iidw, ijdw, ikdw ! 64 nearest neighbour INDEX-w - REAL(dp) , DIMENSION(jpnfl,4) :: zlagxu, zlagyu, zlagzu ! Lagrange coefficients - REAL(dp) , DIMENSION(jpnfl,4) :: zlagxv, zlagyv, zlagzv ! - - - REAL(dp) , DIMENSION(jpnfl,4) :: zlagxw, zlagyw, zlagzw ! - - - REAL(dp) , DIMENSION(jpnfl,4,4,4) :: ztufl , ztvfl , ztwfl ! velocity at choosen time step + REAL(wp) , DIMENSION(jpnfl,4) :: zlagxu, zlagyu, zlagzu ! Lagrange coefficients + REAL(wp) , DIMENSION(jpnfl,4) :: zlagxv, zlagyv, zlagzv ! - - + REAL(wp) , DIMENSION(jpnfl,4) :: zlagxw, zlagyw, zlagzw ! - - + REAL(wp) , DIMENSION(jpnfl,4,4,4) :: ztufl , ztvfl , ztwfl ! velocity at choosen time step !!--------------------------------------------------------------------- ! Interpolation of U velocity diff --git a/src/OCE/FLO/flo_oce.F90 b/src/OCE/FLO/flo_oce.F90 index f4975a31c8f95f5ed11c1af6e01e256087f6c5c5..911f87879679d24b278a08b8b545e7424c280299 100644 --- a/src/OCE/FLO/flo_oce.F90 +++ b/src/OCE/FLO/flo_oce.F90 @@ -28,10 +28,10 @@ MODULE flo_oce INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: ngrpfl !: number to identify searcher group INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: nfloat !: number to identify searcher group - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: flxx , flyy , flzz !: long, lat, depth of float (decimal degree, m >0) - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: tpifl, tpjfl, tpkfl !: (i,j,k) indices of float position + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: flxx , flyy , flzz !: long, lat, depth of float (decimal degree, m >0) + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: tpifl, tpjfl, tpkfl !: (i,j,k) indices of float position - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wb !: vertical velocity at previous time step (m s-1). + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wb !: vertical velocity at previous time step (m s-1). ! !! * namelist namflo : langrangian floats * LOGICAL, PUBLIC :: ln_rstflo !: T/F float restart diff --git a/src/OCE/FLO/floblk.F90 b/src/OCE/FLO/floblk.F90 index 9b431d4b2654b4e2a7791a49558211a45116ff3c..75ea92edbe9e3cc57037ef75b12f24e745e75494 100644 --- a/src/OCE/FLO/floblk.F90 +++ b/src/OCE/FLO/floblk.F90 @@ -48,32 +48,31 @@ CONTAINS INTEGER :: jfl ! dummy loop arguments INTEGER :: ind, ifin, iloop - REAL(dp) :: zuinfl,zvinfl,zwinfl, zuoutfl,zvoutfl,zwoutfl, zvol, zsurfz, zind + REAL(wp) :: & + zuinfl,zvinfl,zwinfl, & ! transport across the input face + zuoutfl,zvoutfl,zwoutfl, & ! transport across the ouput face + zvol, & ! volume of the mesh + zsurfz, & ! surface of the face of the mesh + zind - - - - - - - REAL(dp), DIMENSION ( 2 ) :: zsurfx, zsurfy ! surface of the face of the mesh + REAL(wp), DIMENSION ( 2 ) :: zsurfx, zsurfy ! surface of the face of the mesh INTEGER , DIMENSION ( jpnfl ) :: iil, ijl, ikl ! index of nearest mesh INTEGER , DIMENSION ( jpnfl ) :: iiloc , ijloc INTEGER , DIMENSION ( jpnfl ) :: iiinfl, ijinfl, ikinfl ! index of input mesh of the float. INTEGER , DIMENSION ( jpnfl ) :: iioutfl, ijoutfl, ikoutfl ! index of output mesh of the float. - REAL(dp) , DIMENSION ( jpnfl ) :: zgifl, zgjfl, zgkfl ! position of floats, index on + REAL(wp) , DIMENSION ( jpnfl ) :: zgifl, zgjfl, zgkfl ! position of floats, index on ! ! velocity mesh. - REAL(dp) , DIMENSION ( jpnfl ) :: ztxfl, ztyfl, ztzfl ! time for a float to quit the mesh + REAL(wp) , DIMENSION ( jpnfl ) :: ztxfl, ztyfl, ztzfl ! time for a float to quit the mesh ! ! across one of the face x,y and z - REAL(dp) , DIMENSION ( jpnfl ) :: zttfl ! time for a float to quit the mesh - REAL(dp) , DIMENSION ( jpnfl ) :: zagefl ! time during which, trajectorie of + REAL(wp) , DIMENSION ( jpnfl ) :: zttfl ! time for a float to quit the mesh + REAL(wp) , DIMENSION ( jpnfl ) :: zagefl ! time during which, trajectorie of ! ! the float has been computed - REAL(dp) , DIMENSION ( jpnfl ) :: zagenewfl ! new age of float after calculation + REAL(wp) , DIMENSION ( jpnfl ) :: zagenewfl ! new age of float after calculation ! ! of new position - REAL(dp) , DIMENSION ( jpnfl ) :: zufl, zvfl, zwfl ! interpolated vel. at float position - REAL(dp) , DIMENSION ( jpnfl ) :: zudfl, zvdfl, zwdfl ! velocity diff input/output of mesh - REAL(dp) , DIMENSION ( jpnfl ) :: zgidfl, zgjdfl, zgkdfl ! direction index of float + REAL(wp) , DIMENSION ( jpnfl ) :: zufl, zvfl, zwfl ! interpolated vel. at float position + REAL(wp) , DIMENSION ( jpnfl ) :: zudfl, zvdfl, zwdfl ! velocity diff input/output of mesh + REAL(wp) , DIMENSION ( jpnfl ) :: zgidfl, zgjdfl, zgkdfl ! direction index of float !!--------------------------------------------------------------------- IF( kt == nit000 ) THEN diff --git a/src/OCE/FLO/flodom.F90 b/src/OCE/FLO/flodom.F90 index 8c7d07fddf24efc14c388df6feca186f9d8dddb7..3ccef91948ad4926d11af176cd8af59342e30e3f 100644 --- a/src/OCE/FLO/flodom.F90 +++ b/src/OCE/FLO/flodom.F90 @@ -30,7 +30,7 @@ MODULE flodom INTEGER , ALLOCATABLE, DIMENSION(:) :: iimfl, ijmfl, ikmfl ! index mesh of floats INTEGER , ALLOCATABLE, DIMENSION(:) :: idomfl, ivtest, ihtest ! - - REAL(dp), ALLOCATABLE, DIMENSION(:) :: zgifl, zgjfl, zgkfl ! distances in indexes + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zgifl, zgjfl, zgkfl ! distances in indexes !! * Substitutions # include "domzgr_substitute.h90" @@ -134,7 +134,7 @@ CONTAINS INTEGER :: jfl,ji, jj, jk ! dummy loop indices INTEGER :: itrash ! trash var for reading INTEGER :: ifl ! number of floats to read - REAL(dp) :: zdxab, zdyad + REAL(wp) :: zdxab, zdyad LOGICAL :: llinmesh CHARACTER(len=80) :: cltmp !!--------------------------------------------------------------------- @@ -361,15 +361,14 @@ CONTAINS !! !! ** Method : !!---------------------------------------------------------------------- - REAL(dp) :: pax, pay, pbx, pby, pcx, pcy, pdx, pdy, px, py, ptx, pty - - - - - + REAL(wp) :: & + pax, pay, pbx, pby, & ! ??? + pcx, pcy, pdx, pdy, & ! ??? + px, py, & ! longitude and latitude + ptx, pty ! ??? LOGICAL :: ldinmesh ! ??? !! - REAL(dp) :: zabt, zbct, zcdt, zdat, zabpt, zbcpt, zcdpt, zdapt + REAL(wp) :: zabt, zbct, zcdt, zdat, zabpt, zbcpt, zcdpt, zdapt !!--------------------------------------------------------------------- ! 4 semi plane defined by the 4 points and including the T point @@ -412,8 +411,8 @@ CONTAINS !! ** Purpose : !! ** Method : !!---------------------------------------------------------------------- - REAL(dp) :: fsline - REAL(dp), INTENT(in) :: psax, psay, psbx, psby, psx, psy + REAL(wp) :: fsline + REAL(wp), INTENT(in) :: psax, psay, psbx, psby, psx, psy !!--------------------------------------------------------------------- fsline = psy * ( psbx - psax ) & & - psx * ( psby - psay ) & @@ -429,10 +428,10 @@ CONTAINS !! points !! ** Method : !!---------------------------------------------------------------------- - REAL(dp), INTENT(in) :: pla1, phi1, pla2, phi2 ! ??? + REAL(wp), INTENT(in) :: pla1, phi1, pla2, phi2 ! ??? !! - REAL(dp) :: dly1, dly2, dlx1, dlx2, dlx, dls, dld, dpi - REAL(dp) :: flo_dstnce + REAL(wp) :: dly1, dly2, dlx1, dlx2, dlx, dls, dld, dpi + REAL(wp) :: flo_dstnce !!--------------------------------------------------------------------- ! dpi = 2._wp * ASIN(1._wp) diff --git a/src/OCE/FLO/flowri.F90 b/src/OCE/FLO/flowri.F90 index 2026d48e4b89c34cc060d731a41c856477cc01fa..8eb4022dafdae8359b19ef33f9305103cc59709c 100644 --- a/src/OCE/FLO/flowri.F90 +++ b/src/OCE/FLO/flowri.F90 @@ -29,8 +29,8 @@ MODULE flowri INTEGER :: jfl ! number of floats CHARACTER (len=80) :: clname ! netcdf output filename - REAL(dp), ALLOCATABLE, DIMENSION(:) :: zlon , zlat, zdep ! 2D workspace - REAL(dp), ALLOCATABLE, DIMENSION(:) :: ztem , zsal, zrho ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zlon , zlat, zdep ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:) :: ztem , zsal, zrho ! 2D workspace !! * Substitutions # include "domzgr_substitute.h90" @@ -74,8 +74,8 @@ CONTAINS INTEGER :: iafloc,ibfloc,ia1floc,ib1floc ! " INTEGER :: irec, irecflo - REAL(dp) :: zafl,zbfl,zcfl ! temporary real - REAL(dp) :: ztime ! " + REAL(wp) :: zafl,zbfl,zcfl ! temporary real + REAL(wp) :: ztime ! " INTEGER, DIMENSION(2) :: icount INTEGER, DIMENSION(2) :: istart @@ -97,9 +97,9 @@ CONTAINS ia1fl = iafl + 1 ! I-index of the nearest point after ib1fl = ibfl + 1 ! J-index of the nearest point after ic1fl = icfl + 1 ! K-index of the nearest point after - zafl = tpifl(jfl) - REAL(iafl,dp) ! distance ????? - zbfl = tpjfl(jfl) - REAL(ibfl,dp) ! distance ????? - zcfl = tpkfl(jfl) - REAL(icfl,dp) ! distance ????? + zafl = tpifl(jfl) - REAL(iafl,wp) ! distance ????? + zbfl = tpjfl(jfl) - REAL(ibfl,wp) ! distance ????? + zcfl = tpkfl(jfl) - REAL(icfl,wp) ! distance ????? IF( lk_mpp ) THEN @@ -207,7 +207,7 @@ CONTAINS CALL iom_put( "traj_temp" , ztem ) CALL iom_put( "traj_salt" , zsal ) CALL iom_put( "traj_dens" , zrho ) - CALL iom_put( "traj_group" , REAL(ngrpfl,dp) ) + CALL iom_put( "traj_group" , REAL(ngrpfl,wp) ) #else !II-2-b Write with IOIPSL @@ -235,7 +235,7 @@ CONTAINS CALL fliodefv( numflo, 'traj_dens' , (/1,2/), v_t=flio_r8, long_name="Density" , units="kg/m3" ) CALL fliodefv( numflo, 'traj_group' , (/1/) , v_t=flio_r8, long_name="number of the group" , units="no unit" ) - CALL flioputv( numflo , 'traj_group' , REAL(ngrpfl,dp) ) + CALL flioputv( numflo , 'traj_group' , REAL(ngrpfl,wp) ) ELSE ! Re-open diff --git a/src/OCE/ICB/icb_oce.F90 b/src/OCE/ICB/icb_oce.F90 index 42f0bebea06dc9c42a54570c92e6cf52b0237b32..39a204ea63d9d7b5a2f314590081c7df6f6c4e2a 100644 --- a/src/OCE/ICB/icb_oce.F90 +++ b/src/OCE/ICB/icb_oce.F90 @@ -57,11 +57,10 @@ MODULE icb_oce TYPE, PUBLIC :: point !: properties of an individual iceberg (position, mass, size, etc...) INTEGER :: year REAL(wp) :: xi , yj , zk ! iceberg coordinates in the (i,j) referential (global) and deepest level affected - REAL(dp) :: e1 , e2 ! horizontal scale factors at the iceberg position - REAL(wp) :: day! geographic position - REAL(dp) :: lon, lat! geographic position + REAL(wp) :: e1 , e2 ! horizontal scale factors at the iceberg position + REAL(wp) :: lon, lat, day ! geographic position REAL(wp) :: mass, thickness, width, length, uvel, vvel ! iceberg physical properties - REAL(dp) :: ssu, ssv, ui, vi, ua, va, ssh_x, ssh_y, sst, sss, cn, hi ! properties of iceberg environment + REAL(wp) :: ssu, ssv, ui, vi, ua, va, ssh_x, ssh_y, sst, sss, cn, hi ! properties of iceberg environment REAL(wp) :: mass_of_bits, heat_density INTEGER :: kb ! icb bottom level END TYPE point @@ -78,21 +77,21 @@ MODULE icb_oce TYPE(iceberg) , POINTER :: first_berg => NULL() !: master instance of linked list iceberg type ! !!! parameters controlling iceberg characteristics and modelling - REAL(dp) :: berg_dt !: Time-step between iceberg CALLs (should make adaptive?) - REAL(dp), DIMENSION(:), ALLOCATABLE :: first_width, first_length !: + REAL(wp) :: berg_dt !: Time-step between iceberg CALLs (should make adaptive?) + REAL(wp), DIMENSION(:), ALLOCATABLE :: first_width, first_length !: LOGICAL :: l_restarted_bergs=.FALSE. ! Indicate whether we read state from a restart or not ! ! arbitrary numbers for diawri entry - REAL(dp), DIMENSION(nclasses), PUBLIC :: class_num=(/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 /) + REAL(wp), DIMENSION(nclasses), PUBLIC :: class_num=(/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 /) ! Extra arrays with bigger halo, needed when interpolating forcing onto iceberg position ! particularly for MPP when iceberg can lie inside T grid but outside U, V, or f grid - REAL(dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssu_e, ssv_e - REAL(dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: sst_e, sss_e, fr_e - REAL(dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ua_e, va_e - REAL(dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssh_e - REAL(dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: tmask_e, umask_e, vmask_e - REAl(dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: rlon_e, rlat_e, ff_e - REAl(dp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: uoce_e, voce_e, toce_e, e3t_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssu_e, ssv_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: sst_e, sss_e, fr_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ua_e, va_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssh_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: tmask_e, umask_e, vmask_e + REAl(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: rlon_e, rlat_e, ff_e + REAl(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: uoce_e, voce_e, toce_e, e3t_e ! #if defined key_si3 || defined key_cice REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: hi_e, ui_e, vi_e @@ -115,20 +114,20 @@ MODULE icb_oce LOGICAL , PUBLIC :: ln_bergdia !: Calculate budgets INTEGER , PUBLIC :: nn_verbose_level !: Turn on debugging when level > 0 INTEGER , PUBLIC :: nn_test_icebergs !: Create icebergs in absence of a restart file from the supplied class nb - REAL(dp), PUBLIC, DIMENSION(4) :: rn_test_box !: lon1,lon2,lat1,lat2 box to create them in + REAL(wp), PUBLIC, DIMENSION(4) :: rn_test_box !: lon1,lon2,lat1,lat2 box to create them in LOGICAL , PUBLIC :: ln_use_calving !: Force use of calving data even with nn_test_icebergs > 0 ! (default is not to use calving data with test bergs) INTEGER , PUBLIC :: nn_sample_rate !: Timesteps between sampling of position for trajectory storage INTEGER , PUBLIC :: nn_verbose_write !: timesteps between verbose messages - REAL(dp), PUBLIC :: rn_rho_bergs !: Density of icebergs - REAL(dp), PUBLIC :: rho_berg_1_oce !: convertion factor (thickness to draft) (rn_rho_bergs/pp_rho_seawater) - REAL(dp), PUBLIC :: rn_LoW_ratio !: Initial ratio L/W for newly calved icebergs - REAL(dp), PUBLIC :: rn_bits_erosion_fraction !: Fraction of erosion melt flux to divert to bergy bits - REAL(dp), PUBLIC :: rn_sicn_shift !: Shift of sea-ice concentration in erosion flux modulation (0 first_berg DO WHILE( ASSOCIATED(this) ) pt => this%current_point - IF( pt%xi > REAL(mig(nicbei),dp) + 0.5_wp ) THEN + IF( pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp - ELSE IF( pt%xi < REAL(mig(nicbdi),dp) - 0.5_wp ) THEN + ELSE IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN pt%xi = ricb_left + MOD(pt%xi, 1._wp ) ENDIF this => this%next @@ -125,7 +125,7 @@ CONTAINS DO WHILE( ASSOCIATED(this) ) pt => this%current_point ijne = INT( pt%yj + 0.5 ) - IF( pt%yj > REAL(mjg(nicbej),dp) + 0.5_wp ) THEN + IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN ! iine = INT( pt%xi + 0.5 ) ipts = nicbfldpts (mi1(iine)) @@ -134,8 +134,8 @@ CONTAINS ! velocity must change ijglo = INT( ipts/nicbpack ) iiglo = ipts - nicbpack*ijglo - pt%xi = iiglo - ( pt%xi - REAL(iine,dp) ) - pt%yj = ijglo - ( pt%yj - REAL(ijne,dp) ) + pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) + pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) pt%uvel = -1._wp * pt%uvel pt%vvel = -1._wp * pt%vvel ENDIF @@ -228,7 +228,7 @@ CONTAINS this => first_berg DO WHILE (ASSOCIATED(this)) pt => this%current_point - IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei),dp) + 0.5_wp - (nn_hls-1) ) THEN + IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei),wp) + 0.5_wp - (nn_hls-1) ) THEN tmpberg => this this => this%next ibergs_to_send_e = ibergs_to_send_e + 1 @@ -241,7 +241,7 @@ CONTAINS ! now pack it into buffer and delete from list CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e) CALL icb_utl_delete(first_berg, tmpberg) - ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi),dp) - 0.5_wp - (nn_hls-1) ) THEN + ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp - (nn_hls-1) ) THEN tmpberg => this this => this%next ibergs_to_send_w = ibergs_to_send_w + 1 @@ -320,7 +320,7 @@ CONTAINS this => first_berg DO WHILE (ASSOCIATED(this)) pt => this%current_point - IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej),dp) + 0.5_wp - (nn_hls-1) ) THEN + IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN tmpberg => this this => this%next ibergs_to_send_n = ibergs_to_send_n + 1 @@ -330,7 +330,7 @@ CONTAINS ENDIF CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n) CALL icb_utl_delete(first_berg, tmpberg) - ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj),dp) - 0.5_wp - (nn_hls-1) ) THEN + ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp - (nn_hls-1) ) THEN tmpberg => this this => this%next ibergs_to_send_s = ibergs_to_send_s + 1 @@ -441,10 +441,10 @@ CONTAINS this => first_berg DO WHILE (ASSOCIATED(this)) pt => this%current_point - IF( pt%xi < REAL(mig(nicbdi),dp) - 0.5_wp - (nn_hls-1) .OR. & - pt%xi > REAL(mig(nicbei),dp) + 0.5_wp - (nn_hls-1) .OR. & - pt%yj < REAL(mjg(nicbdj),dp) - 0.5_wp - (nn_hls-1) .OR. & - pt%yj > REAL(mjg(nicbej),dp) + 0.5_wp - (nn_hls-1) ) THEN + IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp - (nn_hls-1) .OR. & + pt%xi > REAL(mig(nicbei),wp) + 0.5_wp - (nn_hls-1) .OR. & + pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp - (nn_hls-1) .OR. & + pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN i = i + 1 WRITE(numicb,*) 'berg lost in halo: ', this%number(:) WRITE(numicb,*) ' ', nimpp, njmpp @@ -515,7 +515,7 @@ CONTAINS pt => this%current_point iine = INT( pt%xi + 0.5 ) + (nn_hls-1) iproc = nicbflddest(mi1(iine)) - IF( pt%yj > REAL(mjg(nicbej),dp) + 0.5_wp - (nn_hls-1) ) THEN + IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN IF( iproc == ifldproc ) THEN ! IF( iproc /= narea ) THEN @@ -595,15 +595,15 @@ CONTAINS ijne = INT( pt%yj + 0.5 ) + (nn_hls-1) ipts = nicbfldpts (mi1(iine)) iproc = nicbflddest(mi1(iine)) - IF( pt%yj > REAL(mjg(nicbej),dp) + 0.5_wp - (nn_hls-1) ) THEN + IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN IF( iproc == ifldproc ) THEN ! ! moving across the cut line means both position and ! velocity must change ijglo = INT( ipts/nicbpack ) iiglo = ipts - nicbpack*ijglo - pt%xi = iiglo - ( pt%xi - REAL(iine,dp) ) - pt%yj = ijglo - ( pt%yj - REAL(ijne,dp) ) + pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) + pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) pt%uvel = -1._wp * pt%uvel pt%vvel = -1._wp * pt%vvel ! @@ -710,7 +710,7 @@ CONTAINS pbuff%data(15,kb) = berg%mass_scaling DO k=1,nkounts - pbuff%data(15+k,kb) = REAL( berg%number(k),dp ) + pbuff%data(15+k,kb) = REAL( berg%number(k), wp ) END DO ! END SUBROUTINE icb_pack_into_buffer diff --git a/src/OCE/ICB/icbrst.F90 b/src/OCE/ICB/icbrst.F90 index 90c462d68a98d925141140b6b68c7a4e4bc89f89..0d38a1856a559ae413cc59c46049ddd9305d34dd 100644 --- a/src/OCE/ICB/icbrst.F90 +++ b/src/OCE/ICB/icbrst.F90 @@ -60,7 +60,7 @@ CONTAINS INTEGER :: idim, ivar, iatt INTEGER :: jn, iunlim_dim, ibergs_in_file INTEGER :: ii, ij, iclass, ibase_err, imax_icb - REAL(dp), DIMENSION(nkounts) :: zdata + REAL(wp), DIMENSION(nkounts) :: zdata LOGICAL :: ll_found_restart CHARACTER(len=256) :: cl_path CHARACTER(len=256) :: cl_filename @@ -215,7 +215,7 @@ CONTAINS WRITE(cl_kt, '(i8.8)') kt cl_filename = TRIM(cexper)//"_"//cl_kt//"_"//TRIM(cn_icbrst_out) IF( lk_mpp ) THEN - idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' WRITE(cl_filename, clfmt) TRIM(cl_filename), '_', narea-1, '.nc' ELSE diff --git a/src/OCE/ICB/icbthm.F90 b/src/OCE/ICB/icbthm.F90 index 869ec137683383fdb8b1519085a1dab419351b98..edc1415a36da88d313bc4fe6862676e8194b916c 100644 --- a/src/OCE/ICB/icbthm.F90 +++ b/src/OCE/ICB/icbthm.F90 @@ -49,13 +49,13 @@ CONTAINS INTEGER, INTENT(in) :: kt ! timestep number, just passed to icb_utl_print_berg ! INTEGER :: ii, ij, jk, ikb - REAL(dp) :: zM, zT, zW, zL, zSST, zVol, zLn, zWn, zTn, znVol, zIC, zDn, zD, zvb, zub, ztb - REAL(dp) :: zMv, zMe, zMb, zmelt, zdvo, zdvob, zdva, zdM, zSs, zdMe, zdMb, zdMv - REAL(dp) :: zSSS, zfzpt - REAL(dp) :: zMnew, zMnew1, zMnew2, zheat_hcflux, zheat_latent, z1_12 - REAL(dp) :: zMbits, znMbits, zdMbitsE, zdMbitsM, zLbits, zAbits, zMbb - REAL(dp) :: zxi, zyj, zff, z1_rday, z1_e1e2, zdt, z1_dt, z1_dt_e1e2, zdepw - REAL(dp), DIMENSION(jpk) :: ztoce, zuoce, zvoce, ze3t, zzMv + REAL(wp) :: zM, zT, zW, zL, zSST, zVol, zLn, zWn, zTn, znVol, zIC, zDn, zD, zvb, zub, ztb + REAL(wp) :: zMv, zMe, zMb, zmelt, zdvo, zdvob, zdva, zdM, zSs, zdMe, zdMb, zdMv + REAL(wp) :: zSSS, zfzpt + REAL(wp) :: zMnew, zMnew1, zMnew2, zheat_hcflux, zheat_latent, z1_12 + REAL(wp) :: zMbits, znMbits, zdMbitsE, zdMbitsM, zLbits, zAbits, zMbb + REAL(wp) :: zxi, zyj, zff, z1_rday, z1_e1e2, zdt, z1_dt, z1_dt_e1e2, zdepw + REAL(wp), DIMENSION(jpk) :: ztoce, zuoce, zvoce, ze3t, zzMv TYPE(iceberg), POINTER :: this, next TYPE(point) , POINTER :: pt ! diff --git a/src/OCE/ICB/icbtrj.F90 b/src/OCE/ICB/icbtrj.F90 index 753b1f4476dc84c87301312033c2bad15930873b..4cc5411eef79d4b1a6ba7e5991ab0896302f9209 100644 --- a/src/OCE/ICB/icbtrj.F90 +++ b/src/OCE/ICB/icbtrj.F90 @@ -75,15 +75,15 @@ CONTAINS WRITE(cldate_ini, '(i4.4,2i2.2)') iyear, imonth, iday ! compute end time step date - zfjulday = fjulday + rn_Dt / rday * REAL( nitend - nit000 + 1 ,dp) - IF( ABS(zfjulday - REAL(NINT(zfjulday),dp)) < 0.1 / rday ) zfjulday = REAL(NINT(zfjulday),dp) ! avoid truncation error + zfjulday = fjulday + rn_Dt / rday * REAL( nitend - nit000 + 1 , wp) + IF( ABS(zfjulday - REAL(NINT(zfjulday),wp)) < 0.1 / rday ) zfjulday = REAL(NINT(zfjulday),wp) ! avoid truncation error CALL ju2ymds( zfjulday, iyear, imonth, iday, zsec ) WRITE(cldate_end, '(i4.4,2i2.2)') iyear, imonth, iday ! define trajectory output name cl_filename = 'trajectory_icebergs_'//cldate_ini//'-'//cldate_end IF ( lk_mpp ) THEN - idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' WRITE(cl_filename, clfmt) TRIM(cl_filename), '_', narea-1, '.nc' ELSE @@ -284,4 +284,4 @@ CONTAINS END SUBROUTINE icb_trj_end !!====================================================================== -END MODULE icbtrj +END MODULE icbtrj \ No newline at end of file diff --git a/src/OCE/ICB/icbutl.F90 b/src/OCE/ICB/icbutl.F90 index ffee27b5d3ee3b04f6664c390e221297cdc50a02..00a434b38995f04d0d1c2d6562fd58b90c786d16 100644 --- a/src/OCE/ICB/icbutl.F90 +++ b/src/OCE/ICB/icbutl.F90 @@ -57,6 +57,7 @@ MODULE icbutl PUBLIC icb_utl_heat ! routine called in icbdia module !! * Substitutions +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -73,7 +74,7 @@ CONTAINS !! !! ** Method : - blah blah !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(0:jpi+1,0:jpj+1) :: ztmp + REAL(wp), DIMENSION(0:jpi+1,0:jpj+1) :: ztmp #if defined key_si3 REAL(wp), DIMENSION(jpi,jpj) :: zssh_lead_m ! ocean surface (ssh_m) if ice is not embedded ! ! ocean surface in leads if ice is embedded @@ -96,10 +97,10 @@ CONTAINS va_e (1:jpi,1:jpj) = vtau_icb (:,:) * vmask(:,:,1) ! maybe mask useless because mask applied in sbcblk ff_e(1:jpi,1:jpj) = ff_f (:,:) ! - CALL lbc_lnk_icb( 'icbutl', ssu_e, 'U', -1._dp, 1, 1 ) - CALL lbc_lnk_icb( 'icbutl', ssv_e, 'V', -1._dp, 1, 1 ) - CALL lbc_lnk_icb( 'icbutl', ua_e , 'U', -1._dp, 1, 1 ) - CALL lbc_lnk_icb( 'icbutl', va_e , 'V', -1._dp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ssu_e, 'U', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ssv_e, 'V', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ua_e , 'U', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', va_e , 'V', -1._wp, 1, 1 ) #if defined key_si3 hi_e(1:jpi, 1:jpj) = hm_i (:,:) ui_e(1:jpi, 1:jpj) = u_ice(:,:) @@ -121,12 +122,12 @@ CONTAINS DO jk = 1,jpk ! uoce ztmp(1:jpi,1:jpj) = uu(:,:,jk,Kmm) - CALL lbc_lnk_icb( 'icbutl', ztmp, 'U', -1._dp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ztmp, 'U', -1._wp, 1, 1 ) uoce_e(:,:,jk) = ztmp(:,:) ! ! voce ztmp(1:jpi,1:jpj) = vv(:,:,jk,Kmm) - CALL lbc_lnk_icb( 'icbutl', ztmp, 'V', -1._dp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ztmp, 'V', -1._wp, 1, 1 ) voce_e(:,:,jk) = ztmp(:,:) ! e3t_e(1:jpi,1:jpj,jk) = e3t(:,:,jk,Kmm) @@ -158,20 +159,20 @@ CONTAINS !! !!---------------------------------------------------------------------- REAL(wp), INTENT(in ) :: pi , pj ! position in (i,j) referential - REAL(dp), INTENT( out), OPTIONAL :: pe1, pe2 ! i- and j scale factors - REAL(dp), INTENT( out), OPTIONAL :: pssu, pssv, pui, pvi, pua, pva ! ocean, ice and wind speeds - REAL(dp), INTENT( out), OPTIONAL :: pssh_i, pssh_j ! ssh i- & j-gradients - REAL(dp), INTENT( out), OPTIONAL :: psst, psss, pcn, phi, pff ! SST, SSS, ice concentration, ice thickness, Coriolis - REAL(dp), INTENT( out), OPTIONAL :: plat, plon ! position - REAL(dp), DIMENSION(jpk), INTENT( out), OPTIONAL :: ptoce, puoce, pvoce, pe3t ! 3D variables - ! - REAL(dp), DIMENSION(4) :: zwT , zwU , zwV , zwF ! interpolation weight - REAL(dp), DIMENSION(4) :: zmskF, zmskU, zmskV, zmskT ! mask - REAL(dp), DIMENSION(4) :: zwTp, zmskTp, zwTm, zmskTm - REAL(dp), DIMENSION(4,jpk) :: zw1d + REAL(wp), INTENT( out), OPTIONAL :: pe1, pe2 ! i- and j scale factors + REAL(wp), INTENT( out), OPTIONAL :: pssu, pssv, pui, pvi, pua, pva ! ocean, ice and wind speeds + REAL(wp), INTENT( out), OPTIONAL :: pssh_i, pssh_j ! ssh i- & j-gradients + REAL(wp), INTENT( out), OPTIONAL :: psst, psss, pcn, phi, pff ! SST, SSS, ice concentration, ice thickness, Coriolis + REAL(wp), INTENT( out), OPTIONAL :: plat, plon ! position + REAL(wp), DIMENSION(jpk), INTENT( out), OPTIONAL :: ptoce, puoce, pvoce, pe3t ! 3D variables + ! + REAL(wp), DIMENSION(4) :: zwT , zwU , zwV , zwF ! interpolation weight + REAL(wp), DIMENSION(4) :: zmskF, zmskU, zmskV, zmskT ! mask + REAL(wp), DIMENSION(4) :: zwTp, zmskTp, zwTm, zmskTm + REAL(wp), DIMENSION(4,jpk) :: zw1d INTEGER :: iiT, iiU, iiV, iiF, ijT, ijU, ijV, ijF ! bottom left corner INTEGER :: iiTp, iiTm, ijTp, ijTm - REAL(dp) :: zcd, zmod ! local scalars + REAL(wp) :: zcd, zmod ! local scalars !!---------------------------------------------------------------------- ! ! get position, weight and mask @@ -181,8 +182,8 @@ CONTAINS CALL icb_utl_pos( pi, pj, 'F', iiF, ijF, zwF, zmskF ) ! ! metrics and coordinates - IF ( PRESENT(pe1 ) ) pe1 = icb_utl_bilin_e( e1t, e1u, e1v, e1f, pi, pj ) ! scale factors - IF ( PRESENT(pe2 ) ) pe2 = icb_utl_bilin_e( e2t, e2u, e2v, e2f, pi, pj ) + IF ( PRESENT(pe1 ) ) pe1 = icb_utl_bilin_e( e1t, CASTSP(e1u), e1v, e1f, pi, pj ) ! scale factors + IF ( PRESENT(pe2 ) ) pe2 = icb_utl_bilin_e( e2t, e2u, CASTSP(e2v), e2f, pi, pj ) IF ( PRESENT(plon) ) plon= icb_utl_bilin_h( rlon_e, iiT, ijT, zwT, .true. ) IF ( PRESENT(plat) ) plat= icb_utl_bilin_h( rlat_e, iiT, ijT, zwT, .false. ) ! @@ -217,14 +218,14 @@ CONTAINS CALL icb_utl_pos( pi+0.1_wp, pj , 'T', iiTp, ijTp, zwTp, zmskTp ) CALL icb_utl_pos( pi-0.1_wp, pj , 'T', iiTm, ijTm, zwTm, zmskTm ) ! - IF ( .NOT. PRESENT(pe1) ) pe1 = icb_utl_bilin_e( e1t, e1u, e1v, e1f, pi, pj ) + IF ( .NOT. PRESENT(pe1) ) pe1 = icb_utl_bilin_e( e1t, CASTSP(e1u), e1v, e1f, pi, pj ) pssh_i = ( icb_utl_bilin_h( ssh_e, iiTp, ijTp, zwTp*zmskTp, .false. ) - & & icb_utl_bilin_h( ssh_e, iiTm, ijTm, zwTm*zmskTm, .false. ) ) / ( 0.2_wp * pe1 ) ! CALL icb_utl_pos( pi , pj+0.1_wp, 'T', iiTp, ijTp, zwTp, zmskTp ) CALL icb_utl_pos( pi , pj-0.1_wp, 'T', iiTm, ijTm, zwTm, zmskTm ) ! - IF ( .NOT. PRESENT(pe2) ) pe2 = icb_utl_bilin_e( e2t, e2u, e2v, e2f, pi, pj ) + IF ( .NOT. PRESENT(pe2) ) pe2 = icb_utl_bilin_e( e2t, e2u, CASTSP(e2v), e2f, pi, pj ) pssh_j = ( icb_utl_bilin_h( ssh_e, iiTp, ijTp, zwTp*zmskTp, .false. ) - & & icb_utl_bilin_h( ssh_e, iiTm, ijTm, zwTm*zmskTm, .false. ) ) / ( 0.2_wp * pe2 ) END IF @@ -266,10 +267,10 @@ CONTAINS !!---------------------------------------------------------------------- REAL(wp) , INTENT(IN) :: pi, pj ! targeted coordinates in (i,j) referential CHARACTER(len=1) , INTENT(IN) :: cd_type ! point type - REAL(dp), DIMENSION(4), INTENT(OUT) :: pw, pmsk ! weight and mask + REAL(wp), DIMENSION(4), INTENT(OUT) :: pw, pmsk ! weight and mask INTEGER , INTENT(OUT) :: kii, kij ! bottom left corner position in local domain ! - REAL(dp) :: zwi, zwj ! distance to bottom left corner + REAL(wp) :: zwi, zwj ! distance to bottom left corner INTEGER :: ierr ! !!---------------------------------------------------------------------- @@ -281,23 +282,23 @@ CONTAINS ! current T cell kii = MAX(0, INT( pi )) kij = MAX(0, INT( pj )) ! T-point - zwi = pi - REAL(kii,dp) - zwj = pj - REAL(kij,dp) + zwi = pi - REAL(kii,wp) + zwj = pj - REAL(kij,wp) CASE ( 'U' ) kii = MAX(0, INT( pi-0.5_wp )) kij = MAX(0, INT( pj )) ! U-point - zwi = pi - 0.5_wp - REAL(kii,dp) - zwj = pj - REAL(kij,dp) + zwi = pi - 0.5_wp - REAL(kii,wp) + zwj = pj - REAL(kij,wp) CASE ( 'V' ) kii = MAX(0, INT( pi )) kij = MAX(0, INT( pj-0.5_wp )) ! V-point - zwi = pi - REAL(kii,dp) - zwj = pj - 0.5_wp - REAL(kij,dp) + zwi = pi - REAL(kii,wp) + zwj = pj - 0.5_wp - REAL(kij,wp) CASE ( 'F' ) kii = MAX(0, INT( pi-0.5_wp )) kij = MAX(0, INT( pj-0.5_wp )) ! F-point - zwi = pi - 0.5_wp - REAL(kii,dp) - zwj = pj - 0.5_wp - REAL(kij,dp) + zwi = pi - 0.5_wp - REAL(kii,wp) + zwj = pj - 0.5_wp - REAL(kij,wp) END SELECT kii = kii + (nn_hls-1) kij = kij + (nn_hls-1) @@ -359,7 +360,7 @@ CONTAINS END SELECT END SUBROUTINE icb_utl_pos - REAL(dp) FUNCTION icb_utl_bilin_2d_h( pfld, pii, pij, pw, pllon ) + REAL(wp) FUNCTION icb_utl_bilin_2d_h( pfld, pii, pij, pw, pllon ) !!---------------------------------------------------------------------- !! *** FUNCTION icb_utl_bilin *** !! @@ -370,12 +371,12 @@ CONTAINS !! the slip/no-slip conditions ==>>> to be done later !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(0:jpi+1,0:jpj+1), INTENT(in) :: pfld ! field to be interpolated - REAL(dp), DIMENSION(4) , INTENT(in) :: pw ! weight + REAL(wp), DIMENSION(0:jpi+1,0:jpj+1), INTENT(in) :: pfld ! field to be interpolated + REAL(wp), DIMENSION(4) , INTENT(in) :: pw ! weight LOGICAL , INTENT(in) :: pllon ! input data is a longitude INTEGER , INTENT(in) :: pii, pij ! bottom left corner ! - REAL(dp), DIMENSION(4) :: zdat ! input data + REAL(wp), DIMENSION(4) :: zdat ! input data !!---------------------------------------------------------------------- ! ! data @@ -406,12 +407,12 @@ CONTAINS !! the slip/no-slip conditions ==>>> to be done later !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(0:jpi+1,0:jpj+1, jpk), INTENT(in) :: pfld ! field to be interpolated - REAL(dp), DIMENSION(4,jpk) , INTENT(in) :: pw ! weight + REAL(wp), DIMENSION(0:jpi+1,0:jpj+1, jpk), INTENT(in) :: pfld ! field to be interpolated + REAL(wp), DIMENSION(4,jpk) , INTENT(in) :: pw ! weight INTEGER , INTENT(in) :: pii, pij ! bottom left corner - REAL(dp), DIMENSION(jpk) :: icb_utl_bilin_3d_h + REAL(wp), DIMENSION(jpk) :: icb_utl_bilin_3d_h ! - REAL(dp), DIMENSION(4,jpk) :: zdat ! input data + REAL(wp), DIMENSION(4,jpk) :: zdat ! input data INTEGER :: jk !!---------------------------------------------------------------------- ! @@ -429,7 +430,7 @@ CONTAINS ! END FUNCTION icb_utl_bilin_3d_h - REAL(dp) FUNCTION icb_utl_bilin_e( pet, peu, pev, pef, pi, pj ) + REAL(wp) FUNCTION icb_utl_bilin_e( pet, peu, pev, pef, pi, pj ) !!---------------------------------------------------------------------- !! *** FUNCTION dom_init *** !! @@ -437,16 +438,17 @@ CONTAINS !! ** Method : interpolation done using the 4 nearest grid points among !! t-, u-, v-, and f-points. !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:), INTENT(in) :: pet, peu, pev, pef ! horizontal scale factor to be interpolated at t-,u-,v- & f-pts + REAL(wp), DIMENSION(:,:), INTENT(in) :: peu, pev! horizontal scale factor to be interpolated at t-,u-,v- & f-pts + REAL(dp), DIMENSION(:,:), INTENT(in) :: pet, pef! horizontal scale factor to be interpolated at t-,u-,v- & f-pts REAL(wp) , INTENT(IN) :: pi , pj ! iceberg position ! ! weights corresponding to corner points of a T cell quadrant - REAL(dp) :: zi, zj ! local real + REAL(wp) :: zi, zj ! local real INTEGER :: ii, ij ! bottom left corner coordinate in local domain ! ! values at corner points of a T cell quadrant ! 00 = bottom left, 10 = bottom right, 01 = top left, 11 = top right - REAL(dp) :: ze00, ze10, ze01, ze11 + REAL(wp) :: ze00, ze10, ze01, ze11 !!---------------------------------------------------------------------- ! ! cannot used iiT because need ii/ij reltaive to global indices not local one @@ -458,8 +460,8 @@ CONTAINS ! 0 <= zi < 0.5, 0.5 <= zj < 1 --> SE quadrant ! 0.5 <= zi < 1 , 0.5 <= zj < 1 --> SW quadrant - zi = pi - REAL(ii,dp) !!gm use here mig, mjg arrays - zj = pj - REAL(ij,dp) + zi = pi - REAL(ii,wp) !!gm use here mig, mjg arrays + zj = pj - REAL(ij,wp) ! conversion to local domain (no need to do a sanity check already done in icbpos) ii = mi1(ii) + (nn_hls-1) @@ -508,11 +510,11 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER, INTENT(out):: kb - REAL(dp), DIMENSION(:), INTENT(in) :: pe3 - REAL(dp), INTENT(in) :: pD + REAL(wp), DIMENSION(:), INTENT(in) :: pe3 + REAL(wp), INTENT(in) :: pD !! INTEGER :: jk - REAL(dp) :: zdepw + REAL(wp) :: zdepw !!---------------------------------------------------------------------- !! zdepw = pe3(1) ; kb = 2 @@ -531,12 +533,12 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: kb ! deepest level affected by icb - REAL(dp), DIMENSION(:), INTENT(in ) :: pe3, pdat ! vertical profile - REAL(dp), INTENT(in ) :: pD ! draft - REAL(dp), INTENT(out) :: pzavg ! z average + REAL(wp), DIMENSION(:), INTENT(in ) :: pe3, pdat ! vertical profile + REAL(wp), INTENT(in ) :: pD ! draft + REAL(wp), INTENT(out) :: pzavg ! z average !!---------------------------------------------------------------------- INTEGER :: jk - REAL(dp) :: zdep + REAL(wp) :: zdep !!---------------------------------------------------------------------- pzavg = 0.0 ; zdep = 0.0 DO jk = 1,kb-1 @@ -627,7 +629,7 @@ CONTAINS END SUBROUTINE icb_utl_insert - REAL(dp) FUNCTION icb_utl_yearday(kmon, kday, khr, kmin, ksec) + REAL(wp) FUNCTION icb_utl_yearday(kmon, kday, khr, kmin, ksec) !!---------------------------------------------------------------------- !! *** FUNCTION icb_utl_yearday *** !! @@ -643,8 +645,8 @@ CONTAINS INTEGER, DIMENSION(12) :: imonths = (/ 0,31,28,31,30,31,30,31,31,30,31,30 /) !!---------------------------------------------------------------------- ! - icb_utl_yearday = REAL( SUM( imonths(1:kmon) ),dp ) - icb_utl_yearday = icb_utl_yearday + REAL(kday-1,dp) + (REAL(khr,dp) + (REAL(kmin,dp) + REAL(ksec,dp)/60.)/60.)/24. + icb_utl_yearday = REAL( SUM( imonths(1:kmon) ), wp ) + icb_utl_yearday = icb_utl_yearday + REAL(kday-1,wp) + (REAL(khr,wp) + (REAL(kmin,wp) + REAL(ksec,wp)/60.)/60.)/24. ! END FUNCTION icb_utl_yearday @@ -830,7 +832,7 @@ CONTAINS END FUNCTION icb_utl_count - REAL(dp) FUNCTION icb_utl_mass( first, justbits, justbergs ) + REAL(wp) FUNCTION icb_utl_mass( first, justbits, justbergs ) !!---------------------------------------------------------------------- !! *** FUNCTION icb_utl_mass *** !! @@ -868,7 +870,7 @@ CONTAINS END FUNCTION icb_utl_mass - REAL(dp) FUNCTION icb_utl_heat( first, justbits, justbergs ) + REAL(wp) FUNCTION icb_utl_heat( first, justbits, justbergs ) !!---------------------------------------------------------------------- !! *** FUNCTION icb_utl_heat *** !! @@ -916,8 +918,9 @@ CONTAINS !! ** Comments : not called, if needed a CALL test_icb_utl_getkb need to be added in icb_step !!---------------------------------------------------------------------- INTEGER :: ikb - REAL(dp) :: zD, zout - REAL(dp), DIMENSION(jpk) :: ze3, zin + REAL(wp) :: zout + REAL(wp) :: zD + REAL(wp), DIMENSION(jpk) :: ze3, zin WRITE(numout,*) 'Test icb_utl_getkb : ' zD = 0.0 ; ze3= 20.0 WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) diff --git a/src/OCE/IOM/iom.F90 b/src/OCE/IOM/iom.F90 index adf43adb41ab055c7e6522affd0b331d6bef6205..007f1e60ec56d69e088f046128633fbdd889503a 100644 --- a/src/OCE/IOM/iom.F90 +++ b/src/OCE/IOM/iom.F90 @@ -95,7 +95,6 @@ MODULE iom END INTERFACE iom_put !! * Substitutions -# include "single_precision_substitute.h90" # include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -253,23 +252,23 @@ CONTAINS 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",CASTDP((/ (REAL(ji,dp), ji=1,jpnfl) /)) ) + CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) # if defined key_si3 - CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,dp), ji=1,jpl) /) ) + 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,dp), ji=1,4) /) ) + 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",CASTDP((/ REAL(20,dp) /)) ) ! strange syntaxe and idea... - CALL iom_set_axis_attr( "iax_26C",CASTDP((/ REAL(26,dp) /)) ) ! strange syntaxe and idea... - CALL iom_set_axis_attr( "iax_28C",CASTDP((/ REAL(28,dp) /)) ) ! strange syntaxe and idea... + 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" ,CASTDP((/ (REAL(ji,dp), ji=1,nbasin) /)) ) + CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,nbasin) /) ) ENDIF ! ! automatic definitions of some of the xml attributs @@ -618,10 +617,10 @@ CONTAINS 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,dp), ji=1,jpl) /) ) + 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",CASTDP((/ (REAL(ji,dp), ji=1,jpka) /)) ) + 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 @@ -2196,7 +2195,7 @@ CONTAINS !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- CHARACTER(LEN=*) , INTENT(in) :: cdid - REAL(dp), DIMENSION(:) , OPTIONAL, INTENT(in) :: paxis + REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: paxis REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds !!---------------------------------------------------------------------- IF( PRESENT(paxis) ) THEN @@ -2313,8 +2312,8 @@ CONTAINS !! ** Purpose : define horizontal grids !!---------------------------------------------------------------------- CHARACTER(LEN=1) , INTENT(in) :: cdgrd - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: plon - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: plat + 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 @@ -2382,8 +2381,8 @@ CONTAINS !! !!---------------------------------------------------------------------- CHARACTER(LEN=1) , INTENT(in) :: cdgrd - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: plon_cnr, plat_cnr ! Lat/lon coord. of a contiguous vertex of cell (i,j) - REAL(dp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coord. of the point of cell (i,j) + 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) @@ -2442,7 +2441,7 @@ CONTAINS !! ** Purpose : define grids for zonal mean !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: plat + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat ! INTEGER :: ix, iy REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon @@ -2476,7 +2475,7 @@ CONTAINS 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,dp ) + zz = REAL( narea, wp ) CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) ! END SUBROUTINE set_scalar @@ -2594,20 +2593,20 @@ CONTAINS 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),dp) ) THEN ; WRITE(clon, '(i3, a)') NINT( zlon), 'e' + 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),dp) ) THEN ; WRITE(clon, '(i3, a)') NINT(-zlon), 'w' + 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),dp) ) THEN ; WRITE(clat, '(i2, a)') NINT( zlat), 'n' + 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),dp) ) THEN ; WRITE(clat, '(i2, a)') NINT(-zlat), 's' + IF( zlat == REAL(NINT(zlat), wp) ) THEN ; WRITE(clat, '(i2, a)') NINT(-zlat), 's' ELSE ; WRITE(clat, '(f4.1,a)') -zlat , 's' ENDIF ENDIF @@ -2706,14 +2705,14 @@ CONTAINS ! idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') DO WHILE ( idx /= 0 ) - cldate = iom_sdate( fjulday + rn_Dt / rday * REAL( nitend - nit000,dp ), ld24 = .TRUE. ) + 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,dp ), ld24 = .TRUE., ldfull = .TRUE. ) + 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 @@ -2754,16 +2753,16 @@ CONTAINS ELSE ; llfull = .FALSE. ENDIF ! - CALL ju2ymds(REAL(pjday,dp), iyear, imonth, iday, zsec ) + 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( REAL(pjday,dp) - 1.0_dp, iyear, imonth, iday, zsec ) + 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,dp))) + 1 + ELSE ; WRITE(clfmt, "('i',i1,',2i2.2')") INT(LOG10(REAL(iyear,wp))) + 1 ENDIF ! !$AGRIF_DO_NOT_TREAT diff --git a/src/OCE/IOM/iom_nf90.F90 b/src/OCE/IOM/iom_nf90.F90 index 162b877e8ae0fc5c60e4d4c158f09358c7c0daa0..feb699e109fee54c3cc7521ec42fbad2c3905c92 100644 --- a/src/OCE/IOM/iom_nf90.F90 +++ b/src/OCE/IOM/iom_nf90.F90 @@ -111,7 +111,7 @@ CONTAINS iln = INDEX( cdname, '.nc' ) IF( ldwrt ) THEN !* the file should be open in write mode so we create it... IF( jpnij > 1 ) THEN - idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' WRITE(cltmp,clfmt) cdname(1:iln-1), '_', narea-1, '.nc' cdname = TRIM(cltmp) diff --git a/src/OCE/IOM/prtctl.F90 b/src/OCE/IOM/prtctl.F90 index f260f89d4c18e5c08633b0b10b5607b49d93f955..80f95b18d7f8664fb4e022fc7f23e0c170c98c02 100644 --- a/src/OCE/IOM/prtctl.F90 +++ b/src/OCE/IOM/prtctl.F90 @@ -18,9 +18,9 @@ MODULE prtctl INTEGER , DIMENSION( :), ALLOCATABLE :: numprt_oce, numprt_top INTEGER , DIMENSION( :), ALLOCATABLE :: nall_ictls, nall_ictle ! first, last indoor index for each i-domain INTEGER , DIMENSION( :), ALLOCATABLE :: nall_jctls, nall_jctle ! first, last indoor index for each j-domain - REAL(dp), DIMENSION( :), ALLOCATABLE :: t_ctl , s_ctl ! previous tracer trend values - REAL(dp), DIMENSION( :), ALLOCATABLE :: u_ctl , v_ctl ! previous velocity trend values - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl ! previous top trend values + REAL(wp), DIMENSION( :), ALLOCATABLE :: t_ctl , s_ctl ! previous tracer trend values + REAL(wp), DIMENSION( :), ALLOCATABLE :: u_ctl , v_ctl ! previous velocity trend values + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl ! previous top trend values ! PUBLIC prt_ctl ! called by all subroutines PUBLIC prt_ctl_info ! called by all subroutines @@ -38,11 +38,11 @@ CONTAINS SUBROUTINE prt_ctl (tab2d_1, tab3d_1, tab4d_1, tab2d_2, tab3d_2, mask1, mask2, & & clinfo, clinfo1, clinfo2, clinfo3, kdim ) !! - REAL(dp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 - REAL(dp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1 - REAL(dp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1 - REAL(dp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 - REAL(dp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2 + REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1 + REAL(wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1 + REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array @@ -51,32 +51,32 @@ CONTAINS CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3 INTEGER , INTENT(in), OPTIONAL :: kdim ! - IF( PRESENT(tab2d_2) ) THEN - CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = is_tile(tab2d_2), ktab3d_2 = 0, & - & tab2d_1 = REAL(tab2d_1,dp), tab2d_2 = REAL(tab2d_2,dp), & - & mask1 = mask1, mask2 = mask2, & - & clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3 ) - ELSEIF( PRESENT(tab3d_2) ) THEN - CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = is_tile(tab3d_2), & - & tab3d_1 = REAL(tab3d_1,dp), tab3d_2 = REAL(tab3d_2,dp), & - & mask1 = mask1, mask2 = mask2, & - & clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3, kdim = kdim ) - ELSEIF( PRESENT(tab2d_1) ) THEN - CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, & - & tab2d_1 = REAL(tab2d_1,dp), & - & mask1 = mask1, & - & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3 ) - ELSEIF( PRESENT(tab3d_1) ) THEN - CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, & - & tab3d_1 = REAL(tab3d_1,dp), & - & mask1 = mask1, & - & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim ) - ELSEIF( PRESENT(tab4d_1) ) THEN - CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = 0, ktab4d_1 = is_tile(tab4d_1), ktab2d_2 = 0, ktab3d_2 = 0, & - & tab4d_1 = REAL(tab4d_1,dp), & - & mask1 = mask1, & - & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim ) - ENDIF + !IF( PRESENT(tab2d_2) ) THEN + !CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = is_tile(tab2d_2), ktab3d_2 = 0, & + ! & tab2d_1 = REAL(tab2d_1, wp), tab2d_2 = REAL(tab2d_2, wp), & + ! & mask1 = mask1, mask2 = mask2, & + ! & clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3 ) + !ELSEIF( PRESENT(tab3d_2) ) THEN + !CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = is_tile(tab3d_2), & + ! & tab3d_1 = REAL(tab3d_1, wp), tab3d_2 = REAL(tab3d_2, wp), & + ! & mask1 = mask1, mask2 = mask2, & + ! & clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3, kdim = kdim ) + ! ELSEIF( PRESENT(tab2d_1) ) THEN + !CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, & + ! & tab2d_1 = REAL(tab2d_1,wp), & + ! & mask1 = mask1, & + ! & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3 ) + !ELSEIF( PRESENT(tab3d_1) ) THEN + !CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, & + ! & tab3d_1 = REAL(tab3d_1, wp), & + ! & mask1 = mask1, & + ! & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim ) +! ELSEIF( PRESENT(tab4d_1) ) THEN + !CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = 0, ktab4d_1 = is_tile(tab4d_1), ktab2d_2 = 0, ktab3d_2 = 0, & + ! & tab4d_1 = REAL(tab4d_1, wp), & + ! & mask1 = mask1, & + ! & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim ) + ! ENDIF END SUBROUTINE prt_ctl @@ -104,7 +104,7 @@ CONTAINS !! - All arguments of the above calling sequence are optional so their !! name must be explicitly typed if used. For instance if the 3D !! array tn(:,:,:) must be passed through the prt_ctl subroutine, - !! it must look like: CALL prt_ctl(tab3d_1=tn). + !! it must look like: !CALL prt_ctl(tab3d_1=tn). !! !! tab2d_1 : first 2D array !! tab3d_1 : first 3D array @@ -119,11 +119,11 @@ CONTAINS !! clinfo3 : additional information !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2 - REAL(dp), DIMENSION(A2D_T(ktab2d_1)) , INTENT(in), OPTIONAL :: tab2d_1 - REAL(dp), DIMENSION(A2D_T(ktab3d_1),:) , INTENT(in), OPTIONAL :: tab3d_1 - REAL(dp), DIMENSION(A2D_T(ktab4d_1),:,:), INTENT(in), OPTIONAL :: tab4d_1 - REAL(dp), DIMENSION(A2D_T(ktab2d_2)) , INTENT(in), OPTIONAL :: tab2d_2 - REAL(dp), DIMENSION(A2D_T(ktab3d_2),:) , INTENT(in), OPTIONAL :: tab3d_2 + REAL(wp), DIMENSION(A2D_T(ktab2d_1)) , INTENT(in), OPTIONAL :: tab2d_1 + REAL(wp), DIMENSION(A2D_T(ktab3d_1),:) , INTENT(in), OPTIONAL :: tab3d_1 + REAL(wp), DIMENSION(A2D_T(ktab4d_1),:,:), INTENT(in), OPTIONAL :: tab4d_1 + REAL(wp), DIMENSION(A2D_T(ktab2d_2)) , INTENT(in), OPTIONAL :: tab2d_2 + REAL(wp), DIMENSION(A2D_T(ktab3d_2),:) , INTENT(in), OPTIONAL :: tab3d_2 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array @@ -137,7 +137,7 @@ CONTAINS INTEGER :: jn, jl, kdir INTEGER :: iis, iie, jjs, jje INTEGER :: itra, inum - REAL(dp) :: zsum1, zsum2, zvctl1, zvctl2 + REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2 !!---------------------------------------------------------------------- ! ! Arrays, scalars initialization @@ -320,7 +320,7 @@ CONTAINS ! IF( jpnij > 1 ) THEN ! MULTI processor run cl_run = 'MULTI processor run' - idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)' WRITE(clfile_out,clfmt) 'mpp.'//trim(clname)//'_', narea - 1 ijsplt = 1 @@ -338,7 +338,7 @@ CONTAINS IF( ijsplt == 1 ) CALL ctl_warn( 'nn_isplt & nn_jsplt are equal to 1 -> control sum done over the whole domain' ) IF(lwp) WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt IF(lwp) WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt - idg = MAX( INT(LOG10(REAL(MAX(1,ijsplt-1),dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(MAX(1,ijsplt-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)' IF( ijsplt == 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', 0 ELSE ! print control done over a specific area @@ -364,7 +364,7 @@ CONTAINS WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle idg = MAXVAL( (/ nn_ictls,nn_ictle,nn_jctls,nn_jctle /) ) ! temporary use of idg to store the largest index - idg = MAX( INT(LOG10(REAL(idg,dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(idg,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 WRITE(clfmt, "('(4(a,i', i1, '.', i1, '))')") idg, idg ! '(4(a,ix.x))' WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', nn_ictls, '_', nn_ictle, '_', nn_jctls, '_', nn_jctle ENDIF @@ -459,9 +459,9 @@ CONTAINS ! clfmt6: ' nimpp = XXX' -> '(Nx, a9, iM)' ! idg = MAXVAL( (/ nall_ictls(jl), nall_ictle(jl), nall_jctls(jl), nall_jctle(jl) /) ) ! temporary use of idg - idg = INT(LOG10(REAL(idg,dp))) + 1 ! how many digits do we use? + idg = INT(LOG10(REAL(idg,wp))) + 1 ! how many digits do we use? idg2 = MAXVAL( (/ mig0(nall_ictls(jl)), mig0(nall_ictle(jl)), mjg0(nall_jctls(jl)), mjg0(nall_jctle(jl)) /) ) - idg2 = INT(LOG10(REAL(idg2,dp))) + 1 ! how many digits do we use? + idg2 = INT(LOG10(REAL(idg2,wp))) + 1 ! how many digits do we use? WRITE(clfmt2, "('(18x, 13a1, a9, i', i1, ', a2, i',i1,', a2, 13a1)')") idg, idg2 WRITE(clfmt3, "('(18x, a1, ', i2,'x, a1)')") 13+9+idg+2+idg2+2+13 - 2 WRITE(clfmt4, "('(', i2,'x, a9, i', i1,', a2, i', i1,', a2, ', i2,'x, a9, i', i1,', a2, i', i1,', a2)')") & @@ -485,4 +485,4 @@ CONTAINS !!====================================================================== -END MODULE prtctl +END MODULE prtctl \ No newline at end of file diff --git a/src/OCE/IOM/restart.F90 b/src/OCE/IOM/restart.F90 index 60f4544a0be86cfab60d2945826074e525aa250e..1df18028eed594ec27b8426eceb467d2fd9a836f 100644 --- a/src/OCE/IOM/restart.F90 +++ b/src/OCE/IOM/restart.F90 @@ -264,8 +264,8 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices INTEGER :: jk - REAL(dp), DIMENSION(jpi, jpj, jpk) :: w3d - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zgdept ! 3D workspace for QCO + REAL(wp), DIMENSION(jpi, jpj, jpk) :: w3d + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zgdept ! 3D workspace for QCO !!---------------------------------------------------------------------- ! IF(.NOT.lrxios ) CALL iom_delay_rst( 'READ', 'OCE', numror ) ! read only ocean delayed global communication variables diff --git a/src/OCE/ISF/isf_oce.F90 b/src/OCE/ISF/isf_oce.F90 index 24d30c2e48fc05aae42330e46249023df5a8ce9b..3c27e9e873bd7360d7fb8cbad35f8bc1adfa8714 100644 --- a/src/OCE/ISF/isf_oce.F90 +++ b/src/OCE/ISF/isf_oce.F90 @@ -12,7 +12,6 @@ MODULE isf_oce !!---------------------------------------------------------------------- !! isf : define and allocate ice shelf variables !!---------------------------------------------------------------------- - USE par_kind USE par_oce , ONLY: jpi, jpj, jpk USE in_out_manager, ONLY: wp, jpts ! I/O manager @@ -36,11 +35,11 @@ MODULE isf_oce ! ! 0.2 -------- ice shelf cavity opened namelist parameter ------------- LOGICAL , PUBLIC :: ln_isfcav_mlt !: logical for the use of ice shelf parametrisation - REAL(dp) , PUBLIC :: rn_gammat0 !: temperature exchange coeficient [] - REAL(dp) , PUBLIC :: rn_gammas0 !: salinity exchange coeficient [] - REAL(dp) , PUBLIC :: rn_htbl !: Losch top boundary layer thickness [m] - REAL(dp) , PUBLIC :: rn_isfload_T !: - REAL(dp) , PUBLIC :: rn_isfload_S !: + REAL(wp) , PUBLIC :: rn_gammat0 !: temperature exchange coeficient [] + REAL(wp) , PUBLIC :: rn_gammas0 !: salinity exchange coeficient [] + REAL(wp) , PUBLIC :: rn_htbl !: Losch top boundary layer thickness [m] + REAL(wp) , PUBLIC :: rn_isfload_T !: + REAL(wp) , PUBLIC :: rn_isfload_S !: CHARACTER(LEN=256), PUBLIC :: cn_gammablk !: gamma formulation CHARACTER(LEN=256), PUBLIC :: cn_isfcav_mlt !: melt formulation (cavity/param) CHARACTER(LEN=256), PUBLIC :: cn_isfload !: ice shelf load computation method @@ -48,7 +47,7 @@ MODULE isf_oce ! ! 0.3 -------- ice shelf cavity parametrised namelist parameter ------------- LOGICAL , PUBLIC :: ln_isfpar_mlt !: logical for the computation of melt inside the cavity - REAL(dp) , PUBLIC :: rn_isfpar_bg03_gt0 !: temperature exchange coeficient [m/s] + REAL(wp) , PUBLIC :: rn_isfpar_bg03_gt0 !: temperature exchange coeficient [m/s] CHARACTER(LEN=256), PUBLIC :: cn_isfpar_mlt !: melt formulation (cavity/param) TYPE(FLD_N) , PUBLIC :: sn_isfpar_fwf !: information about the isf melting file to be read TYPE(FLD_N) , PUBLIC :: sn_isfpar_zmax !: information about the grounding line depth file to be read @@ -76,36 +75,36 @@ MODULE isf_oce ! ! 2.1 -------- ice shelf cavity parameter -------------- LOGICAL , PUBLIC :: l_isfoasis = .FALSE. - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfload !: ice shelf load - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_oasis + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfload !: ice shelf load + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_oasis ! ! 2.2 -------- ice shelf cavity melt namelist parameter ------------- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_cav !: INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_cav , misfkb_cav !: - REAL(dp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_cav, rfrac_tbl_cav !: - REAL(dp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_cav , fwfisf_cav_b !: before and now net fwf from the ice shelf [kg/m2/s] - REAL(dp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_cav_tsc , risf_cav_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s] + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_cav, rfrac_tbl_cav !: + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_cav , fwfisf_cav_b !: before and now net fwf from the ice shelf [kg/m2/s] + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_cav_tsc , risf_cav_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s] TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfcav_fwf !: ! - REAL(dp) , PUBLIC :: risf_lamb1, risf_lamb2, risf_lamb3 ! freezing point linearization coeficient + REAL(wp) , PUBLIC :: risf_lamb1, risf_lamb2, risf_lamb3 ! freezing point linearization coeficient ! ! 2.3 -------- ice shelf param. melt namelist parameter ------------- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_par !: INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_par , misfkb_par !: - REAL(dp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_par, rfrac_tbl_par !: - REAL(dp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_par , fwfisf_par_b !: before and now net fwf from the ice shelf [kg/m2/s] - REAL(dp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_par_tsc , risf_par_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s] + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_par, rfrac_tbl_par !: + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_par , fwfisf_par_b !: before and now net fwf from the ice shelf [kg/m2/s] + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_par_tsc , risf_par_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s] TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfpar_fwf !: ! - REAL(dp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf0_tbl_par !: thickness of tbl (initial value) [m] - REAL(dp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfLeff !: + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf0_tbl_par !: thickness of tbl (initial value) [m] + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfLeff !: ! ! 2.4 -------- coupling namelist parameter ------------- INTEGER , PUBLIC :: nstp_iscpl !: - REAL(dp), PUBLIC :: rdt_iscpl !: - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfcpl_ssh, risfcpl_cons_ssh, risfcpl_cons_ssh_b !: - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risfcpl_vol, risfcpl_cons_vol, risfcpl_cons_vol_b !: - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: risfcpl_tsc, risfcpl_cons_tsc, risfcpl_cons_tsc_b !: + REAL(wp), PUBLIC :: rdt_iscpl !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfcpl_ssh, risfcpl_cons_ssh, risfcpl_cons_ssh_b !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risfcpl_vol, risfcpl_cons_vol, risfcpl_cons_vol_b !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: risfcpl_tsc, risfcpl_cons_tsc, risfcpl_cons_tsc_b !: ! !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -269,4 +268,4 @@ CONTAINS END SUBROUTINE isf_alloc !!====================================================================== -END MODULE isf_oce +END MODULE isf_oce \ No newline at end of file diff --git a/src/OCE/ISF/isfcav.F90 b/src/OCE/ISF/isfcav.F90 index 6679cb43e6231576361b755bc11cc2fc211f61e0..a100225c9d566a4c4abd7867b03189791db3e95d 100644 --- a/src/OCE/ISF/isfcav.F90 +++ b/src/OCE/ISF/isfcav.F90 @@ -68,20 +68,20 @@ CONTAINS !! !!--------------------------------------------------------------------- !!-------------------------- OUT -------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) , INTENT(inout) :: pqfwf ! ice shelf fwf - REAL(dp), DIMENSION(jpi,jpj,jpts), INTENT(inout) :: ptsc ! T & S ice shelf cavity contents + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: pqfwf ! ice shelf fwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(inout) :: ptsc ! T & S ice shelf cavity contents !!-------------------------- IN -------------------------------------- INTEGER, INTENT(in) :: Kmm ! ocean time level index INTEGER, INTENT(in) :: kt ! ocean time step !!--------------------------------------------------------------------- LOGICAL :: lit INTEGER :: nit, ji, jj, ikt - REAL(dp) :: zerr - REAL(dp) :: zcoef, zdku, zdkv - REAL(dp), DIMENSION(jpi,jpj) :: zqlat, zqoce, zqhc, zqh ! heat fluxes - REAL(dp), DIMENSION(jpi,jpj) :: zqh_b, zRc ! - REAL(dp), DIMENSION(jpi,jpj) :: zgammat, zgammas ! exchange coeficient - REAL(dp), DIMENSION(jpi,jpj) :: zttbl, zstbl ! temp. and sal. in top boundary layer + REAL(wp) :: zerr + REAL(wp) :: zcoef, zdku, zdkv + REAL(wp), DIMENSION(jpi,jpj) :: zqlat, zqoce, zqhc, zqh ! heat fluxes + REAL(wp), DIMENSION(jpi,jpj) :: zqh_b, zRc ! + REAL(wp), DIMENSION(jpi,jpj) :: zgammat, zgammas ! exchange coeficient + REAL(wp), DIMENSION(jpi,jpj) :: zttbl, zstbl ! temp. and sal. in top boundary layer !!--------------------------------------------------------------------- ! ! compute T/S/U/V for the top boundary layer @@ -110,7 +110,7 @@ CONTAINS ! ! richardson number (minimum value set to zero) zRc(ji,jj) = MAX(rn2(ji,jj,ikt+1), 1.e-20_wp) / MAX( zdku*zdku + zdkv*zdkv, 1.e-20_wp ) END_2D - CALL lbc_lnk( 'isfmlt', zRc, 'T', 1._dp ) + CALL lbc_lnk( 'isfmlt', zRc, 'T', 1._wp ) ENDIF ! ! compute ice shelf melting @@ -169,7 +169,7 @@ CONTAINS ! set temperature content ptsc(ji,jj,jp_tem) = zqh(ji,jj) * r1_rho0_rcp END_2D - CALL lbc_lnk( 'isfmlt', pqfwf, 'T', 1.0_dp) + CALL lbc_lnk( 'isfmlt', pqfwf, 'T', 1.0_wp) ! ! output fluxes CALL isf_diags_flx( Kmm, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, 'cav', pqfwf, zqoce, zqlat, zqhc) @@ -266,4 +266,4 @@ CONTAINS ! END SUBROUTINE isf_cav_init -END MODULE isfcav +END MODULE isfcav \ No newline at end of file diff --git a/src/OCE/ISF/isfcavgam.F90 b/src/OCE/ISF/isfcavgam.F90 index 7193866a6756a4013a0e55694ccc4597af6b133c..e58a521d2d11ba0bd8690220f418275c1428598c 100644 --- a/src/OCE/ISF/isfcavgam.F90 +++ b/src/OCE/ISF/isfcavgam.F90 @@ -51,14 +51,14 @@ CONTAINS !! 3 method available (cst, vel and vel_stab) !!--------------------------------------------------------------------- !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pgt , pgs ! gamma t and gamma s + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt , pgs ! gamma t and gamma s !!-------------------------- IN ------------------------------------- INTEGER :: Kmm ! ocean time level index - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! isf heat and fwf - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! isf heat and fwf + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number !!--------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: zutbl, zvtbl ! top boundary layer velocity + REAL(wp), DIMENSION(jpi,jpj) :: zutbl, zvtbl ! top boundary layer velocity !!--------------------------------------------------------------------- ! !========================================== @@ -129,14 +129,14 @@ CONTAINS !! ** Reference : Asay-Davis et al., Geosci. Model Dev., 9, 2471-2497, 2016 !!--------------------------------------------------------------------- !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas [m/s] !!-------------------------- IN ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coefficient - REAL(dp), INTENT(in ) :: pke2 ! background velocity + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coefficient + REAL(wp), INTENT(in ) :: pke2 ! background velocity !!--------------------------------------------------------------------- INTEGER :: ji, jj ! loop index - REAL(dp), DIMENSION(jpi,jpj) :: zustar + REAL(wp), DIMENSION(jpi,jpj) :: zustar !!--------------------------------------------------------------------- ! DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -163,32 +163,32 @@ CONTAINS !! ** Reference : Holland and Jenkins, 1999, JPO, p1787-1800 !!--------------------------------------------------------------------- !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas !!-------------------------- IN ------------------------------------- INTEGER :: Kmm ! ocean time level index - REAL(dp), INTENT(in ) :: pke2 ! background velocity squared - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! surface heat flux and fwf flux - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coeficient - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! tracer in the losch top boundary layer - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number + REAL(wp), INTENT(in ) :: pke2 ! background velocity squared + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! surface heat flux and fwf flux + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coeficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! tracer in the losch top boundary layer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number !!--------------------------------------------------------------------- INTEGER :: ji, jj ! loop index INTEGER :: ikt ! local integer - REAL(dp) :: zdku, zdkv ! U, V shear - REAL(dp) :: zPr, zSc ! Prandtl and Scmidth number - REAL(dp) :: zmob, zmols ! Monin Obukov length, coriolis factor at T point - REAL(dp) :: zbuofdep, zhnu ! Bouyancy length scale, sublayer tickness - REAL(dp) :: zhmax ! limitation of mol - REAL(dp) :: zetastar ! stability parameter - REAL(dp) :: zgmolet, zgmoles, zgturb ! contribution of modelecular sublayer and turbulence - REAL(dp) :: zcoef ! temporary coef - REAL(dp) :: zdep - REAL(dp) :: zeps = 1.0e-20_wp + REAL(wp) :: zdku, zdkv ! U, V shear + REAL(wp) :: zPr, zSc ! Prandtl and Scmidth number + REAL(wp) :: zmob, zmols ! Monin Obukov length, coriolis factor at T point + REAL(wp) :: zbuofdep, zhnu ! Bouyancy length scale, sublayer tickness + REAL(wp) :: zhmax ! limitation of mol + REAL(wp) :: zetastar ! stability parameter + REAL(wp) :: zgmolet, zgmoles, zgturb ! contribution of modelecular sublayer and turbulence + REAL(wp) :: zcoef ! temporary coef + REAL(wp) :: zdep + REAL(wp) :: zeps = 1.0e-20_wp REAL(wp), PARAMETER :: zxsiN = 0.052_wp ! dimensionless constant REAL(wp), PARAMETER :: znu = 1.95e-6_wp ! kinamatic viscosity of sea water (m2.s-1) - REAL(dp), DIMENSION(2) :: zts, zab - REAL(dp), DIMENSION(jpi,jpj) :: zustar ! friction velocity + REAL(wp), DIMENSION(2) :: zts, zab + REAL(wp), DIMENSION(jpi,jpj) :: zustar ! friction velocity !!--------------------------------------------------------------------- ! ! compute Pr and Sc number (eq ??) diff --git a/src/OCE/ISF/isfcavmlt.F90 b/src/OCE/ISF/isfcavmlt.F90 index bc6d940fb13d28bf3d240aa872f2b92506d9e1c7..b6c8d30b1b33effb53f4a38c57a46904f5ceddef 100644 --- a/src/OCE/ISF/isfcavmlt.F90 +++ b/src/OCE/ISF/isfcavmlt.F90 @@ -54,11 +54,11 @@ CONTAINS !! ** Purpose : compute or read ice shelf fwf/heat fluxes in the ice shelf cavity !! !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat and fwf fluxes + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat and fwf fluxes !!-------------------------- IN ------------------------------------- INTEGER, INTENT(in) :: kt - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt , pgs ! gamma t and gamma s - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt , pgs ! gamma t and gamma s + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer !!--------------------------------------------------------------------- ! ! compute latent heat and melt (2d) @@ -104,16 +104,16 @@ CONTAINS !! - compute heat content flux !!--------------------------------------------------------------------- !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes !!-------------------------- IN ------------------------------------- INTEGER , INTENT(in ) :: kt ! current time step - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pstbl ! salinity in tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pstbl ! salinity in tbl !!-------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature !!-------------------------------------------------------------------- ! ! Compute freezing temperature - CALL eos_fzp( CASTDP(pstbl(:,:)), ztfrz(:,:), risfdep(:,:) ) + CALL eos_fzp( pstbl(:,:), ztfrz(:,:), CASTDP(risfdep(:,:)) ) ! ! read input file of fwf (from isf to oce; ie melt) CALL fld_read ( kt, 1, sf_isfcav_fwf ) @@ -148,17 +148,17 @@ CONTAINS !! http://staff.acecrc.org.au/~bkgalton/ISOMIP/test_cavities.pdf (last access: 21 July 2016), 2006. !! !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! hean content, ocean-ice heat and fwf fluxes + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! hean content, ocean-ice heat and fwf fluxes !!-------------------------- IN ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt ! temperature exchange coeficient - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! temperature and salinity in top boundary layer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt ! temperature exchange coeficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! temperature and salinity in top boundary layer !!-------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: ztfrz ! freezing temperature - REAL(dp), DIMENSION(jpi,jpj) :: zthd ! thermal driving + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing temperature + REAL(wp), DIMENSION(jpi,jpj) :: zthd ! thermal driving !!-------------------------------------------------------------------- ! ! Calculate freezing temperature - CALL eos_fzp( CASTDP(pstbl(:,:)), ztfrz(:,:), risfdep(:,:) ) + CALL eos_fzp( pstbl(:,:), ztfrz(:,:), CASTDP(risfdep(:,:)) ) ! ! thermal driving zthd (:,:) = ( pttbl(:,:) - ztfrz(:,:) ) * mskisf_cav(:,:) @@ -196,17 +196,17 @@ CONTAINS !! Geosci. Model Dev., 9, 2471-2497, https://doi.org/10.5194/gmd-9-2471-2016, 2016. !! !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! latent heat and fwf fluxes + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! latent heat and fwf fluxes !!-------------------------- IN ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt , pgs ! heat/salt exchange coeficient - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! mean temperature and salinity in top boundary layer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt , pgs ! heat/salt exchange coeficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! mean temperature and salinity in top boundary layer !!-------------------------------------------------------------------- - REAL(dp) :: zeps1,zeps2,zeps3,zeps4,zeps6,zeps7 ! dummy local scalar for quadratic equation resolution - REAL(dp) :: zaqe,zbqe,zcqe,zaqer,zdis,zsfrz,zcfac ! dummy local scalar for quadratic equation resolution - REAL(dp) :: zeps = 1.e-20 - REAL(dp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point - REAL(dp), DIMENSION(jpi,jpj) :: zqcon ! conductive flux through the ice shelf - REAL(dp), DIMENSION(jpi,jpj) :: zthd ! thermal driving + REAL(wp) :: zeps1,zeps2,zeps3,zeps4,zeps6,zeps7 ! dummy local scalar for quadratic equation resolution + REAL(wp) :: zaqe,zbqe,zcqe,zaqer,zdis,zsfrz,zcfac ! dummy local scalar for quadratic equation resolution + REAL(wp) :: zeps = 1.e-20 + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point + REAL(wp), DIMENSION(jpi,jpj) :: zqcon ! conductive flux through the ice shelf + REAL(wp), DIMENSION(jpi,jpj) :: zthd ! thermal driving ! INTEGER :: ji, jj ! dummy loop indices !!-------------------------------------------------------------------- @@ -271,18 +271,18 @@ CONTAINS !! !!--------------------------------------------------------------------- !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes !!-------------------------- IN ------------------------------------- INTEGER , INTENT(in ) :: kt ! current time step - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pstbl ! salinity in tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pstbl ! salinity in tbl !!-------------------------------------------------------------------- - REAL(dp) :: zfwf_fld, zfwf_oasis ! total fwf in the forcing fields (pattern) and from the oasis interface (amount) - REAL(dp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature - REAL(dp), DIMENSION(jpi,jpj) :: zfwf ! 2d fwf map after scaling + REAL(wp) :: zfwf_fld, zfwf_oasis ! total fwf in the forcing fields (pattern) and from the oasis interface (amount) + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature + REAL(wp), DIMENSION(jpi,jpj) :: zfwf ! 2d fwf map after scaling !!-------------------------------------------------------------------- ! ! Calculate freezing temperature - CALL eos_fzp( CASTDP(pstbl(:,:)), ztfrz(:,:), risfdep(:,:) ) + CALL eos_fzp( pstbl(:,:), ztfrz(:,:), CASTDP(risfdep(:,:)) ) ! ! read input file of fwf from isf to oce CALL fld_read ( kt, 1, sf_isfcav_fwf ) diff --git a/src/OCE/ISF/isfcpl.F90 b/src/OCE/ISF/isfcpl.F90 index d41b1c26cecb64e9c2bdadc10500fc8be486bce5..5a70f9f9f1c82ee6efead92fd46c5c786ba195c5 100644 --- a/src/OCE/ISF/isfcpl.F90 +++ b/src/OCE/ISF/isfcpl.F90 @@ -136,7 +136,7 @@ CONTAINS INTEGER, INTENT(in) :: Kmm ! ocean time level index !!---------------------------------------------------------------------- INTEGER :: jk ! loop index - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! for qco substitution + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! for qco substitution !!---------------------------------------------------------------------- ! DO jk = 1, jpk @@ -172,8 +172,8 @@ CONTAINS INTEGER :: ji, jj, jd, jk !! loop index INTEGER :: jip1, jim1, jjp1, jjm1 !! - REAL(dp):: zsummsk - REAL(dp), DIMENSION(jpi,jpj) :: zdssmask, zssmask0, zssmask_b, zssh + REAL(wp):: zsummsk + REAL(wp), DIMENSION(jpi,jpj) :: zdssmask, zssmask0, zssmask_b, zssh !!---------------------------------------------------------------------- ! CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b ) ! need to extrapolate T/S @@ -201,7 +201,8 @@ CONTAINS zssmask_b(ji,jj) = 1._wp ENDIF END_2D - CALL lbc_lnk( 'isfcpl', ssh(:,:,Kmm), 'T', 1.0_dp, zssmask_b(:,:), 'T', 1.0_dp ) + CALL lbc_lnk( 'isfcpl', ssh(:,:,Kmm), 'T', 1.0_dp) + CALL lbc_lnk( 'isfcpl', zssmask_b(:,:), 'T', 1.0_wp ) ! zssh(:,:) = ssh(:,:,Kmm) zssmask0(:,:) = zssmask_b(:,:) @@ -214,7 +215,7 @@ CONTAINS ! ssh(:,:,Kbb) = ssh(:,:,Kmm) ! - IF ( ln_isfdebug ) CALL debug('isfcpl_ssh: sshn',ssh(:,:,Kmm)) + IF ( ln_isfdebug ) CALL debug('isfcpl_ssh: sshn',CASTSP(ssh(:,:,Kmm))) ! ! recompute the vertical scale factor, depth and water thickness IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)' @@ -245,19 +246,19 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: Kmm ! ocean time level index !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztmask_b + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b !REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: pdepw_b !! depth w before !! INTEGER :: ji, jj, jk, jd !! loop index INTEGER :: jip1, jim1, jjp1, jjm1, jkp1, jkm1 !! - REAL(dp):: zsummsk - REAL(dp):: zdz, zdzm1, zdzp1 + REAL(wp):: zsummsk + REAL(wp):: zdz, zdzm1, zdzp1 !! - REAL(dp), DIMENSION(jpi,jpj) :: zdmask - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztmask0, zwmaskn - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztmask1, zwmaskb, ztmp3d - REAL(dp), DIMENSION(jpi,jpj,jpk,jpts) :: zts0 + REAL(wp), DIMENSION(jpi,jpj) :: zdmask + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask0, zwmaskn + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask1, zwmaskb, ztmp3d + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts0 !!---------------------------------------------------------------------- ! CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b ) ! need to extrapolate T/S @@ -359,7 +360,8 @@ CONTAINS END_2D END DO ! - CALL lbc_lnk( 'isfcpl', ts(:,:,:,jp_tem,Kmm), 'T', 1.0_dp, ts(:,:,:,jp_sal,Kmm), 'T', 1.0_dp, ztmask1, 'T', 1.0_dp) + CALL lbc_lnk( 'isfcpl', ts(:,:,:,jp_tem,Kmm), 'T', 1.0_dp, ts(:,:,:,jp_sal,Kmm), 'T', 1.0_dp) + CALL lbc_lnk( 'isfcpl', ztmask1, 'T', 1.0_wp) ! ! update temperature and salinity and mask zts0(:,:,:,:) = ts(:,:,:,:,Kmm) @@ -403,9 +405,9 @@ CONTAINS INTEGER :: ji, jj, jk INTEGER :: ikb, ikt !! - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zqvolb, zqvoln ! vol flux div. before/after coupling - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ze3u_b, ze3v_b ! vertical scale factor before/after coupling - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztmask_b ! mask before coupling + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zqvolb, zqvoln ! vol flux div. before/after coupling + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3u_b, ze3v_b ! vertical scale factor before/after coupling + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b ! mask before coupling !!---------------------------------------------------------------------- ! CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b ) @@ -456,7 +458,7 @@ CONTAINS ! END_2D ! - CALL lbc_lnk( 'isfcpl', risfcpl_vol, 'T', 1.0_dp ) + CALL lbc_lnk( 'isfcpl', risfcpl_vol, 'T', 1.0_wp ) ! ! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh) ! @@ -505,13 +507,13 @@ CONTAINS INTEGER :: nisfl_area ! global number of cell concerned by the wet->dry case INTEGER, DIMENSION(jpnij) :: nisfl ! local number of cell concerned by the wet->dry case ! - REAL(dp) :: z1_sum, z1_rdtiscpl - REAL(dp) :: zdtem, zdsal, zdvol, zratio ! tem, sal, vol increment - REAL(dp) :: zlon , zlat ! target location - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztmask_b ! mask before - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ze3t_b ! scale factor before - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zt_b ! scale factor before - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zs_b ! scale factor before + REAL(wp) :: z1_sum, z1_rdtiscpl + REAL(wp) :: zdtem, zdsal, zdvol, zratio ! tem, sal, vol increment + REAL(wp) :: zlon , zlat ! target location + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b ! mask before + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t_b ! scale factor before + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zt_b ! scale factor before + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zs_b ! scale factor before !!---------------------------------------------------------------------- !============================================================================== @@ -629,10 +631,10 @@ CONTAINS ! ELSE IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN ! spread correction amoung neigbourg wet cells (vertical direction) - CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1.0_dp, 0) + CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1.0_wp, 0) ELSE ! need to find where to put correction in later on - CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1.0_dp, 1) + CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1.0_wp, 1) END IF END IF END DO @@ -692,8 +694,8 @@ CONTAINS risfcpl_cons_tsc(:,:,:,jp_tem) = risfcpl_cons_tsc(:,:,:,jp_tem) * tmask(:,:,:) ! ! add lbclnk - CALL lbc_lnk( 'isfcpl', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_dp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_dp, & - & risfcpl_cons_vol(:,:,:) , 'T', 1.0_dp) + CALL lbc_lnk( 'isfcpl', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, & + & risfcpl_cons_vol(:,:,:) , 'T', 1.0_wp) ! ! ssh correction (for dynspg_ts) DO jk = 1,jpk @@ -720,7 +722,7 @@ CONTAINS ! ! or source location (kfind=1) INTEGER, INTENT(in ), OPTIONAL :: kfind ! 0 target cell already found ! ! 1 target to be determined - REAL(dp), INTENT(in ) :: pdvol, pdsal, pdtem, pratio ! vol/sal/tem increment + REAL(wp), INTENT(in ) :: pdvol, pdsal, pdtem, pratio ! vol/sal/tem increment ! ! and ratio in case increment span over multiple cells. !!---------------------------------------------------------------------- INTEGER :: ifind @@ -751,15 +753,15 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: ki, kj, kk, kfind ! target point indices - REAL(dp), INTENT(in) :: plon, plat ! target point lon/lat - REAL(dp), INTENT(in) :: pvolinc, pteminc,psalinc ! correction increment for vol/temp/salt + REAL(wp), INTENT(in) :: plon, plat ! target point lon/lat + REAL(wp), INTENT(in) :: pvolinc, pteminc,psalinc ! correction increment for vol/temp/salt !!---------------------------------------------------------------------- INTEGER :: jj, ji, iig, ijg !!---------------------------------------------------------------------- ! ! define global indice of correction location iig = ki ; ijg = kj - IF ( kfind == 1 ) CALL dom_ngb( CASTSP(plon), CASTSP(plat), iig, ijg,'T', kk) + IF ( kfind == 1 ) CALL dom_ngb( plon, plat, iig, ijg,'T', kk) ! ! fill the correction array DO jj = mj0(ijg),mj1(ijg) diff --git a/src/OCE/ISF/isfdiags.F90 b/src/OCE/ISF/isfdiags.F90 index 303745bdd13f2bf648d152894b9e7df24064299e..fee359442bacb6a07ccb3375d487884dddc23d33 100644 --- a/src/OCE/ISF/isfdiags.F90 +++ b/src/OCE/ISF/isfdiags.F90 @@ -46,8 +46,8 @@ CONTAINS !!-------------------------- IN ------------------------------------- INTEGER, INTENT(in) :: Kmm ! ocean time level index INTEGER , DIMENSION(jpi,jpj), INTENT(in) :: ktop , kbot ! top and bottom level of the tbl - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqfwf, pqoce, pqlat, pqhc ! 2d var to map in 3d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqfwf, pqoce, pqlat, pqhc ! 2d var to map in 3d CHARACTER(LEN=3), INTENT(in) :: cdisf ! parametrisation or interactive melt !!--------------------------------------------------------------------- CHARACTER(LEN=256) :: cvarqfwf , cvarqoce , cvarqlat , cvarqhc @@ -86,14 +86,14 @@ CONTAINS !!-------------------------- IN ------------------------------------- INTEGER, INTENT(in) :: Kmm ! ocean time level index INTEGER , DIMENSION(jpi,jpj), INTENT(in) :: ktop , kbot ! top and bottom level of the tbl - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pvar2d ! 2d var to map in 3d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pvar2d ! 2d var to map in 3d CHARACTER(LEN=*), INTENT(in) :: cdvar !!--------------------------------------------------------------------- INTEGER :: ji, jj, jk ! loop indices INTEGER :: ikt, ikb ! top and bottom level of the tbl - REAL(dp), DIMENSION(jpi,jpj) :: zvar2d ! - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zvar3d ! 3d var to output + REAL(wp), DIMENSION(jpi,jpj) :: zvar2d ! + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvar3d ! 3d var to output !!--------------------------------------------------------------------- ! ! compute 3d output diff --git a/src/OCE/ISF/isfdynatf.F90 b/src/OCE/ISF/isfdynatf.F90 index 233b3fd32921c0ed931e3855d16668a3435c62d0..dbf13ba089b625438aeb982731d5a7c42f8f878d 100644 --- a/src/OCE/ISF/isfdynatf.F90 +++ b/src/OCE/ISF/isfdynatf.F90 @@ -38,7 +38,7 @@ CONTAINS !!-------------------------- OUT ------------------------------------- INTEGER , INTENT(in ) :: kt ! ocean time step INTEGER , INTENT(in ) :: Kmm ! ocean time level index - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3t_f ! time filtered scale factor to be corrected + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3t_f ! time filtered scale factor to be corrected ! REAL(wp) , INTENT(in ) :: pcoef ! rn_atfp * rn_Dt * r1_rho0 !!-------------------------------------------------------------------- @@ -67,14 +67,14 @@ CONTAINS !! !!-------------------------- IN ------------------------------------- INTEGER , INTENT(in ) :: Kmm ! ocean time level index - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3t_f ! time-filtered scale factor to be corrected + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3t_f ! time-filtered scale factor to be corrected INTEGER , DIMENSION(jpi,jpj) , INTENT(in ) :: ktop , kbot ! top and bottom level of tbl - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfrac, phtbl ! fraction of bottom cell included in tbl, tbl thickness - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf , pfwf_b ! now/before fwf + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfrac, phtbl ! fraction of bottom cell included in tbl, tbl thickness + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf , pfwf_b ! now/before fwf REAL(wp), INTENT(in ) :: pcoef ! rn_atfp * rn_Dt * r1_rho0 !!---------------------------------------------------------------------- INTEGER :: ji,jj,jk - REAL(dp), DIMENSION(jpi,jpj) :: zfwfinc + REAL(wp), DIMENSION(jpi,jpj) :: zfwfinc !!---------------------------------------------------------------------- ! ! compute fwf conservation correction diff --git a/src/OCE/ISF/isfhdiv.F90 b/src/OCE/ISF/isfhdiv.F90 index 0666fd29d75941faae045d4aa5e933a22171e799..95037028f46c203fecd6944ed3b787652fd9c86e 100644 --- a/src/OCE/ISF/isfhdiv.F90 +++ b/src/OCE/ISF/isfhdiv.F90 @@ -38,7 +38,7 @@ CONTAINS !! increment) !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:,:), INTENT( inout ) :: phdiv ! horizontal divergence + REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: phdiv ! horizontal divergence !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: kt INTEGER, INTENT(in) :: Kmm ! ocean time level index @@ -82,15 +82,15 @@ CONTAINS !! !! ** Action : phdivn increased by the ice shelf outflow !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phdiv + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phdiv !!---------------------------------------------------------------------- INTEGER , DIMENSION(jpi,jpj), INTENT(in ) :: ktop , kbot - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pfrac, phtbl - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pfwf , pfwf_b + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pfrac, phtbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pfwf , pfwf_b !!---------------------------------------------------------------------- INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ikt, ikb - REAL(dp), DIMENSION(A2D(nn_hls)) :: zhdiv + REAL(wp), DIMENSION(A2D(nn_hls)) :: zhdiv !!---------------------------------------------------------------------- ! !== fwf distributed over several levels ==! @@ -127,10 +127,10 @@ CONTAINS !! ** Action : phdivn increased by the ice shelf outflow !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phdiv + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phdiv !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: Kmm ! ocean time level index - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pqvol + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pqvol !!---------------------------------------------------------------------- INTEGER :: ji, jj, jk !!---------------------------------------------------------------------- diff --git a/src/OCE/ISF/isfload.F90 b/src/OCE/ISF/isfload.F90 index 4dd4f3359c0460c7b2afa7eee6ba9aea81a1094b..6e35f0f29b10bed3364ac4be8856cfff0369b2ce 100644 --- a/src/OCE/ISF/isfload.F90 +++ b/src/OCE/ISF/isfload.F90 @@ -26,6 +26,7 @@ MODULE isfload ! !! * Substitutions # include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -42,7 +43,7 @@ CONTAINS !! !!-------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kmm ! ocean time level index - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pisfload ! ice shelf load + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pisfload ! ice shelf load !!---------------------------------------------------------------------- ! ! quality test: ice shelf in a stratify/uniform ocean should not drive any flow. @@ -71,13 +72,13 @@ CONTAINS !! !!-------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kmm ! ocean time level index - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pload ! ice shelf load + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pload ! ice shelf load ! INTEGER :: ji, jj, jk INTEGER :: ikt - REAL(dp), DIMENSION(jpi,jpj) :: zrhdtop_isf ! water density displaced by the ice shelf (at the interface) - REAL(dp), DIMENSION(jpi,jpj,jpts) :: zts_top ! water properties displaced by the ice shelf - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zrhd ! water density displaced by the ice shelf + REAL(wp), DIMENSION(jpi,jpj) :: zrhdtop_isf ! water density displaced by the ice shelf (at the interface) + REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts_top ! water properties displaced by the ice shelf + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrhd ! water density displaced by the ice shelf !!---------------------------------------------------------------------- ! ! !- assume water displaced by the ice shelf is at T=rn_isfload_T and S=rn_isfload_S (rude) @@ -87,7 +88,7 @@ CONTAINS #if defined key_qco && key_isf CALL eos( zts_top(:,:,:), gdept_0(:,:,jk), zrhd(:,:,jk) ) #else - CALL eos( zts_top(:,:,:), gdept(:,:,jk,Kmm), zrhd(:,:,jk) ) + CALL eos( zts_top(:,:,:), CASTSP(gdept(:,:,jk,Kmm)), zrhd(:,:,jk) ) #endif END DO ! diff --git a/src/OCE/ISF/isfpar.F90 b/src/OCE/ISF/isfpar.F90 index 8dbed867bd791201f5adee034be6edffb39652e2..32495a28db199f78ce0409f4e0e449c1d536ccee 100644 --- a/src/OCE/ISF/isfpar.F90 +++ b/src/OCE/ISF/isfpar.F90 @@ -61,14 +61,14 @@ CONTAINS !! !!--------------------------------------------------------------------- !!-------------------------- OUT -------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) , INTENT(inout) :: pqfwf - REAL(dp), DIMENSION(jpi,jpj,jpts), INTENT(inout) :: ptsc + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: pqfwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(inout) :: ptsc !!-------------------------- IN -------------------------------------- INTEGER, INTENT(in) :: kt ! ocean time step INTEGER, INTENT(in) :: Kmm ! ocean time level index !!--------------------------------------------------------------------- INTEGER :: ji, jj - REAL(dp), DIMENSION(jpi,jpj) :: zqoce, zqhc, zqlat, zqh + REAL(wp), DIMENSION(jpi,jpj) :: zqoce, zqhc, zqlat, zqh !!--------------------------------------------------------------------- ! ! compute heat content, latent heat and melt fluxes (2d) @@ -114,7 +114,7 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER :: ierr - REAL(dp), DIMENSION(jpi,jpj) :: ztblmax, ztblmin + REAL(wp), DIMENSION(jpi,jpj) :: ztblmax, ztblmin !!---------------------------------------------------------------------- ! ! allocation diff --git a/src/OCE/ISF/isfparmlt.F90 b/src/OCE/ISF/isfparmlt.F90 index 6f6b88930efbffb2319f75cedd9d41b833a72dd4..0e921f0d69cf9cb14625b1217220a923dfce9240 100644 --- a/src/OCE/ISF/isfparmlt.F90 +++ b/src/OCE/ISF/isfparmlt.F90 @@ -30,6 +30,7 @@ MODULE isfparmlt !! * Substitutions +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -54,7 +55,7 @@ CONTAINS !! 2 : Beckmann & Goose parameterization !! !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: pqfwf, pqoce, pqhc ! fresh water, ice-ocean heat and heat content fluxes + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqfwf, pqoce, pqhc ! fresh water, ice-ocean heat and heat content fluxes !!-------------------------- IN ------------------------------------- INTEGER, INTENT(in) :: kt ! ocean time step INTEGER, INTENT(in) :: Kmm ! ocean time level index @@ -94,14 +95,14 @@ CONTAINS !! data read into a forcing files. !! !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: pqhc, pqfwf, pqoce ! fresh water and ice-ocean heat fluxes + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqhc, pqfwf, pqoce ! fresh water and ice-ocean heat fluxes !!-------------------------- IN ------------------------------------- INTEGER, INTENT(in) :: kt INTEGER, INTENT(in) :: Kmm ! ocean time level index !!-------------------------------------------------------------------- INTEGER :: jk - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d - REAL(dp), DIMENSION(jpi,jpj) :: ztfrz + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz !!-------------------------------------------------------------------- ! ! 0. ------------Read specified fwf from isf to oce @@ -110,9 +111,9 @@ CONTAINS ! compute ptfrz ! 1. ------------Mean freezing point DO jk = 1,jpk - CALL eos_fzp(ts(:,:,jk,jp_sal,Kmm), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm)) + CALL eos_fzp(CASTSP(ts(:,:,jk,jp_sal,Kmm)), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm)) END DO - CALL isf_tbl(Kmm, ztfrz3d, ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) + CALL isf_tbl(Kmm, CASTDP(ztfrz3d), ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) ! pqfwf(:,:) = sf_isfpar_fwf(1)%fnow(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) ( > 0 from isf to oce) pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean/ice shelf flux assume to be equal to latent heat flux ( > 0 from isf to oce) @@ -138,22 +139,22 @@ CONTAINS !! interaction for climate models", Ocean Modelling 5(2003) 157-170. !!---------------------------------------------------------------------- !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: pqhc, pqfwf, pqoce ! fresh water and ice-ocean heat fluxes + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqhc, pqfwf, pqoce ! fresh water and ice-ocean heat fluxes !!-------------------------- IN ------------------------------------- INTEGER, INTENT(in) :: kt INTEGER, INTENT(in) :: Kmm ! ocean time level index !!-------------------------------------------------------------------- INTEGER :: jk - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d ! freezing point - REAL(dp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point - REAL(dp), DIMENSION(jpi,jpj) :: ztavg ! temperature avg + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d ! freezing point + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point + REAL(wp), DIMENSION(jpi,jpj) :: ztavg ! temperature avg !!---------------------------------------------------------------------- ! ! 0. ------------Mean freezing point DO jk = 1,jpk - CALL eos_fzp(ts(:,:,jk,jp_sal,Kmm), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm)) + CALL eos_fzp(CASTSP(ts(:,:,jk,jp_sal,Kmm)), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm)) END DO - CALL isf_tbl(Kmm, ztfrz3d, ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) + CALL isf_tbl(Kmm, CASTDP(ztfrz3d), ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) ! ! 1. ------------Mean temperature CALL isf_tbl(Kmm, ts(:,:,:,jp_tem,Kmm), ztavg, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) @@ -187,16 +188,16 @@ CONTAINS !! !!--------------------------------------------------------------------- !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes !!-------------------------- IN ------------------------------------- INTEGER , INTENT(in ) :: kt ! current time step INTEGER , INTENT(in ) :: Kmm ! ocean time level index !!-------------------------------------------------------------------- INTEGER :: jk ! loop index - REAL(dp) :: zfwf_fld, zfwf_oasis ! total fwf in the forcing fields (pattern) and from the cpl interface (amount) - REAL(dp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature - REAL(dp), DIMENSION(jpi,jpj) :: zfwf ! 2d fwf map after scaling - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d + REAL(wp) :: zfwf_fld, zfwf_oasis ! total fwf in the forcing fields (pattern) and from the cpl interface (amount) + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature + REAL(wp), DIMENSION(jpi,jpj) :: zfwf ! 2d fwf map after scaling + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d !!-------------------------------------------------------------------- ! ! 0. ------------Read specified runoff @@ -204,9 +205,9 @@ CONTAINS ! ! 1. ------------Mean freezing point (needed for heat content flux) DO jk = 1,jpk - CALL eos_fzp(ts(:,:,jk,jp_sal,Kmm), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm)) + CALL eos_fzp(CASTSP(ts(:,:,jk,jp_sal,Kmm)), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm)) END DO - CALL isf_tbl(Kmm, ztfrz3d, ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) + CALL isf_tbl(Kmm, CASTDP(ztfrz3d), ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) ! ! 2. ------------Scale isf melt pattern with total amount from oasis ! ice shelf 2d map of fwf from isf to oce diff --git a/src/OCE/ISF/isfrst.F90 b/src/OCE/ISF/isfrst.F90 index 3f442ff51fee6ad255274f3c6e3228db14185073..d90b3e0c1b5a0967e3fa2a8bd74eaa2ecf9b6751 100644 --- a/src/OCE/ISF/isfrst.F90 +++ b/src/OCE/ISF/isfrst.F90 @@ -34,12 +34,12 @@ CONTAINS !! isfrst_read : read iceshelf variables from restart !! !!-------------------------- OUT -------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) , INTENT( out) :: pfwf_b - REAL(dp), DIMENSION(jpi,jpj,jpts), INTENT( out) :: ptsc_b + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pfwf_b + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT( out) :: ptsc_b !!-------------------------- IN -------------------------------------- CHARACTER(LEN=3) , INTENT(in ) :: cdisf - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf - REAL(dp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc !!---------------------------------------------------------------------- CHARACTER(LEN=256) :: cfwf_b, chc_b, csc_b !!---------------------------------------------------------------------- @@ -71,8 +71,8 @@ CONTAINS !!-------------------------- IN -------------------------------------- INTEGER , INTENT(in ) :: kt CHARACTER(LEN=3) , INTENT(in ) :: cdisf - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf - REAL(dp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc !!--------------------------------------------------------------------- CHARACTER(LEN=256) :: cfwf_b, chc_b, csc_b !!--------------------------------------------------------------------- diff --git a/src/OCE/ISF/isfstp.F90 b/src/OCE/ISF/isfstp.F90 index 52d9d59b0db8409dd2a28749f9c2c0da160ab1c1..956a587d3301ecda4b09ccfff9f8d8c6ef581a8b 100644 --- a/src/OCE/ISF/isfstp.F90 +++ b/src/OCE/ISF/isfstp.F90 @@ -35,6 +35,7 @@ MODULE isfstp PUBLIC isf_stp, isf_init, isf_nam ! routine called in sbcmod and divhor !! * Substitutions +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -62,7 +63,7 @@ CONTAINS ! INTEGER :: jk ! loop index #if defined key_qco - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ze3t ! 3D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t ! 3D workspace #endif !!--------------------------------------------------------------------- ! @@ -86,7 +87,7 @@ CONTAINS DO jk = 1, jpk ze3t(:,:,jk) = e3t(:,:,jk,Kmm) END DO - CALL isf_tbl_lvl( ht(:,:), ze3t , misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) + CALL isf_tbl_lvl( CASTSP(ht(:,:)), ze3t , misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) #else CALL isf_tbl_lvl( ht(:,:), e3t(:,:,:,Kmm), misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) #endif @@ -115,7 +116,7 @@ CONTAINS DO jk = 1, jpk ze3t(:,:,jk) = e3t(:,:,jk,Kmm) END DO - CALL isf_tbl_lvl( ht(:,:), ze3t , misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) + CALL isf_tbl_lvl( CASTSP(ht(:,:)), ze3t , misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) #else CALL isf_tbl_lvl( ht(:,:), e3t(:,:,:,Kmm), misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) #endif diff --git a/src/OCE/ISF/isftbl.F90 b/src/OCE/ISF/isftbl.F90 index 5a277944c2b3cdd3df8224d709317791fa4a9834..394c57b051d3fd2ac85c17ca7b3786a84d748357 100644 --- a/src/OCE/ISF/isftbl.F90 +++ b/src/OCE/ISF/isftbl.F90 @@ -40,24 +40,24 @@ CONTAINS !! https://doi.org/10.1029/2007JC004368 , 2008 !! !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) , INTENT( out) :: pvarout ! 2d average of pvarin + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pvarout ! 2d average of pvarin !!-------------------------- IN ------------------------------------- INTEGER , INTENT(in ) :: Kmm ! ocean time level index CHARACTER(len=1) , INTENT(in ) :: cd_ptin ! point of variable in/out REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pvarin ! 3d variable to average over the tbl INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl ! tbl thickness + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl ! tbl thickness !!-------------------------- IN OPTIONAL ----------------------------- INTEGER, DIMENSION(jpi,jpj), OPTIONAL, INTENT(in ) :: kbot ! bottom level - REAL(dp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in ) :: pfrac ! fraction of bottom cell affected by tbl + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in ) :: pfrac ! fraction of bottom cell affected by tbl !!-------------------------------------------------------------------- INTEGER :: ji, jj ! loop index INTEGER , DIMENSION(jpi,jpj) :: ikbot ! bottom level of the tbl - REAL(dp), DIMENSION(jpi,jpj) :: zvarout ! 2d average of pvarin - REAL(dp), DIMENSION(jpi,jpj) :: zhtbl ! thickness of the tbl - REAL(dp), DIMENSION(jpi,jpj) :: zfrac ! thickness of the tbl + REAL(wp), DIMENSION(jpi,jpj) :: zvarout ! 2d average of pvarin + REAL(wp), DIMENSION(jpi,jpj) :: zhtbl ! thickness of the tbl + REAL(wp), DIMENSION(jpi,jpj) :: zfrac ! thickness of the tbl INTEGER :: jk ! loop index - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ze3t,ze3u,ze3v ! e3 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t,ze3u,ze3v ! e3 !!-------------------------------------------------------------------- ! SELECT CASE ( cd_ptin ) @@ -125,11 +125,11 @@ CONTAINS !! over a thickness phtbl. The bottom level is partially counted (pfrac). !! !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) , INTENT( out) :: pvarout ! tbl property averaged over phtbl between level ktop and kbot + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pvarout ! tbl property averaged over phtbl between level ktop and kbot !!-------------------------- IN ------------------------------------- INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop, kbot ! top and bottom level of the top boundary layer - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl, pfrac ! fraction of bottom level to be affected by the tbl - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl, pfrac ! fraction of bottom level to be affected by the tbl + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pvarin ! tbl property to average between ktop, kbot over phtbl !!-------------------------------------------------------------------- INTEGER :: ji,jj,jk ! loop indices @@ -162,13 +162,13 @@ CONTAINS !! !!-------------------------- OUT -------------------------------------- INTEGER, DIMENSION(jpi,jpj) , INTENT( out) :: kbot ! bottom level of the top boundary layer - REAL(dp), DIMENSION(jpi,jpj) , INTENT( out) :: pfrac ! fraction of bottom level in the tbl + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pfrac ! fraction of bottom level in the tbl !!-------------------------- IN -------------------------------------- INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level of the top boundary layer - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: phw ! water column thickness - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phw ! water column thickness + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor !!-------------------------- INOUT ------------------------------------ - REAL(dp), DIMENSION(jpi,jpj) , INTENT(inout) :: phtbl ! top boundary layer thickness + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: phtbl ! top boundary layer thickness !!--------------------------------------------------------------------- INTEGER :: ji,jj,jk INTEGER :: ikt, ikb @@ -213,9 +213,9 @@ CONTAINS !!-------------------------- OUT ------------------------------------- INTEGER, DIMENSION(jpi,jpj) , INTENT( out) :: kbot ! bottom level of the top boundary layer !!-------------------------- IN ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl ! top boundary layer thickness + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl ! top boundary layer thickness INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level of the top boundary layer - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor !!-------------------------------------------------------------------- INTEGER :: ji, jj INTEGER :: ikt, ikb @@ -247,7 +247,7 @@ CONTAINS !!-------------------------- OUT ------------------------------------- INTEGER, DIMENSION(jpi,jpj), INTENT( out) :: ktop ! top level affected by the ice shelf parametrisation !!-------------------------- IN ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: pdep ! top depth of the parametrisation influence + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pdep ! top depth of the parametrisation influence !!-------------------------------------------------------------------- INTEGER :: ji,jj INTEGER :: ikt diff --git a/src/OCE/ISF/isfutils.F90 b/src/OCE/ISF/isfutils.F90 index 3d120bb2e2da1c3f9768b334b4a42e8b6240acc6..5d2dfccabfc7c319ffd1b5de625941c7e39a6137 100644 --- a/src/OCE/ISF/isfutils.F90 +++ b/src/OCE/ISF/isfutils.F90 @@ -28,6 +28,7 @@ MODULE isfutils PUBLIC read_2dcstdta, debug +# include "single_precision_substitute.h90" CONTAINS SUBROUTINE read_2dcstdta(cdfile, cdvar, pvar) @@ -37,7 +38,7 @@ CONTAINS !! ** Purpose : read input file !! !!-------------------------- OUT ------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pvar ! output variable + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pvar ! output variable !!-------------------------- IN ------------------------------------- CHARACTER(len=*) , INTENT(in ) :: cdfile ! input file name CHARACTER(len=*) , INTENT(in ) :: cdvar ! variable name @@ -59,9 +60,9 @@ CONTAINS !! !!-------------------------- IN ------------------------------------- CHARACTER(LEN=*) , INTENT(in ) :: cdtxt - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pvar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pvar !!-------------------------------------------------------------------- - REAL(dp) :: zmin, zmax, zsum + REAL(wp) :: zmin, zmax, zsum INTEGER(i8) :: imodd, ip INTEGER :: imods INTEGER :: isums, idums @@ -70,9 +71,9 @@ CONTAINS !!-------------------------------------------------------------------- ! ! global min/max/sum to check data range and NaN - zsum = glob_sum( 'debug', pvar(:,:) ) - zmin = glob_min( 'debug', pvar(:,:) ) - zmax = glob_max( 'debug', pvar(:,:) ) + zsum =glob_sum( 'debug', CASTDP(pvar(:,:)) ) + zmin = glob_min( 'debug',REAL(pvar(:,:),dp) ) + zmax = glob_max( 'debug', REAL(pvar(:,:),dp) ) ! ! basic check sum to check reproducibility ! TRANSFER function find out the integer corresponding to pvar(i,j) bit pattern @@ -114,7 +115,7 @@ CONTAINS CHARACTER(LEN=*) , INTENT(in ) :: cdtxt REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pvar !!-------------------------------------------------------------------- - REAL(dp) :: zmin, zmax, zsum + REAL(wp) :: zmin, zmax, zsum INTEGER(i8) :: imodd, ip INTEGER :: imods INTEGER :: isums, idums diff --git a/src/OCE/LBC/halo_mng.F90 b/src/OCE/LBC/halo_mng.F90 index 1b3e1b754083f74146dda9343ddf0d446445c05d..f03b666002f0ad97e606160140565ebd389efc7f 100644 --- a/src/OCE/LBC/halo_mng.F90 +++ b/src/OCE/LBC/halo_mng.F90 @@ -70,11 +70,11 @@ CONTAINS SUBROUTINE halo_mng_resize_2D(pta, cdna, psgn, fillval) - REAL(dp), POINTER, DIMENSION(:,:) :: pta + REAL(wp), POINTER, DIMENSION(:,:) :: pta CHARACTER(len=1), INTENT(in) :: cdna REAL(wp), INTENT(in) :: psgn REAL(wp), OPTIONAL, INTENT(in ) :: fillval - REAL(dp), POINTER, DIMENSION(:,:) :: zpta + REAL(wp), POINTER, DIMENSION(:,:) :: zpta INTEGER :: offset INTEGER :: pta_size_i, pta_size_j @@ -91,7 +91,7 @@ CONTAINS ELSE zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj) END IF - CALL lbc_lnk( 'halo_mng_resize_2D', zpta, cdna, REAL(psgn,dp), pfillval=REAL(fillval,dp)) + CALL lbc_lnk( 'halo_mng_resize_2D', zpta, cdna, psgn, pfillval=fillval) DEALLOCATE(pta) pta => zpta END IF @@ -100,11 +100,11 @@ CONTAINS SUBROUTINE halo_mng_resize_3D(pta, cdna, psgn, fillval) - REAL(dp), POINTER, DIMENSION(:,:,:) :: pta + REAL(wp), POINTER, DIMENSION(:,:,:) :: pta CHARACTER(len=1), INTENT(in) :: cdna REAL(wp), INTENT(in) :: psgn REAL(wp), OPTIONAL, INTENT(in ) :: fillval - REAL(dp), POINTER, DIMENSION(:,:,:) :: zpta + REAL(wp), POINTER, DIMENSION(:,:,:) :: zpta INTEGER :: offset INTEGER :: pta_size_i, pta_size_j @@ -121,7 +121,7 @@ CONTAINS ELSE zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :) END IF - CALL lbc_lnk( 'halo_mng_resize_3D', zpta, cdna, REAL(psgn,dp), pfillval=REAL(fillval,dp)) + CALL lbc_lnk( 'halo_mng_resize_3D', zpta, cdna, psgn, pfillval=fillval) DEALLOCATE(pta) pta => zpta END IF @@ -130,12 +130,12 @@ CONTAINS SUBROUTINE halo_mng_resize_4D(pta, cdna, psgn, fillval, fjpt) - REAL(dp), POINTER, DIMENSION(:,:,:,:) :: pta + REAL(wp), POINTER, DIMENSION(:,:,:,:) :: pta CHARACTER(len=1), INTENT(in) :: cdna REAL(wp), INTENT(in) :: psgn REAL(wp), OPTIONAL, INTENT(in) :: fillval INTEGER , INTENT(in) :: fjpt - REAL(dp), POINTER, DIMENSION(:,:,:,:) :: zpta + REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zpta INTEGER :: offset INTEGER :: pta_size_i, pta_size_j @@ -152,7 +152,7 @@ CONTAINS ELSE zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :, :) END IF - CALL lbc_lnk( 'halo_mng_resize_4D', zpta(:,:,:,fjpt), cdna, REAL(psgn,dp), pfillval=REAL(fillval,dp)) + CALL lbc_lnk( 'halo_mng_resize_4D', zpta(:,:,:,fjpt), cdna, psgn, pfillval=fillval) DEALLOCATE(pta) pta => zpta END IF @@ -161,13 +161,13 @@ CONTAINS SUBROUTINE halo_mng_resize_5D(pta, cdna, psgn, fillval, kjpt, fjpt) - REAL(dp), POINTER, DIMENSION(:,:,:,:,:) :: pta + REAL(wp), POINTER, DIMENSION(:,:,:,:,:) :: pta CHARACTER(len=1), INTENT(in) :: cdna REAL(wp), INTENT(in) :: psgn REAL(wp), OPTIONAL, INTENT(in) :: fillval INTEGER , OPTIONAL, INTENT(in) :: kjpt ! number of tracers INTEGER , INTENT(in) :: fjpt - REAL(dp), POINTER, DIMENSION(:,:,:,:,:) :: zpta + REAL(wp), POINTER, DIMENSION(:,:,:,:,:) :: zpta INTEGER :: offset INTEGER :: pta_size_i, pta_size_j @@ -184,11 +184,11 @@ CONTAINS ELSE zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :, :, :) END IF - CALL lbc_lnk( 'halo_mng_resize_5D', zpta(:,:,:,:,fjpt), cdna, REAL(psgn,dp), pfillval=REAL(fillval,dp)) + CALL lbc_lnk( 'halo_mng_resize_5D', zpta(:,:,:,:,fjpt), cdna, psgn, pfillval=fillval) DEALLOCATE(pta) pta => zpta END IF END SUBROUTINE halo_mng_resize_5D -END MODULE +END MODULE \ No newline at end of file diff --git a/src/OCE/LBC/lib_mpp.F90 b/src/OCE/LBC/lib_mpp.F90 index 6fc990b0e94967e2af376313e51110e7bad381cc..4bf56f6b652e6c617c23d14c8aa6f5174a99d5ef 100644 --- a/src/OCE/LBC/lib_mpp.F90 +++ b/src/OCE/LBC/lib_mpp.F90 @@ -547,7 +547,7 @@ CONTAINS ndelayid(idvar) = -1 ! do as if we had no restart ELSE ALLOCATE(todelay(idvar)%y1d(isz)) - todelay(idvar)%y1d(:) = CMPLX(todelay(idvar)%z1d(:), 0.,dp) ! create %y1d, complex variable needed by mpi_sumdd + todelay(idvar)%y1d(:) = CMPLX(todelay(idvar)%z1d(:), 0., wp) ! create %y1d, complex variable needed by mpi_sumdd ndelayid(idvar) = MPI_REQUEST_NULL ! initialised request to a valid value END IF ENDIF @@ -574,7 +574,7 @@ CONTAINS CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) # endif #else - pout(:) = REAL(y_in(:),dp) + pout(:) = REAL(y_in(:), wp) #endif END SUBROUTINE mpp_delay_sum @@ -606,7 +606,7 @@ CONTAINS else if ( wp == sp ) then MPI_TYPE = MPI_REAL else - CALL ctl_stop( "Error defining type,dp is neither dp nor sp" ) + CALL ctl_stop( "Error defining type, wp is neither dp nor sp" ) end if @@ -677,7 +677,7 @@ CONTAINS ! test on ndelayid(kid) useless as mpi_wait return immediatly if the request handle is MPI_REQUEST_NULL CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! after this ndelayid(kid) = MPI_REQUEST_NULL IF( ln_timing ) CALL tic_tac( .FALSE., ld_global = .TRUE.) - IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:),dp) ! define %z1d from %y1d + IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d #endif END SUBROUTINE mpp_delay_rcv @@ -1560,7 +1560,7 @@ CONTAINS IF( PRESENT( karea ) ) THEN IF( karea > 1 ) THEN ! Warning: jpnij is maybe not already defined when calling ctl_opn -> use mppsize instead of jpnij - idg = MAX( INT(LOG10(REAL(MAX(1,mppsize-1),dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(MAX(1,mppsize-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 WRITE(clfmt, "('(a,a,i', i1, '.', i1, ')')") idg, idg ! '(a,a,ix.x)' WRITE(clfile, clfmt) TRIM(clfile), '_', karea-1 ENDIF diff --git a/src/OCE/LBC/mpp_loc_generic.h90 b/src/OCE/LBC/mpp_loc_generic.h90 index 232cddf5e053d33bdea8b6566989e6b3f148eb02..21783b85eea64eaa65a897d7311082636e390d82 100644 --- a/src/OCE/LBC/mpp_loc_generic.h90 +++ b/src/OCE/LBC/mpp_loc_generic.h90 @@ -1,6 +1,6 @@ !== IN: ptab is an array ==! # if defined SINGLE_PRECISION -# define ARRAY_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) #if ! defined key_mpi_off # define MPI_TYPE MPI_2REAL #endif @@ -136,4 +136,4 @@ #undef MPI_OPERATION #undef LOC_OPERATION #undef INDEX_TYPE -#undef ERRVAL \ No newline at end of file +#undef ERRVAL diff --git a/src/OCE/LBC/mppini.F90 b/src/OCE/LBC/mppini.F90 index b42f5414bff288681a94bf3addc64e650949a221..4e619abfe5ee52b32cb36ccbea9df34f5b1e5633 100644 --- a/src/OCE/LBC/mppini.F90 +++ b/src/OCE/LBC/mppini.F90 @@ -692,14 +692,14 @@ CONTAINS LOGICAL :: llist LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llmsk2d ! max size of the subdomains along i,j LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisOce ! - - - REAL(dp):: zpropland + REAL(wp):: zpropland !!---------------------------------------------------------------------- ! llist = .FALSE. IF( PRESENT(ldlist) ) llist = ldlist CALL mpp_init_landprop( zpropland ) ! get the proportion of land point over the gloal domain - inbij = NINT( REAL(knbij,dp) / ( 1.0 - zpropland ) ) ! define the largest possible value for jpni*jpnj + inbij = NINT( REAL(knbij, wp) / ( 1.0 - zpropland ) ) ! define the largest possible value for jpni*jpnj ! IF( llist ) THEN ; inbijmax = inbij*2 ELSE ; inbijmax = inbij @@ -845,7 +845,7 @@ CONTAINS IF(lwp .AND. inbij < inbijold) THEN WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & & 'nb_cores oce: ', inbij, ', land domains excluded: ', inbi0(ji)*inbj0(ji) - inbij, & - & ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,dp) / REAL(inbi0(ji)*inbj0(ji),dp) *100., & + & ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,wp) / REAL(inbi0(ji)*inbj0(ji),wp) *100., & & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' inbijold = inbij ENDIF @@ -885,7 +885,7 @@ CONTAINS !! !! ** Method : read iproc strips (of length Ni0glo) of the land-sea mask !!---------------------------------------------------------------------- - REAL(dp), INTENT( out) :: propland ! proportion of land points in the global domain (between 0 and 1) + REAL(wp), INTENT( out) :: propland ! proportion of land points in the global domain (between 0 and 1) ! INTEGER, DIMENSION(jpni*jpnj) :: kusedom_1d INTEGER :: inboce, iarea @@ -924,7 +924,7 @@ CONTAINS ENDIF CALL mpp_sum( 'mppini', inboce ) ! total number of ocean points over the global domain ! - propland = REAL( Ni0glo*Nj0glo - inboce,dp ) / REAL( Ni0glo*Nj0glo,dp ) + propland = REAL( Ni0glo*Nj0glo - inboce, wp ) / REAL( Ni0glo*Nj0glo, wp ) ! END SUBROUTINE mpp_init_landprop @@ -1065,7 +1065,7 @@ CONTAINS LOGICAL, DIMENSION(kicnt,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean ! INTEGER :: inumsave ! local logical unit - REAL(dp), DIMENSION(kicnt,kjcnt) :: zbot, zbdy + REAL(wp), DIMENSION(kicnt,kjcnt) :: zbot, zbdy !!---------------------------------------------------------------------- ! inumsave = numout ; numout = numnul ! redirect all print to /dev/null @@ -1156,7 +1156,7 @@ CONTAINS INTEGER :: ipi, ipj INTEGER :: iiwe, iiea, iist, iisz INTEGER :: ijso, ijno, ijst, ijsz - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zmsk + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zmsk LOGICAL , DIMENSION(Ni_0,Nj_0,1) :: lloce !!---------------------------------------------------------------------- ! @@ -1176,13 +1176,13 @@ CONTAINS ipj = Nj_0 + 2*jh ! ALLOCATE( zmsk(ipi,ipj) ) - zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = REAL(COUNT(lloce, dim = 3),dp) ! define inner domain -> need REAL to use lbclnk - CALL lbc_lnk('mppini', zmsk, 'T', 1._dp, khls = jh) ! fill halos + zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = REAL(COUNT(lloce, dim = 3), wp) ! define inner domain -> need REAL to use lbclnk + CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh) ! fill halos ! Beware, coastal F points can be used in the code -> we may need communications for these points F points even if tmask = 0 ! -> the mask we must use here is equal to 1 as soon as one of the 4 neighbours is oce (sum of the mask, not multiplication) zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = zmsk(jh+1:jh+Ni_0,jh+1 :jh+Nj_0 ) + zmsk(jh+1+1:jh+Ni_0+1,jh+1 :jh+Nj_0 ) & & + zmsk(jh+1:jh+Ni_0,jh+1+1:jh+Nj_0+1) + zmsk(jh+1+1:jh+Ni_0+1,jh+1+1:jh+Nj_0+1) - CALL lbc_lnk('mppini', zmsk, 'T', 1._dp, khls = jh) ! fill halos again! + CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh) ! fill halos again! ! iiwe = jh ; iiea = Ni_0 ! bottom-left corner - 1 of the sent data ijso = jh ; ijno = Nj_0 @@ -1289,7 +1289,7 @@ ENDIF LOGICAL, INTENT(in ) :: ldwrtlay ! true if additional prints in layout.dat INTEGER, INTENT(in ) :: knum ! layout.dat unit ! - REAL(dp), DIMENSION(jpi,jpj,2,4) :: zinfo + REAL(wp), DIMENSION(jpi,jpj,2,4) :: zinfo INTEGER , DIMENSION(10) :: irknei ! too many elements but safe... INTEGER :: ji, jj, jg, jn ! dummy loop indices INTEGER :: iitmp @@ -1323,17 +1323,17 @@ ENDIF DO jg = 1, 4 ! grid type: T, U, V, F DO jj = nn_hls+1, jpj-nn_hls ! inner domain (warning do_loop_substitute not yet defined) DO ji = nn_hls+1, jpi-nn_hls ! inner domain (warning do_loop_substitute not yet defined) - zinfo(ji,jj,1,jg) = REAL(narea,dp) ! mpi_rank + 1 (as default lbc_lnk fill is 0 - zinfo(ji,jj,2,jg) = REAL(ji,dp) ! ji of this proc + zinfo(ji,jj,1,jg) = REAL(narea, wp) ! mpi_rank + 1 (as default lbc_lnk fill is 0 + zinfo(ji,jj,2,jg) = REAL(ji, wp) ! ji of this proc END DO END DO END DO ! ln_nnogather = .FALSE. ! force "classical" North pole folding to fill all halos -> should be no more HUGE values... - CALL lbc_lnk( 'mppini', zinfo(:,:,:,1), 'T', 1._dp ) ! Do 4 calls instead of 1 to save memory as the nogather version - CALL lbc_lnk( 'mppini', zinfo(:,:,:,2), 'U', 1._dp ) ! creates buffer arrays with jpiglo as the first dimension - CALL lbc_lnk( 'mppini', zinfo(:,:,:,3), 'V', 1._dp ) ! - CALL lbc_lnk( 'mppini', zinfo(:,:,:,4), 'F', 1._dp ) ! + CALL lbc_lnk( 'mppini', zinfo(:,:,:,1), 'T', 1._wp ) ! Do 4 calls instead of 1 to save memory as the nogather version + CALL lbc_lnk( 'mppini', zinfo(:,:,:,2), 'U', 1._wp ) ! creates buffer arrays with jpiglo as the first dimension + CALL lbc_lnk( 'mppini', zinfo(:,:,:,3), 'V', 1._wp ) ! + CALL lbc_lnk( 'mppini', zinfo(:,:,:,4), 'F', 1._wp ) ! ln_nnogather = .TRUE. IF( l_IdoNFold ) THEN ! only the procs involed in the NFD must take care of this @@ -1450,4 +1450,4 @@ ENDIF END SUBROUTINE init_locglo !!====================================================================== -END MODULE mppini +END MODULE mppini \ No newline at end of file diff --git a/src/OCE/LDF/ldfc1d_c2d.F90 b/src/OCE/LDF/ldfc1d_c2d.F90 index b5c6f27291745f31a82cca8a67406edd6a31343d..4b1b439836cf2bf618a2a1b05f35757ccec4731c 100644 --- a/src/OCE/LDF/ldfc1d_c2d.F90 +++ b/src/OCE/LDF/ldfc1d_c2d.F90 @@ -25,9 +25,9 @@ MODULE ldfc1d_c2d PUBLIC ldf_c1d ! called by ldftra and ldfdyn modules PUBLIC ldf_c2d ! called by ldftra and ldfdyn modules - REAL(dp) :: r1_2 = 0.5_wp ! =1/2 - REAL(dp) :: r1_4 = 0.25_wp ! =1/4 - REAL(dp) :: r1_12 = 1._wp / 12._wp ! =1/12 + 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" @@ -53,13 +53,13 @@ CONTAINS !! DYN pah1, pah2 defined at T- and F-points !!---------------------------------------------------------------------- CHARACTER(len=3) , INTENT(in ) :: cd_type ! DYNamique or TRAcers - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: pahs1, pahs2 ! surface value of eddy coefficient [m2/s] - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pah1 , pah2 ! eddy coefficient [m2/s] + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pahs1, pahs2 ! surface value of eddy coefficient [m2/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pah1 , pah2 ! eddy coefficient [m2/s] ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zh, zc, zdep1 ! local scalars - REAL(dp) :: zw , zdep2 ! - - - REAL(dp) :: zratio ! - - + REAL(wp) :: zh, zc, zdep1 ! local scalars + REAL(wp) :: zw , zdep2 ! - - + REAL(wp) :: zratio ! - - !!---------------------------------------------------------------------- ! IF(lwp) WRITE(numout,*) @@ -84,7 +84,7 @@ CONTAINS & + gdept_0(ji,jj ,jk) + gdept_0(ji+1,jj ,jk) ) * r1_4 pah2(ji,jj,jk) = pahs2(ji,jj) * ( zratio + zc * ( 1._wp + TANH( - ( zdep2 - zh ) * zw) ) ) END_3D - CALL lbc_lnk( 'ldfc1d_c2d', pah2, 'F', 1.0_dp ) ! Lateral boundary conditions + CALL lbc_lnk( 'ldfc1d_c2d', pah2, 'F', 1.0_wp ) ! Lateral boundary conditions ! CASE( 'TRA' ) ! U- and V-points (zdep1 & 2 are an approximation in zps-coord.) DO_3DS( 0, 0, 0, 0, jpkm1, 1, -1 ) @@ -94,7 +94,7 @@ CONTAINS pah2(ji,jj,jk) = pahs2(ji,jj) * ( zratio + zc * ( 1._wp + TANH( - ( zdep2 - zh ) * zw) ) ) END_3D ! Lateral boundary conditions - CALL lbc_lnk( 'ldfc1d_c2d', pah1, 'U', 1.0_dp , pah2, 'V', 1.0_dp ) + CALL lbc_lnk( 'ldfc1d_c2d', pah1, 'U', 1.0_wp , pah2, 'V', 1.0_wp ) ! CASE DEFAULT ! error CALL ctl_stop( 'ldf_c1d: ', cd_type, ' Unknown, i.e. /= DYN or TRA' ) @@ -119,9 +119,9 @@ CONTAINS !! DYN pah1, pah2 defined at T- and F-points !!---------------------------------------------------------------------- CHARACTER(len=3) , INTENT(in ) :: cd_type ! DYNamique or TRAcers - REAL(dp) , INTENT(in ) :: pUfac ! =1/2*Uc LAPlacian BiLaPlacian + REAL(wp) , INTENT(in ) :: pUfac ! =1/2*Uc LAPlacian BiLaPlacian INTEGER , INTENT(in ) :: knn ! characteristic velocity [m/s] - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pah1, pah2 ! eddy coefficients [m2/s or m4/s] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pah1, pah2 ! eddy coefficients [m2/s or m4/s] ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: inn ! local integer @@ -155,4 +155,4 @@ CONTAINS END SUBROUTINE ldf_c2d !!====================================================================== -END MODULE ldfc1d_c2d +END MODULE ldfc1d_c2d \ No newline at end of file diff --git a/src/OCE/LDF/ldfdyn.F90 b/src/OCE/LDF/ldfdyn.F90 index a2fee92dc1cb2a0753cb2dc198518c7ec65a4de5..b21c7314a29dee040093baf90b9510c3f3683fca 100644 --- a/src/OCE/LDF/ldfdyn.F90 +++ b/src/OCE/LDF/ldfdyn.F90 @@ -42,14 +42,14 @@ MODULE ldfdyn INTEGER , PUBLIC :: nn_ahm_ijk_t !: choice of time & space variations of the lateral eddy viscosity coef. ! ! time invariant coefficients: aht = 1/2 Ud*Ld (lap case) ! ! bht = 1/12 Ud*Ld^3 (blp case) - REAL(dp), PUBLIC :: rn_Uv !: lateral viscous velocity [m/s] - REAL(dp), PUBLIC :: rn_Lv !: lateral viscous length [m] + REAL(wp), PUBLIC :: rn_Uv !: lateral viscous velocity [m/s] + REAL(wp), PUBLIC :: rn_Lv !: lateral viscous length [m] ! ! Smagorinsky viscosity (nn_ahm_ijk_t = 32) - REAL(dp), PUBLIC :: rn_csmc !: Smagorinsky constant of proportionality - REAL(dp), PUBLIC :: rn_minfac !: Multiplicative factor of theorectical minimum Smagorinsky viscosity - REAL(dp), PUBLIC :: rn_maxfac !: Multiplicative factor of theorectical maximum Smagorinsky viscosity + REAL(wp), PUBLIC :: rn_csmc !: Smagorinsky constant of proportionality + REAL(wp), PUBLIC :: rn_minfac !: Multiplicative factor of theorectical minimum Smagorinsky viscosity + REAL(wp), PUBLIC :: rn_maxfac !: Multiplicative factor of theorectical maximum Smagorinsky viscosity ! ! iso-neutral laplacian (ln_dynldf_lap=ln_dynldf_iso=T) - REAL(dp), PUBLIC :: rn_ahm_b !: lateral laplacian background eddy viscosity [m2/s] + REAL(wp), PUBLIC :: rn_ahm_b !: lateral laplacian background eddy viscosity [m2/s] ! !!* Parameter to control the type of lateral viscous operator INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 !: error in setting the operator @@ -65,16 +65,16 @@ MODULE ldfdyn INTEGER , PUBLIC :: nldf_dyn !: type of lateral diffusion used defined from ln_dynldf_... (namlist logicals) LOGICAL , PUBLIC :: l_ldfdyn_time !: flag for time variation of the lateral eddy viscosity coef. - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahmt, ahmf !: eddy viscosity coef. at T- and F-points [m2/s or m4/s] - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dtensq !: horizontal tension squared (Smagorinsky only) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dshesq !: horizontal shearing strain squared (Smagorinsky only) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: esqt, esqf !: Square of the local gridscale (e1e2/(e1+e2))**2 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahmt, ahmf !: eddy viscosity coef. at T- and F-points [m2/s or m4/s] + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dtensq !: horizontal tension squared (Smagorinsky only) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dshesq !: horizontal shearing strain squared (Smagorinsky only) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: esqt, esqf !: Square of the local gridscale (e1e2/(e1+e2))**2 - REAL(dp) :: r1_2 = 0.5_wp ! =1/2 - REAL(dp) :: r1_4 = 0.25_wp ! =1/4 - REAL(dp) :: r1_8 = 0.125_wp ! =1/8 - REAL(dp) :: r1_12 = 1._wp / 12._wp ! =1/12 - REAL(dp) :: r1_288 = 1._wp / 288._wp ! =1/( 12^2 * 2 ) + REAL(wp) :: r1_2 = 0.5_wp ! =1/2 + REAL(wp) :: r1_4 = 0.25_wp ! =1/4 + REAL(wp) :: r1_8 = 0.125_wp ! =1/8 + REAL(wp) :: r1_12 = 1._wp / 12._wp ! =1/12 + REAL(wp) :: r1_288 = 1._wp / 288._wp ! =1/( 12^2 * 2 ) !! * Substitutions # include "do_loop_substitute.h90" @@ -110,7 +110,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ioptio, ierr, inum, ios, inn ! local integer - REAL(dp) :: zah0, zah_max, zUfac ! local scalar + REAL(wp) :: zah0, zah_max, zUfac ! local scalar CHARACTER(len=5) :: cl_Units ! units (m2/s or m4/s) !! NAMELIST/namdyn_ldf/ ln_dynldf_OFF, nn_dynldf_typ, ln_dynldf_lap, ln_dynldf_blp, & ! type of operator @@ -369,8 +369,8 @@ CONTAINS INTEGER, INTENT(in) :: Kbb ! ocean time level indices ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zu2pv2_ij_p1, zu2pv2_ij, zu2pv2_ij_m1, zemax ! local scalar (option 31) - REAL(dp) :: zcmsmag, zstabf_lo, zstabf_up, zdelta, zdb ! local scalar (option 32) + REAL(wp) :: zu2pv2_ij_p1, zu2pv2_ij, zu2pv2_ij_m1, zemax ! local scalar (option 31) + REAL(wp) :: zcmsmag, zstabf_lo, zstabf_up, zdelta, zdb ! local scalar (option 32) !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('ldf_dyn') @@ -405,7 +405,7 @@ CONTAINS END DO ENDIF ! - CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_dp, ahmf, 'F', 1.0_dp ) + CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_wp, ahmf, 'F', 1.0_wp ) ! ! CASE( 32 ) !== time varying 3D field ==! = F( local deformation rate and gridscale ) (Smagorinsky) @@ -437,7 +437,7 @@ CONTAINS ! END DO ! - CALL lbc_lnk( 'ldfdyn', dtensq, 'T', 1.0_dp ) ! lbc_lnk on dshesq not needed + CALL lbc_lnk( 'ldfdyn', dtensq, 'T', 1.0_wp ) ! lbc_lnk on dshesq not needed ! DO jk = 1, jpkm1 ! @@ -486,7 +486,7 @@ CONTAINS ! ENDIF ! - CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_dp , ahmf, 'F', 1.0_dp ) + CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_wp , ahmf, 'F', 1.0_wp ) ! END SELECT ! diff --git a/src/OCE/LDF/ldfslp.F90 b/src/OCE/LDF/ldfslp.F90 index 0b885b5ca68d7d96614d4b1ca958146c884452c6..7606e6fdfd2b80a2b63db227c2e951ca2da271c5 100644 --- a/src/OCE/LDF/ldfslp.F90 +++ b/src/OCE/LDF/ldfslp.F90 @@ -49,28 +49,28 @@ MODULE ldfslp LOGICAL , PUBLIC :: ln_triad_iso = .FALSE. !: pure horizontal mixing in ML (nam_traldf namelist) LOGICAL , PUBLIC :: ln_botmix_triad = .FALSE. !: mixing on bottom (nam_traldf namelist) - REAL(dp), PUBLIC :: rn_sw_triad = 1._wp !: =1 switching triads ; =0 all four triads used (nam_traldf namelist) - REAL(dp), PUBLIC :: rn_slpmax = 0.01_wp !: slope limit (nam_traldf namelist) + REAL(wp), PUBLIC :: rn_sw_triad = 1._wp !: =1 switching triads ; =0 all four triads used (nam_traldf namelist) + REAL(wp), PUBLIC :: rn_slpmax = 0.01_wp !: slope limit (nam_traldf namelist) LOGICAL , PUBLIC :: l_grad_zps = .FALSE. !: special treatment for Horz Tgradients w partial steps (triad operator) ! !! Classic operator (Madec) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uslp, wslpi !: i_slope at U- and W-points - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vslp, wslpj !: j-slope at V- and W-points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uslp, wslpi !: i_slope at U- and W-points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vslp, wslpj !: j-slope at V- and W-points ! !! triad operator (Griffies) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wslp2 !: wslp**2 from Griffies quarter cells - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: triadi_g, triadj_g !: skew flux slopes relative to geopotentials - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: triadi , triadj !: isoneutral slopes relative to model-coordinate + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wslp2 !: wslp**2 from Griffies quarter cells + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: triadi_g, triadj_g !: skew flux slopes relative to geopotentials + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: triadi , triadj !: isoneutral slopes relative to model-coordinate ! !! both operators - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ah_wslp2 !: ah * slope^2 at w-point - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akz !: stabilizing vertical diffusivity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ah_wslp2 !: ah * slope^2 at w-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akz !: stabilizing vertical diffusivity ! !! Madec operator - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: omlmask ! mask of the surface mixed layer at T-pt - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: uslpml, wslpiml ! i_slope at U- and W-points just below the mixed layer - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: vslpml, wslpjml ! j_slope at V- and W-points just below the mixed layer + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: omlmask ! mask of the surface mixed layer at T-pt + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: uslpml, wslpiml ! i_slope at U- and W-points just below the mixed layer + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: vslpml, wslpjml ! j_slope at V- and W-points just below the mixed layer - REAL(dp) :: repsln = 1.e-25_wp ! tiny value used as minium of di(rho), dj(rho) and dk(rho) + REAL(wp) :: repsln = 1.e-25_wp ! tiny value used as minium of di(rho), dj(rho) and dk(rho) !! * Substitutions # include "do_loop_substitute.h90" @@ -109,20 +109,20 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: kt ! ocean time-step index INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices - REAL(dp), INTENT(in), DIMENSION(:,:,:) :: prd ! in situ density - REAL(dp), INTENT(in), DIMENSION(:,:,:) :: pn2 ! Brunt-Vaisala frequency (locally ref.) + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: prd ! in situ density + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: pn2 ! Brunt-Vaisala frequency (locally ref.) !! INTEGER :: ji , jj , jk ! dummy loop indices INTEGER :: ii0, ii1 ! temporary integer INTEGER :: ij0, ij1 ! temporary integer - REAL(dp) :: zeps, zm1_g, zm1_2g, z1_16, zcofw, z1_slpmax ! local scalars - REAL(dp) :: zci, zfi, zau, zbu, zai, zbi ! - - - REAL(dp) :: zcj, zfj, zav, zbv, zaj, zbj ! - - - REAL(dp) :: zck, zfk, zbw ! - - - REAL(dp) :: zdepu, zdepv ! - - - REAL(dp), DIMENSION(jpi,jpj) :: zslpml_hmlpu, zslpml_hmlpv - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zgru, zwz, zdzr - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zgrv, zww + REAL(wp) :: zeps, zm1_g, zm1_2g, z1_16, zcofw, z1_slpmax ! local scalars + REAL(wp) :: zci, zfi, zau, zbu, zai, zbi ! - - + REAL(wp) :: zcj, zfj, zav, zbv, zaj, zbj ! - - + REAL(wp) :: zck, zfk, zbw ! - - + REAL(wp) :: zdepu, zdepv ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zslpml_hmlpu, zslpml_hmlpv + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgru, zwz, zdzr + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrv, zww !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('ldf_slp') @@ -220,15 +220,15 @@ CONTAINS & + zfj * zdepv * zslpml_hmlpv(ji,jj) ) * vmask(ji,jj,jk) !!gm modif to suppress omlmask.... (as in Griffies case) ! ! ! jk must be >= ML level for zf=1. otherwise zf=0. -! zfi = REAL( 1 - 1/(1 + jk / MAX( nmln(ji+1,jj), nmln(ji,jj) ) ),dp ) -! zfj = REAL( 1 - 1/(1 + jk / MAX( nmln(ji,jj+1), nmln(ji,jj) ) ),dp ) +! zfi = REAL( 1 - 1/(1 + jk / MAX( nmln(ji+1,jj), nmln(ji,jj) ) ), wp ) +! zfj = REAL( 1 - 1/(1 + jk / MAX( nmln(ji,jj+1), nmln(ji,jj) ) ), wp ) ! zci = 0.5 * ( gdept(ji+1,jj,jk,Kmm)+gdept(ji,jj,jk,Kmm) ) / MAX( hmlpt(ji,jj), hmlpt(ji+1,jj), 10. ) ) ! zcj = 0.5 * ( gdept(ji,jj+1,jk,Kmm)+gdept(ji,jj,jk,Kmm) ) / MAX( hmlpt(ji,jj), hmlpt(ji,jj+1), 10. ) ) ! zwz(ji,jj,jk) = ( zfi * zai / ( zbi - zeps ) + ( 1._wp - zfi ) * wslpiml(ji,jj) * zci ) * tmask(ji,jj,jk) ! zww(ji,jj,jk) = ( zfj * zaj / ( zbj - zeps ) + ( 1._wp - zfj ) * wslpjml(ji,jj) * zcj ) * tmask(ji,jj,jk) !!gm end modif END_3D - CALL lbc_lnk( 'ldfslp', zwz, 'U', -1.0_dp, zww, 'V', -1.0_dp ) ! lateral boundary conditions + CALL lbc_lnk( 'ldfslp', zwz, 'U', -1.0_wp, zww, 'V', -1.0_wp ) ! lateral boundary conditions ! ! !* horizontal Shapiro filter DO jk = 2, jpkm1 @@ -282,13 +282,13 @@ CONTAINS !!gm modif to suppress omlmask.... (as in Griffies operator) ! ! ! jk must be >= ML level for zfk=1. otherwise zfk=0. -! zfk = REAL( 1 - 1/(1 + jk / nmln(ji+1,jj)),dp ) +! zfk = REAL( 1 - 1/(1 + jk / nmln(ji+1,jj)), wp ) ! zck = gdepw(ji,jj,jk,Kmm) / MAX( hmlp(ji,jj), 10. ) ! zwz(ji,jj,jk) = ( zfk * zai / ( zbi - zeps ) + ( 1._wp - zfk ) * wslpiml(ji,jj) * zck ) * tmask(ji,jj,jk) ! zww(ji,jj,jk) = ( zfk * zaj / ( zbj - zeps ) + ( 1._wp - zfk ) * wslpjml(ji,jj) * zck ) * tmask(ji,jj,jk) !!gm end modif END_3D - CALL lbc_lnk( 'ldfslp', zwz, 'T', -1.0_dp, zww, 'T', -1.0_dp ) ! lateral boundary conditions + CALL lbc_lnk( 'ldfslp', zwz, 'T', -1.0_wp, zww, 'T', -1.0_wp ) ! lateral boundary conditions ! ! !* horizontal Shapiro filter DO jk = 2, jpkm1 @@ -317,12 +317,12 @@ CONTAINS ! IV. Lateral boundary conditions ! =============================== - CALL lbc_lnk( 'ldfslp', uslp , 'U', -1.0_dp , vslp , 'V', -1.0_dp , wslpi, 'W', -1.0_dp, wslpj, 'W', -1.0_dp ) + CALL lbc_lnk( 'ldfslp', uslp , 'U', -1.0_wp , vslp , 'V', -1.0_wp , wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) - IF(sn_cfctl%l_prtctl) THEN + !IF(sn_cfctl%l_prtctl) THEN !CALL prt_ctl(tab3d_1=uslp , clinfo1=' slp - u : ', tab3d_2=vslp, clinfo2=' v : ') !CALL prt_ctl(tab3d_1=wslpi, clinfo1=' slp - wi: ', tab3d_2=wslpj, clinfo2=' wj: ') - ENDIF + !ENDIF ! IF( ln_timing ) CALL timing_stop('ldf_slp') ! @@ -348,17 +348,17 @@ CONTAINS !! INTEGER :: ji, jj, jk, jl, ip, jp, kp ! dummy loop indices INTEGER :: iku, ikv ! local integer - REAL(dp) :: zfacti, zfactj ! local scalars - REAL(dp) :: znot_thru_surface ! local scalars - REAL(dp) :: zdit, zdis, zdkt, zbu, zbti, zisw - REAL(dp) :: zdjt, zdjs, zdks, zbv, zbtj, zjsw - REAL(dp) :: zdxrho_raw, zti_coord, zti_raw, zti_lim, zti_g_raw, zti_g_lim - REAL(dp) :: zdyrho_raw, ztj_coord, ztj_raw, ztj_lim, ztj_g_raw, ztj_g_lim - REAL(dp) :: zdzrho_raw - REAL(dp) :: zbeta0, ze3_e1, ze3_e2 - REAL(dp), DIMENSION(jpi,jpj) :: z1_mlbw - REAL(dp), DIMENSION(jpi,jpj,jpk,0:1) :: zdxrho , zdyrho, zdzrho ! Horizontal and vertical density gradients - REAL(dp), DIMENSION(jpi,jpj,0:1,0:1) :: zti_mlb, ztj_mlb ! for Griffies operator only + REAL(wp) :: zfacti, zfactj ! local scalars + REAL(wp) :: znot_thru_surface ! local scalars + REAL(wp) :: zdit, zdis, zdkt, zbu, zbti, zisw + REAL(wp) :: zdjt, zdjs, zdks, zbv, zbtj, zjsw + REAL(wp) :: zdxrho_raw, zti_coord, zti_raw, zti_lim, zti_g_raw, zti_g_lim + REAL(wp) :: zdyrho_raw, ztj_coord, ztj_raw, ztj_lim, ztj_g_raw, ztj_g_lim + REAL(wp) :: zdzrho_raw + REAL(wp) :: zbeta0, ze3_e1, ze3_e2 + REAL(wp), DIMENSION(jpi,jpj) :: z1_mlbw + REAL(wp), DIMENSION(jpi,jpj,jpk,0:1) :: zdxrho , zdyrho, zdzrho ! Horizontal and vertical density gradients + REAL(wp), DIMENSION(jpi,jpj,0:1,0:1) :: zti_mlb, ztj_mlb ! for Griffies operator only !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('ldf_slp_triad') @@ -467,7 +467,7 @@ CONTAINS ip = jl ; jp = jl ! i- and j-indices of triads (i-k and j-k planes) DO jk = 1, jpkm1 ! Must mask contribution to slope from dz/dx at constant s for triads jk=1,kp=0 that poke up though ocean surface - znot_thru_surface = REAL( 1-1/(jk+kp),dp ) !jk+kp=1,=0.; otherwise=1.0 + znot_thru_surface = REAL( 1-1/(jk+kp), wp ) !jk+kp=1,=0.; otherwise=1.0 DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) ! ! Calculate slope relative to geopotentials used for GM skew fluxes @@ -495,8 +495,8 @@ CONTAINS ! Below ML use limited zti_g as is & mask ! Inside ML replace by linearly reducing sx_mlb towards surface & mask ! - zfacti = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji+ip,jj)),dp ) ! k index of uppermost point(s) of triad is jk+kp-1 - zfactj = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji,jj+jp)),dp ) ! must be .ge. nmln(ji,jj) for zfact=1 + zfacti = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji+ip,jj)), wp ) ! k index of uppermost point(s) of triad is jk+kp-1 + zfactj = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji,jj+jp)), wp ) ! must be .ge. nmln(ji,jj) for zfact=1 ! ! otherwise zfact=0 zti_g_lim = ( zfacti * zti_g_lim & & + ( 1._wp - zfacti ) * zti_mlb(ji+ip,jj,1-ip,kp) & @@ -549,7 +549,7 @@ CONTAINS ! wslp2(:,:,1) = 0._wp ! force the surface wslp to zero - CALL lbc_lnk( 'ldfslp', wslp2, 'W', 1.0_dp ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked + CALL lbc_lnk( 'ldfslp', wslp2, 'W', 1.0_wp ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked ! IF( ln_timing ) CALL timing_stop('ldf_slp_triad') ! @@ -572,18 +572,18 @@ CONTAINS !! vslpml, wslpjml just below the mixed layer !! omlmask : mixed layer mask !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:,:), INTENT(in) :: prd ! in situ density - REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pn2 ! Brunt-Vaisala frequency (locally ref.) - REAL(dp), DIMENSION(:,:,:), INTENT(in) :: p_gru, p_grv ! i- & j-gradient of density (u- & v-pts) - REAL(dp), DIMENSION(:,:,:), INTENT(in) :: p_dzr ! z-gradient of density (T-point) + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: prd ! in situ density + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pn2 ! Brunt-Vaisala frequency (locally ref.) + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: p_gru, p_grv ! i- & j-gradient of density (u- & v-pts) + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: p_dzr ! z-gradient of density (T-point) INTEGER , INTENT(in) :: Kmm ! ocean time level indices !! INTEGER :: ji , jj , jk ! dummy loop indices INTEGER :: iku, ikv, ik, ikm1 ! local integers - REAL(dp) :: zeps, zm1_g, zm1_2g, z1_slpmax ! local scalars - REAL(dp) :: zci, zfi, zau, zbu, zai, zbi ! - - - REAL(dp) :: zcj, zfj, zav, zbv, zaj, zbj ! - - - REAL(dp) :: zck, zfk, zbw ! - - + REAL(wp) :: zeps, zm1_g, zm1_2g, z1_slpmax ! local scalars + REAL(wp) :: zci, zfi, zau, zbu, zai, zbi ! - - + REAL(wp) :: zcj, zfj, zav, zbv, zaj, zbj ! - - + REAL(wp) :: zck, zfk, zbw ! - - !!---------------------------------------------------------------------- ! zeps = 1.e-20_wp !== Local constant initialization ==! @@ -658,7 +658,7 @@ CONTAINS wslpjml(ji,jj) = zaj / ( zbj - zeps ) * tmask (ji,jj,ik) END_2D !!gm this lbc_lnk should be useless.... - CALL lbc_lnk( 'ldfslp', uslpml , 'U', -1.0_dp , vslpml , 'V', -1.0_dp , wslpiml, 'W', -1.0_dp , wslpjml, 'W', -1.0_dp ) + CALL lbc_lnk( 'ldfslp', uslpml , 'U', -1.0_wp , vslpml , 'V', -1.0_wp , wslpiml, 'W', -1.0_wp , wslpjml, 'W', -1.0_wp ) ! END SUBROUTINE ldf_slp_mxl @@ -733,4 +733,4 @@ CONTAINS END SUBROUTINE ldf_slp_init !!====================================================================== -END MODULE ldfslp +END MODULE ldfslp \ No newline at end of file diff --git a/src/OCE/LDF/ldftra.F90 b/src/OCE/LDF/ldftra.F90 index c5b0f926742210dfd633ea5aaaf6d75e1f4c0d04..a7eed1802f6f49d0927dac90975a080d6dbe78a5 100644 --- a/src/OCE/LDF/ldftra.F90 +++ b/src/OCE/LDF/ldftra.F90 @@ -60,8 +60,8 @@ MODULE ldftra 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(dp), PUBLIC :: rn_Ud !: lateral diffusive velocity [m/s] - REAL(dp), PUBLIC :: rn_Ld !: lateral diffusive length [m] + 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 =! @@ -69,8 +69,8 @@ MODULE ldftra LOGICAL , PUBLIC :: ln_ldfeiv_dia !: diagnose & output eiv streamfunction and velocity (IOM) ! != Coefficients =! INTEGER , PUBLIC :: nn_aei_ijk_t !: choice of time/space variation of the eiv coeff. - REAL(dp), PUBLIC :: rn_Ue !: lateral diffusive velocity [m/s] - REAL(dp), PUBLIC :: rn_Le !: lateral diffusive length [m] + REAL(wp), PUBLIC :: rn_Ue !: lateral diffusive velocity [m/s] + REAL(wp), PUBLIC :: rn_Le !: lateral diffusive length [m] ! ! Flag to control the type of lateral diffusive operator INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 ! error in specification of lateral diffusion @@ -84,13 +84,13 @@ MODULE ldftra 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(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahtu, ahtv !: eddy diffusivity coef. at U- and V-points [m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aeiu, aeiv !: eddy induced velocity coeff. [m2/s] + 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(dp) :: aht0, aei0 ! constant eddy coefficients (deduced from namelist values) [m2/s] - REAL(dp) :: r1_2 = 0.5_wp ! =1/2 - REAL(dp) :: r1_4 = 0.25_wp ! =1/4 - REAL(dp) :: r1_12 = 1._wp / 12._wp ! =1/12 + 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" @@ -132,7 +132,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: jk ! dummy loop indices INTEGER :: ioptio, ierr, inum, ios, inn ! local integer - REAL(dp) :: zah_max, zUfac ! - - + 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 @@ -401,7 +401,7 @@ CONTAINS INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zaht, zahf, zaht_min, zDaht, z1_f20 ! local scalar + 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 @@ -492,7 +492,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: jk ! dummy loop indices INTEGER :: ierr, inum, ios, inn ! local integer - REAL(dp) :: zah_max, zUfac ! - scalar + 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 @@ -632,12 +632,12 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! ocean time-step index INTEGER , INTENT(in ) :: Kmm ! ocean time level indices - REAL(dp) , INTENT(in ) :: paei0 ! max value [m2/s] - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: paeiu, paeiv ! eiv coefficient [m2/s] + 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(dp) :: zfw, ze3w, zn2, z1_f20, zzaei ! local scalars - REAL(dp), DIMENSION(jpi,jpj) :: zn, zah, zhw, zRo, zaeiw ! 2D workspace + REAL(wp) :: zfw, ze3w, zn2, z1_f20, zzaei ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zn, zah, zhw, zRo, zaeiw ! 2D workspace !!---------------------------------------------------------------------- ! zn (:,:) = 0._wp ! Local initialization @@ -690,13 +690,13 @@ CONTAINS 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 - IF( nn_hls == 1 ) CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1.0_dp ) ! lateral boundary condition + 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_dp , paeiv(:,:,1), 'V', 1.0_dp ) ! lateral boundary condition + 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) @@ -729,14 +729,14 @@ CONTAINS 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components [m3/s] - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: 3 ocean transport components [m3/s] - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the eiv [m3/s] + 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(dp) :: zuwk, zuwk1, zuwi, zuwi1 ! local scalars - REAL(dp) :: zvwk, zvwk1, zvwj, zvwj1 ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw + 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 @@ -783,13 +783,13 @@ CONTAINS !! ** Method : !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(in) :: psi_uw, psi_vw ! streamfunction [m3/s] + 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(dp) :: zztmp ! local scalar - REAL(dp), DIMENSION(A2D(nn_hls)) :: zw2d ! 2D workspace - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zw3d ! 3D workspace + 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... @@ -867,7 +867,7 @@ CONTAINS 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' ) ) 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 @@ -891,7 +891,7 @@ CONTAINS 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' ) ) 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/src/OCE/OBS/ddatetoymdhms.h90 b/src/OCE/OBS/ddatetoymdhms.h90 index 9a5b52339832c22809c56baa48ed0fd5284daea6..91a0b6e647db9f86b5be138ddd562de280a1a1d8 100644 --- a/src/OCE/OBS/ddatetoymdhms.h90 +++ b/src/OCE/OBS/ddatetoymdhms.h90 @@ -20,7 +20,7 @@ !! * Modules used !! * Arguments - real(dp), INTENT(IN) :: ddate + real(wp), INTENT(IN) :: ddate INTEGER, INTENT(OUT) :: kyea INTEGER, INTENT(OUT) :: kmon INTEGER, INTENT(OUT) :: kday diff --git a/src/OCE/OBS/diaobs.F90 b/src/OCE/OBS/diaobs.F90 index bcbec99bfbad851fe2024803b4bb62b6e03bde1d..38e54a7e81f2aec70506cd5e84f3109ae306b2f8 100644 --- a/src/OCE/OBS/diaobs.F90 +++ b/src/OCE/OBS/diaobs.F90 @@ -64,16 +64,16 @@ MODULE diaobs LOGICAL :: ln_sss_fp_indegs ! T=> SSS obs footprint size specified in degrees, F=> in metres LOGICAL :: ln_sic_fp_indegs ! T=> sea-ice obs footprint size specified in degrees, F=> in metres - REAL(dp) :: rn_default_avglamscl ! E/W diameter of SLA observation footprint (metres) - REAL(dp) :: rn_default_avgphiscl ! N/S diameter of SLA observation footprint (metre - REAL(dp) :: rn_sla_avglamscl ! E/W diameter of SLA observation footprint (metres) - REAL(dp) :: rn_sla_avgphiscl ! N/S diameter of SLA observation footprint (metres) - REAL(dp) :: rn_sst_avglamscl ! E/W diameter of SST observation footprint (metres) - REAL(dp) :: rn_sst_avgphiscl ! N/S diameter of SST observation footprint (metres) - REAL(dp) :: rn_sss_avglamscl ! E/W diameter of SSS observation footprint (metres) - REAL(dp) :: rn_sss_avgphiscl ! N/S diameter of SSS observation footprint (metres) - REAL(dp) :: rn_sic_avglamscl ! E/W diameter of sea-ice observation footprint (metres) - REAL(dp) :: rn_sic_avgphiscl ! N/S diameter of sea-ice observation footprint (metres) + REAL(wp) :: rn_default_avglamscl ! E/W diameter of SLA observation footprint (metres) + REAL(wp) :: rn_default_avgphiscl ! N/S diameter of SLA observation footprint (metre + REAL(wp) :: rn_sla_avglamscl ! E/W diameter of SLA observation footprint (metres) + REAL(wp) :: rn_sla_avgphiscl ! N/S diameter of SLA observation footprint (metres) + REAL(wp) :: rn_sst_avglamscl ! E/W diameter of SST observation footprint (metres) + REAL(wp) :: rn_sst_avgphiscl ! N/S diameter of SST observation footprint (metres) + REAL(wp) :: rn_sss_avglamscl ! E/W diameter of SSS observation footprint (metres) + REAL(wp) :: rn_sss_avgphiscl ! N/S diameter of SSS observation footprint (metres) + REAL(wp) :: rn_sic_avglamscl ! E/W diameter of sea-ice observation footprint (metres) + REAL(wp) :: rn_sic_avgphiscl ! N/S diameter of sea-ice observation footprint (metres) INTEGER :: nn_1dint ! Vertical interpolation method INTEGER :: nn_2dint_default ! Default horizontal interpolation method @@ -87,7 +87,7 @@ MODULE diaobs INTEGER , DIMENSION(:), ALLOCATABLE :: nvarsprof, nvarssurf ! Number of profile & surface variables INTEGER , DIMENSION(:), ALLOCATABLE :: nextrprof, nextrsurf ! Number of profile & surface extra variables INTEGER , DIMENSION(:), ALLOCATABLE :: n2dintsurf ! Interpolation option for surface variables - REAL(dp), DIMENSION(:), ALLOCATABLE :: zavglamscl, zavgphiscl ! E/W & N/S diameter of averaging footprint for surface variables + REAL(wp), DIMENSION(:), ALLOCATABLE :: zavglamscl, zavgphiscl ! E/W & N/S diameter of averaging footprint for surface variables LOGICAL , DIMENSION(:), ALLOCATABLE :: lfpindegs ! T=> surface obs footprint size specified in degrees, F=> in metres LOGICAL , DIMENSION(:), ALLOCATABLE :: llnightav ! Logical for calculating night-time averages @@ -161,13 +161,13 @@ CONTAINS LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar ! Logical for profile variable read LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files ! - REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS - REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS - REAL(dp) :: ztype_avglamscl ! Local version of rn_*_avglamscl - REAL(dp) :: ztype_avgphiscl ! Local version of rn_*_avgphiscl - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zglam ! Model longitudes for profile variables - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zgphi ! Model latitudes for profile variables - REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: zmask ! Model land/sea mask associated with variables + REAL(wp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS + REAL(wp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS + REAL(wp) :: ztype_avglamscl ! Local version of rn_*_avglamscl + REAL(wp) :: ztype_avgphiscl ! Local version of rn_*_avgphiscl + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zglam ! Model longitudes for profile variables + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zgphi ! Model latitudes for profile variables + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zmask ! Model land/sea mask associated with variables !! NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla, & & ln_sst, ln_sic, ln_sss, ln_vel3d, & @@ -623,21 +623,17 @@ CONTAINS INTEGER :: jtype ! Data loop variable INTEGER :: jvar ! Variable number INTEGER :: ji, jj, jk ! Loop counters - REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: zprofvar - - - REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: zprofmask - - - REAL(dp), DIMENSION(jpi,jpj) :: zsurfvar, zsurfmask - - - - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zglam, zgphi - - - - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zdept, zdepw + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & + & zprofvar ! Model values for variables in a prof ob + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & + & zprofmask ! Mask associated with zprofvar + REAL(wp), DIMENSION(jpi,jpj) :: & + & zsurfvar, & ! Model values equivalent to surface ob. + & zsurfmask ! Mask associated with surface variable + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zglam, & ! Model longitudes for prof variables + & zgphi ! Model latitudes for prof variables + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zdept, zdepw !----------------------------------------------------------------------- @@ -786,10 +782,9 @@ CONTAINS !! * Local declarations INTEGER :: jtype ! Data set loop variable INTEGER :: jo, jvar, jk - REAL(dp), DIMENSION(:), ALLOCATABLE :: zu, zv - - - + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zu, & + & zv !----------------------------------------------------------------------- ! Depending on switches call various observation output routines @@ -907,7 +902,7 @@ CONTAINS IMPLICIT NONE !! * Arguments - REAL(KIND=dp), INTENT(OUT) :: ddobs ! Date in YYYYMMDD.HHMMSS + REAL(KIND=wp), INTENT(OUT) :: ddobs ! Date in YYYYMMDD.HHMMSS INTEGER, INTENT(IN) :: kstp !! * Local declarations @@ -917,7 +912,7 @@ CONTAINS INTEGER :: ihou INTEGER :: imin INTEGER :: imday ! Number of days in month. - REAL(dp) :: zdayfrc ! Fraction of day + REAL(wp) :: zdayfrc ! Fraction of day INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year @@ -991,7 +986,7 @@ CONTAINS IMPLICIT NONE !! * Arguments - REAL(KIND=dp), INTENT(OUT) :: ddobsini ! Initial date in YYYYMMDD.HHMMSS + REAL(KIND=wp), INTENT(OUT) :: ddobsini ! Initial date in YYYYMMDD.HHMMSS CALL calc_date( nit000 - 1, ddobsini ) @@ -1018,7 +1013,7 @@ CONTAINS IMPLICIT NONE !! * Arguments - REAL(dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS + REAL(wp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS CALL calc_date( nitend, ddobsfin ) @@ -1074,19 +1069,17 @@ CONTAINS INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolation type INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolation type - REAL(dp), INTENT(IN) :: ravglamscl_type, ravgphiscl_type - - - + REAL(wp), INTENT(IN) :: & + & ravglamscl_type, & !E/W diameter of obs footprint for this type + & ravgphiscl_type !N/S diameter of obs footprint for this type LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average CHARACTER(len=8), INTENT(IN) :: ctypein INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & & n2dint - REAL(dp), DIMENSION(ntypes), INTENT(INOUT) :: ravglamscl, ravgphiscl - - + REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & + & ravglamscl, ravgphiscl LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & & lfpindegs, lavnight diff --git a/src/OCE/OBS/grt_cir_dis.h90 b/src/OCE/OBS/grt_cir_dis.h90 index 8da1151c639a2b8863ecf6dd5ad41ec738c34aaa..c4ea5c224625559391c1cedaaffc26beb2d4d3be 100644 --- a/src/OCE/OBS/grt_cir_dis.h90 +++ b/src/OCE/OBS/grt_cir_dis.h90 @@ -4,7 +4,7 @@ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- - REAL(KIND=dp) FUNCTION grt_cir_dis( pa1, pa2, pb1, pb2, pc1, pc2 ) + REAL(KIND=wp) FUNCTION grt_cir_dis( pa1, pa2, pb1, pb2, pc1, pc2 ) !!---------------------------------------------------------------------- !! *** FUNCTION grt_cir_dis *** !! @@ -20,14 +20,14 @@ !!---------------------------------------------------------------------- !! * Arguments - REAL(KIND=dp) :: pa1 ! sin(lat1) - REAL(KIND=dp) :: pa2 ! sin(lat2) - REAL(KIND=dp) :: pb1 ! cos(lat1) * cos(lon1) - REAL(KIND=dp) :: pb2 ! cos(lat2) * cos(lon2) - REAL(KIND=dp) :: pc1 ! cos(lat1) * sin(lon1) - REAL(KIND=dp) :: pc2 ! cos(lat2) * sin(lon2) + REAL(KIND=wp) :: pa1 ! sin(lat1) + REAL(KIND=wp) :: pa2 ! sin(lat2) + REAL(KIND=wp) :: pb1 ! cos(lat1) * cos(lon1) + REAL(KIND=wp) :: pb2 ! cos(lat2) * cos(lon2) + REAL(KIND=wp) :: pc1 ! cos(lat1) * sin(lon1) + REAL(KIND=wp) :: pc2 ! cos(lat2) * sin(lon2) - REAL(KIND=dp) :: cosdist ! cosine of great circle distance + REAL(KIND=wp) :: cosdist ! cosine of great circle distance ! Compute cosine of great circle distance, constraining it to be between ! -1 and 1 (rounding errors can take it slightly outside this range diff --git a/src/OCE/OBS/grt_cir_dis_saa.h90 b/src/OCE/OBS/grt_cir_dis_saa.h90 index ba375a7735c6adb6b0f9eb0cca6ada0cd1800400..c76484a0a7c0ca91ff6b5bcdc89d2c2f3c6023ef 100644 --- a/src/OCE/OBS/grt_cir_dis_saa.h90 +++ b/src/OCE/OBS/grt_cir_dis_saa.h90 @@ -4,7 +4,7 @@ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- - REAL(KIND=dp) FUNCTION grt_cir_dis_saa( pa, pb, pc ) + REAL(KIND=wp) FUNCTION grt_cir_dis_saa( pa, pb, pc ) !!---------------------------------------------------------------------- !! *** FUNCTION grt_cir_dis_saa *** !! @@ -22,9 +22,9 @@ !!---------------------------------------------------------------------- !! * Arguments - REAL(KIND=dp) :: pa ! lon1 - lon2 - REAL(KIND=dp) :: pb ! lat1 - lat2 - REAL(KIND=dp) :: pc ! cos(lat2) + REAL(KIND=wp) :: pa ! lon1 - lon2 + REAL(KIND=wp) :: pb ! lat1 - lat2 + REAL(KIND=wp) :: pc ! cos(lat2) grt_cir_dis_saa = SQRT( pa * pa + ( pb * pc )**2 ) diff --git a/src/OCE/OBS/jul2greg.h90 b/src/OCE/OBS/jul2greg.h90 index ac78a039207d6e8edeb47bedcc902235037dd325..f7087c95214e1f09409aeaee69a8d1cb683b565e 100644 --- a/src/OCE/OBS/jul2greg.h90 +++ b/src/OCE/OBS/jul2greg.h90 @@ -51,10 +51,9 @@ RECURSIVE SUBROUTINE jul2greg( ksec, kminut, khour, kday, kmonth, kyear, & & imon, & & iyea, & & iref - REAL(KIND=dp) :: zday, zref - - - + REAL(KIND=wp) :: & + & zday, & + & zref CHARACTER(len=200) :: & & cerr diff --git a/src/OCE/OBS/linquad.h90 b/src/OCE/OBS/linquad.h90 index aba0ffe1917a9984f799467d9b15b72efbce378b..b6d1e1730fdb7a99686f8834bd3afdc7e2b057ab 100644 --- a/src/OCE/OBS/linquad.h90 +++ b/src/OCE/OBS/linquad.h90 @@ -23,18 +23,17 @@ !!---------------------------------------------------------------------- !! * Arguments - REAL(KIND=dp), INTENT(IN) :: px ! (lon) of the point P(x,y) - REAL(KIND=dp), INTENT(IN) :: py ! (lat) of the point P(x,y) - REAL(KIND=dp), DIMENSION(4), INTENT(IN) :: pxv, pyv - - - + REAL(KIND=wp), INTENT(IN) :: px ! (lon) of the point P(x,y) + REAL(KIND=wp), INTENT(IN) :: py ! (lat) of the point P(x,y) + REAL(KIND=wp), DIMENSION(4), INTENT(IN) :: & + & pxv, & ! (lon, lat) of the surrounding cell + & pyv !! * Local declarations - REAL(KIND=dp) :: zst1 - REAL(KIND=dp) :: zst2 - REAL(KIND=dp) :: zst3 - REAL(KIND=dp) :: zst4 + REAL(KIND=wp) :: zst1 + REAL(KIND=wp) :: zst2 + REAL(KIND=wp) :: zst3 + REAL(KIND=wp) :: zst4 !----------------------------------------------------------------------- ! Test to see if the point is within the cell diff --git a/src/OCE/OBS/maxdist.h90 b/src/OCE/OBS/maxdist.h90 index 593a6574ece287ee4924ee1100c76236cb9303d0..48bfdbe245ac370b7575d7c8daa93d617d1a190c 100644 --- a/src/OCE/OBS/maxdist.h90 +++ b/src/OCE/OBS/maxdist.h90 @@ -4,7 +4,7 @@ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- - REAL(dp) FUNCTION maxdist( pxv, pyv ) + REAL(wp) FUNCTION maxdist( pxv, pyv ) !!---------------------------------------------------------------------- !! *** FUNCTION maxdist *** !! @@ -26,14 +26,13 @@ & pyv !! * Local declarations - REAL(KIND=dp), DIMENSION(4) :: zxv, zyv, za, zb, zc - - - - - - - REAL(KIND=dp) :: zdist + REAL(KIND=wp), DIMENSION(4) :: & + & zxv, & + & zyv, & + & za, & + & zb, & + & zc + REAL(KIND=wp) :: zdist INTEGER :: ji INTEGER :: jj diff --git a/src/OCE/OBS/obs_averg_h2d.F90 b/src/OCE/OBS/obs_averg_h2d.F90 index b91ba8c638a5b4b944546f49173edd950ddce078..d019f6ffd533160e184870fda849806b35bbf11c 100644 --- a/src/OCE/OBS/obs_averg_h2d.F90 +++ b/src/OCE/OBS/obs_averg_h2d.F90 @@ -47,7 +47,6 @@ MODULE obs_averg_h2d !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- -# include "single_precision_substitute.h90" CONTAINS SUBROUTINE obs_avg_h2d_init( kpk, kpk2, kmaxifp, kmaxjfp, k2dint, plam, pphi, & & pglam, pgphi, pglamf, pgphif, pmask, plamscl, pphiscl, lindegrees, & @@ -79,30 +78,24 @@ CONTAINS & kmaxifp, & ! Max size of model points in i-direction for obs footprint & kmaxjfp, & ! Max size of model points in j-direction for obs footprint & k2dint ! Averaging scheme options - see header - REAL(KIND=dp), INTENT(INOUT) :: plam, pphi - - - - REAL(KIND=dp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: pglam, pgphi - - - - REAL(KIND=dp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: pglamf, pgphif - - - - REAL(KIND=dp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: pmask - - - REAL(KIND=dp), INTENT(IN) :: plamscl, pphiscl - - - + REAL(KIND=wp), INTENT(INOUT) :: & + & plam, & ! Geographical (lat,lon) coordinates of + & pphi ! observation + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: & + & pglam, & ! Model variable lon + & pgphi ! Model variable lat + REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: & + & pglamf, & ! Model variable lon at corners of grid-boxes + & pgphif ! Model variable lat at corners of grid-boxes + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & ! Diameter (lat,lon) of obs footprint in metres + & pphiscl ! This is the full width (rather than half-width) LOGICAL, INTENT(IN) :: & & lindegrees ! T=> obs footprint specified in degrees, F=> in metres - REAL(KIND=dp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: pweig - - + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: & + & pweig ! Weights for averaging INTEGER, INTENT(IN), OPTIONAL :: & & iminpoints ! Reject point which is not surrounded ! by at least iminpoints sea points @@ -173,31 +166,25 @@ CONTAINS & kmaxifp, & ! Max size of model points in i-direction for obs footprint & kmaxjfp ! Max size of model points in j-direction for obs footprint - REAL(KIND=dp), INTENT(IN) :: plam, pphi - - - + REAL(KIND=wp), INTENT(IN) :: & + & plam, & + & pphi ! Geographical (lat,lon) coordinates of ! observation - REAL(KIND=dp), INTENT(IN) :: plamscl, pphiscl - - - + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & ! Diameter (lat,lon) of obs footprint in metres or degrees (see below) + & pphiscl ! This is the full width (rather than half-width) LOGICAL, INTENT(IN) :: & & lindegrees ! T=>scales specified in degrees, F=> in metres - REAL(KIND=dp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: pmask - - - REAL(KIND=dp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: pglam, pgphi - - - - REAL(KIND=dp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: pglamf, pgphif - - - - REAL(KIND=dp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: pweig - - + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: & + & pglam, & ! Model variable lon + & pgphi ! Model variable lat + REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: & + & pglamf, & ! Model variable lon at corners of grid boxes + & pgphif ! Model variable lat at corners of grid boxes + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: & + & pweig ! Weights for interpolation !! Local declarations INTEGER :: ji, jj, jk @@ -206,26 +193,22 @@ CONTAINS INTEGER, PARAMETER :: & & jnumsubgrid = 20 ! The number of sub grid-boxes (in x and y directions) used to approximate area of obs fp - REAL(KIND=dp), DIMENSION(4) :: zxvert, zyvert, zdist - - - - REAL(KIND=dp), DIMENSION(4) :: zxgrid, zygrid, zdgrid - - - - REAL(KIND=dp) :: zdx, zdy, zarea_subbox, zxpos, zypos, zsubdist, zarea_fp, zareabox - - - - - - - - REAL(KIND=dp) :: zphiscl_m, zlamscl_m - - - + REAL(KIND=wp), DIMENSION(4) :: & + & zxvert, zyvert, & ! The lon/lat of the vertices(corners) of the grid box in m relative to centre of obs fp + & zdist ! Distance of each vertex to the centre of the obs footprint + REAL(KIND=wp), DIMENSION(4) :: & + & zxgrid, zygrid, & ! Distance of each vertex of grid box to the centre of the grid box in x/y directions + & zdgrid + REAL(KIND=wp) :: & + & zdx, zdy, & ! The sub grid-box sizes (in metres) + & zarea_subbox, & ! The area of each sub grid-box (in metres squared) + & zxpos, zypos, & ! The x,y position (relative to centre of obs footprint) of the centre of each sub grid-box + & zsubdist, & ! The distance of the centre of each sub grid-box from the centre of the obs footprint + & zarea_fp, & ! Total area of obs footprint within the grid box + & zareabox ! Total area of the grid box + REAL(KIND=wp) :: & + & zphiscl_m, & ! Diameter of obs footprint in metres + & zlamscl_m !--------------------------------------------------------------------------------------------------- !Initialise weights to zero. pweig(:,:,:) = 0.0_wp @@ -306,17 +289,17 @@ CONTAINS ! For now split the grid box into a specified number of smaller ! boxes and add up the area of those whose centre is within the obs footprint. ! Order of vertices is 1=topleft, 2=topright, 3=bottomright, 4=bottomleft - zdx = ABS( zxvert(3) - zxvert(4) ) / REAL(jnumsubgrid,dp) - zdy = ABS( zyvert(1) - zyvert(4) ) / REAL(jnumsubgrid,dp) + zdx = ABS( zxvert(3) - zxvert(4) ) / REAL(jnumsubgrid, wp) + zdy = ABS( zyvert(1) - zyvert(4) ) / REAL(jnumsubgrid, wp) zarea_subbox = zdx * zdy zarea_fp = 0.0_wp DO jis = 1, jnumsubgrid - zxpos = zxvert(4) + ( REAL(jis,dp) * zdx ) - (0.5_wp * zdx ) + zxpos = zxvert(4) + ( REAL(jis, wp) * zdx ) - (0.5_wp * zdx ) DO jjs = 1, jnumsubgrid !Find the distance of the centre of this sub grid box to the !centre of the obs footprint - zypos = zyvert(4) + ( REAL(jjs,dp) * zdy ) - ( 0.5_wp * zdy ) + zypos = zyvert(4) + ( REAL(jjs, wp) * zdy ) - ( 0.5_wp * zdy ) zsubdist = SQRT( (zxpos * zxpos) + (zypos * zypos) ) IF ( zsubdist < ( zphiscl_m / 2.0_wp ) ) & & zarea_fp = zarea_fp + zarea_subbox @@ -366,65 +349,52 @@ CONTAINS & kmaxifp, & ! Max size of model points in i-direction for obs footprint & kmaxjfp ! Max size of model points in j-direction for obs footprint - REAL(KIND=dp), INTENT(IN) :: plam, pphi - - - + REAL(KIND=wp), INTENT(IN) :: & + & plam, & + & pphi ! Geographical (lat,lon) coordinates of ! observation - REAL(KIND=dp), INTENT(IN) :: plamscl, pphiscl - - - + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & + & pphiscl ! Width in x/y directions of obs footprint in metres ! This is the full width (rather than half-width) LOGICAL, INTENT(IN) :: & & lindegrees !T=> scales specified in degrees, F=> in metres - REAL(KIND=dp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: pmask - - - REAL(KIND=dp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: pglam, pgphi - - - - REAL(KIND=dp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: pglamf, pgphif - - - - REAL(KIND=dp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: pweig - - + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: & + & pglam, & ! Model variable lat at centre of grid boxes + & pgphi ! Model variable lon at centre of grid boxes + REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: & + & pglamf, & ! Model variable lat at corners of grid boxes + & pgphif ! Model variable lon at corners of grid boxes + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: & + & pweig ! Weights for interpolation !! Local declarations INTEGER :: ji, jj, jk INTEGER :: jvert INTEGER, DIMENSION(4) :: & & jnumvert - REAL(KIND=dp), DIMENSION(4) :: zxvert, zyvert - - - REAL(KIND=dp), DIMENSION(4) :: zdist - - - REAL(KIND=dp), DIMENSION(4) :: zxgrid, zygrid, zdgrid - - - - REAL(KIND=dp) :: zareabox, zarea_fp, zarea_intersect - - - - - REAL(KIND=dp) :: zlamscl_m, zphiscl_m - - - - REAL(KIND=dp) :: z_awidth, z_aheight, z_cwidth, z_cheight - - - - REAL(KIND=dp) :: zleft, zright, ztop, zbottom - - - + REAL(KIND=wp), DIMENSION(4) :: & + & zxvert, zyvert ! The lon/lat of the vertices(corners) of the grid box in m relative to centre of obs fp + REAL(KIND=wp), DIMENSION(4) :: & + & zdist ! Distance of each vertex to the centre of the obs footprint + REAL(KIND=wp), DIMENSION(4) :: & + & zxgrid, zygrid, & ! Distance of each vertex of grid box to the centre of the grid box in x/y directions + & zdgrid + REAL(KIND=wp) :: & + & zareabox, & ! Total area of grid box + & zarea_fp, & ! Total area of obs footprint + & zarea_intersect ! Area of the intersection between the grid box and the obs footprint + REAL(KIND=wp) :: & + & zlamscl_m, & + & zphiscl_m ! Total width (lat,lon) of obs footprint in metres + REAL(KIND=wp) :: & + & z_awidth, z_aheight, & ! Width and height of model grid box + & z_cwidth, z_cheight ! Width and height of union of model grid box and obs footprint + REAL(KIND=wp) :: & + & zleft, zright, & ! Distance (metres) of corners area of intersection + & ztop, zbottom ! between grid box and obs footprint !----------------------------------------------------------------------- @@ -533,23 +503,19 @@ CONTAINS INTEGER, INTENT(IN) :: & & kmaxifp, & ! Max size of model points in i-direction for obs footprint & kmaxjfp ! Max size of model points in j-direction for obs footprint - REAL(KIND=dp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: pweig - - - REAL(KIND=dp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: pmod - - - REAL(KIND=dp), DIMENSION(kpk2), INTENT(OUT) :: pobsk - - + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pweig ! Interpolation weights + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmod ! Model variable to interpolate + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsk ! Model profile interpolated to obs (i,j) pt INTEGER :: & & jk INTEGER :: & & ikmax - REAL(KIND=dp) :: zsum - - + REAL(KIND=wp) :: & + & zsum !------------------------------------------------------------------------ ! Initialize number of levels @@ -604,29 +570,25 @@ CONTAINS !! * Arguments INTEGER , INTENT(IN) :: & & k2dint !Type of interpolation/averaging used - REAL(KIND=dp), INTENT(IN) :: plamscl, pphiscl - - - + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & !Total width/radius in metres of the observation footprint + & pphiscl ! LOGICAL, INTENT(IN) :: & & lindegrees !T=> plamscl and pphiscl are specified in degrees - REAL(KIND=dp), DIMENSION(jpi,jpj), INTENT(IN) :: pmask - - + REAL(KIND=wp), DIMENSION(jpi,jpj), INTENT(IN) :: & + & pmask !Land/sea mask !F=> plamscl and pphiscl are specified in metres INTEGER, INTENT(OUT) :: & & kmaxifp, & !Max number of grid points in i,j directions to use in averaging & kmaxjfp !these have to be even so that the footprint is centred !! * Local variables - REAL(KIND=dp) :: ze1min, ze2min - - - - REAL(KIND=dp) :: zphiscl_m, zlamscl_m - - - + REAL(KIND=wp) :: & + & ze1min, & !Minimum global grid-size in i,j directions + & ze2min + REAL(KIND=wp) :: & + & zphiscl_m, & + & zlamscl_m !------------------------------------------------------------------------ IF ( k2dint <= 4 ) THEN @@ -640,7 +602,7 @@ CONTAINS !If the scales are specified in degrees, work out the max !distance (metres) in x/y directions CALL obs_deg2dist( jpi, jpj, glamt, gphit, & - & CASTDP(plamscl), CASTDP(pphiscl), zlamscl_m, zphiscl_m ) + & plamscl, pphiscl, zlamscl_m, zphiscl_m ) ELSE zlamscl_m = plamscl zphiscl_m = pphiscl @@ -689,29 +651,24 @@ CONTAINS !! * Arguments INTEGER , INTENT(IN) :: & & ki, kj !x/y dimensions of input lat/lon variables - REAL(KIND=dp), INTENT(IN), DIMENSION(ki,kj) :: pglam, pgphi - - - REAL(KIND=dp), INTENT(IN) :: plamscl_deg, pphiscl_deg - - - - REAL(KIND=dp), INTENT(OUT) :: plamscl_max, pphiscl_max - - - + REAL(KIND=wp), INTENT(IN), DIMENSION(ki,kj) :: & + & pglam, pgphi !Longitude and latitudes of grid points + REAL(KIND=wp), INTENT(IN) :: & + & plamscl_deg, & !Size in degrees of the observation footprint + & pphiscl_deg ! + REAL(KIND=wp), INTENT(OUT) :: & + & plamscl_max, & !Maximum size of obs footprint in metres + & pphiscl_max !! * Local declarations INTEGER :: & & ji, jj !Counters - REAL(KIND=dp) :: zlon1, zlon2, zlat1, zlat2, zdlat, zdlon - - - - - REAL(KIND=dp) :: za1, za2, za, zc, zd - - + REAL(KIND=wp) :: & + & zlon1, zlon2, & !Lon values surrounding centre of grid point + & zlat1, zlat2, & !Lat values surrounding centre of grid point + & zdlat, zdlon !Distance in radians in lat/lon directions + REAL(KIND=wp) :: & + & za1, za2, za, zc, zd plamscl_max = -1.0_wp pphiscl_max = -1.0_wp @@ -779,39 +736,31 @@ CONTAINS !!----------------------------------------------------------------------- !! * Modules used !! * Arguments - REAL(KIND=dp), INTENT(IN) :: pglam_bl, pglam_br, pglam_tl, pglam_tr - - - - REAL(KIND=dp), INTENT(IN) :: pgphi_bl, pgphi_br, pgphi_tl, pgphi_tr - - - - REAL(KIND=dp), INTENT(IN) :: pphi, plam - - - REAL(KIND=dp), DIMENSION(4), INTENT(OUT) :: pxvert, pyvert - - - REAL(KIND=dp), DIMENSION(4), INTENT(OUT) :: pdist - - + REAL(KIND=wp), INTENT(IN) :: & + & pglam_bl, pglam_br, & !lon at corners of grid box + & pglam_tl, pglam_tr + REAL(KIND=wp), INTENT(IN) :: & + & pgphi_bl, pgphi_br, & !lat at corners of grid box + & pgphi_tl, pgphi_tr + REAL(KIND=wp), INTENT(IN) :: & + & pphi, plam !lat/lon of centre of obs footprint + REAL(KIND=wp), DIMENSION(4), INTENT(OUT) :: & + & pxvert, pyvert !x/y location (in metres relative to centre of obs footprint) of corners + REAL(KIND=wp), DIMENSION(4), INTENT(OUT) :: & + & pdist !distance (in metres) of each corner relative to centre of obs footprint !! * Local variables INTEGER :: & & jvert !Counter for corners - REAL(KIND=dp) :: zphi, zlam - - - REAL(KIND=dp) :: za1, za2, zb1, zb2, zc1, zc2 - - - - - REAL(KIND=dp) :: zdist_centre_lat, zdist_centre_lon - - - + REAL(KIND=wp) :: & + & zphi, zlam !Local values for lon/lat of corners + REAL(KIND=wp) :: & + & za1, za2, & !For great circle distance calculations + & zb1, zb2, & + & zc1, zc2 + REAL(KIND=wp) :: & + & zdist_centre_lat, & !Distances in lat/lon directions (in metres) + & zdist_centre_lon !!----------------------------------------------------------------------- diff --git a/src/OCE/OBS/obs_conv.F90 b/src/OCE/OBS/obs_conv.F90 index 4c6d98aaae829249a12b5deb1db4dfceb1e23d0b..e3bdbad3801950924ce3fff1533526d7a3cc45b2 100644 --- a/src/OCE/OBS/obs_conv.F90 +++ b/src/OCE/OBS/obs_conv.F90 @@ -18,7 +18,7 @@ MODULE obs_conv !! (approximate version) !!--------------------------------------------------------------------- !! * Modules used - USE par_kind ! Precision variables + USE par_kind IMPLICIT NONE !! * Function accessibility @@ -42,4 +42,4 @@ CONTAINS #include "obs_conv_functions.h90" -END MODULE obs_conv +END MODULE obs_conv \ No newline at end of file diff --git a/src/OCE/OBS/obs_conv_functions.h90 b/src/OCE/OBS/obs_conv_functions.h90 index 943c4dae2f81641432b44c0e5c1da90213326055..8fc5ee99c9d5e21528edb2464c8e77316d186e21 100644 --- a/src/OCE/OBS/obs_conv_functions.h90 +++ b/src/OCE/OBS/obs_conv_functions.h90 @@ -4,7 +4,7 @@ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- - REAL(KIND=dp) FUNCTION potemp( ps, pt, pp, ppr ) + REAL(KIND=wp) FUNCTION potemp( ps, pt, pp, ppr ) !!---------------------------------------------------------------------- !! *** FUNCTION potemp *** !! @@ -31,11 +31,11 @@ REAL(KIND=wp), INTENT(IN) :: ps REAL(KIND=wp), INTENT(IN) :: pt - REAL(KIND=dp), INTENT(IN) :: pp + REAL(KIND=wp), INTENT(IN) :: pp REAL(KIND=wp), INTENT(IN) :: ppr !! * Local declarations - REAL(KIND=dp) :: zpol + REAL(KIND=wp) :: zpol REAL(KIND=wp), PARAMETER :: a1 = 1.067610e-05 REAL(KIND=wp), PARAMETER :: a2 = -1.434297e-06 REAL(KIND=wp), PARAMETER :: a3 = -7.566349e-09 @@ -51,7 +51,7 @@ END FUNCTION potemp - REAL(KIND=dp) FUNCTION fspott( pft, pfs, pfp ) + REAL(KIND=wp) FUNCTION fspott( pft, pfs, pfp ) !!---------------------------------------------------------------------- !! *** FUNCTION fspott *** !! @@ -70,9 +70,9 @@ !!---------------------------------------------------------------------- !! * Arguments - REAL(KIND=dp) :: pft ! in situ temperature in degrees Celsius - REAL(KIND=dp) :: pfs ! salinity in psu - REAL(KIND=dp) :: pfp ! pressure in bars + REAL(KIND=wp) :: pft ! in situ temperature in degrees Celsius + REAL(KIND=wp) :: pfs ! salinity in psu + REAL(KIND=wp) :: pfp ! pressure in bars fspott = & & pft - pfp * ( ( 3.6504e-4 & @@ -90,7 +90,7 @@ END FUNCTION fspott - REAL(KIND=dp) FUNCTION atg( p_s, p_t, p_p ) + REAL(KIND=wp) FUNCTION atg( p_s, p_t, p_p ) !!---------------------------------------------------------------------- !! *** FUNCTION atg *** !! @@ -114,12 +114,12 @@ !! * Arguments REAL(KIND=wp), INTENT(IN) :: p_s ! Salinity in PSU - REAL(KIND=dp), INTENT(IN) :: p_t ! Temperature in centigrades - REAL(KIND=dp), INTENT(IN) :: p_p ! Pressure in decibars. + REAL(KIND=wp), INTENT(IN) :: p_t ! Temperature in centigrades + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars. !! * Local declarations - REAL(KIND=dp) :: z_ds + REAL(KIND=wp) :: z_ds z_ds = p_s - 35.0 atg = ((( -2.1687e-16 * p_t + 1.8676e-14 ) * p_t - 4.6206e-13 ) * p_p & @@ -130,7 +130,7 @@ END FUNCTION atg - REAL(KIND=dp) FUNCTION theta( p_s, p_t0, p_p0, p_pr ) + REAL(KIND=wp) FUNCTION theta( p_s, p_t0, p_p0, p_pr ) !!---------------------------------------------------------------------- !! *** FUNCTION theta *** !! @@ -158,11 +158,11 @@ REAL(KIND=wp), INTENT(IN) :: p_pr !! * Local declarations - REAL(KIND=dp) :: z_p - REAL(KIND=dp) :: z_t - REAL(KIND=dp) :: z_h - REAL(KIND=dp) :: z_xk - REAL(KIND=dp) :: z_q + REAL(KIND=wp) :: z_p + REAL(KIND=wp) :: z_t + REAL(KIND=wp) :: z_h + REAL(KIND=wp) :: z_xk + REAL(KIND=wp) :: z_q z_p = p_p0 z_t = p_t0 @@ -183,7 +183,7 @@ END FUNCTION theta - REAL(KIND=dp) FUNCTION depth( p_p, p_lat ) + REAL(KIND=wp) FUNCTION depth( p_p, p_lat ) !!---------------------------------------------------------------------- !! *** FUNCTION depth *** !! @@ -209,8 +209,8 @@ REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees !! * Local declarations - REAL(KIND=dp) :: z_x - REAL(KIND=dp) :: z_gr + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_gr z_x = SIN( p_lat / 57.29578 ) z_x = z_x * z_x @@ -220,7 +220,7 @@ END FUNCTION depth - REAL(KIND=dp) FUNCTION p_to_dep( p_p, p_lat ) + REAL(KIND=wp) FUNCTION p_to_dep( p_p, p_lat ) !!---------------------------------------------------------------------- !! *** FUNCTION p_to_dep *** !! @@ -244,9 +244,9 @@ REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees !! * Local declarations - REAL(KIND=dp) :: z_x - REAL(KIND=dp) :: z_c1 - REAL(KIND=dp) :: z_c2 + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_c1 + REAL(KIND=wp) :: z_c2 z_x = SIN( p_lat / 57.29578 ) z_x = z_x * z_x @@ -256,7 +256,7 @@ END FUNCTION p_to_dep - REAL(KIND=dp) FUNCTION dep_to_p( p_dep, p_lat ) + REAL(KIND=wp) FUNCTION dep_to_p( p_dep, p_lat ) !!---------------------------------------------------------------------- !! *** FUNCTION dep_to_p *** !! @@ -279,10 +279,10 @@ REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees !! * Local declarations - REAL(KIND=dp) :: z_x - REAL(KIND=dp) :: z_c1 - REAL(KIND=dp) :: z_c2 - REAL(KIND=dp) :: z_d + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_c1 + REAL(KIND=wp) :: z_c2 + REAL(KIND=wp) :: z_d z_x = SIN( p_lat / 57.29578 ) z_x = z_x * z_x diff --git a/src/OCE/OBS/obs_grd_bruteforce.h90 b/src/OCE/OBS/obs_grd_bruteforce.h90 index 33a2d009a808eef3dfd3f73058f88662f0529a50..e15bbbe419ebba5164f98d06e711c0e76cfcf469 100644 --- a/src/OCE/OBS/obs_grd_bruteforce.h90 +++ b/src/OCE/OBS/obs_grd_bruteforce.h90 @@ -33,27 +33,24 @@ SUBROUTINE obs_grd_bruteforce( kpi, kpj, kpiglo, kpjglo, & INTEGER, INTENT(IN) :: klej ! End of inner domain in j INTEGER, INTENT(IN) :: kmyproc ! Processor number for MPP INTEGER, INTENT(IN) :: ktotproc ! Total number of processors - REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) :: pmask - REAL(KIND=dp), DIMENSION(kpi,kpj), INTENT(IN) :: pglam, pgphi - - - + REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) :: & + & pglam, & ! Grid point longitude + & pgphi, & ! Grid point latitude + & pmask ! Grid point mask INTEGER,INTENT(IN) :: kobs ! Size of the observation arrays - REAL(KIND=dp), DIMENSION(kobs), INTENT(IN) :: plam, pphi - - - + REAL(KIND=wp), DIMENSION(kobs), INTENT(IN) :: & + & plam, & ! Longitude of obsrvations + & pphi ! Latitude of observations INTEGER, DIMENSION(kobs), INTENT(OUT) :: & & kobsi, & ! I-index of observations & kobsj, & ! J-index of observations & kproc ! Processor number of observations !! * Local declarations - REAL(dp), DIMENSION(:), ALLOCATABLE :: zplam, zpphi - - - REAL(dp) :: zlammax - REAL(dp) :: zlam + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zplam, zpphi + REAL(wp) :: zlammax + REAL(wp) :: zlam INTEGER :: ji INTEGER :: jj INTEGER :: jk @@ -62,21 +59,19 @@ SUBROUTINE obs_grd_bruteforce( kpi, kpj, kpiglo, kpjglo, & INTEGER :: jlat INTEGER :: joffset INTEGER :: jostride - REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: zlamg, zphig, zmskg - REAL(KIND=dp), DIMENSION(:,:), ALLOCATABLE :: zphitmax, zphitmin, zlamtmax, zlamtmin - - - - - - - + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax,& + & zphitmin,& + & zlamtmax,& + & zlamtmin LOGICAL, DIMENSION(:,:), ALLOCATABLE :: & & llinvalidcell - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zlamtm, zphitm - - - + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zlamtm, & + & zphitm !----------------------------------------------------------------------- ! Define grid setup for grid search diff --git a/src/OCE/OBS/obs_grid.F90 b/src/OCE/OBS/obs_grid.F90 index f8905614059d6dad169b6d9c42de69e1801e6678..993448b866d768994a43534cc7ca7dbba05aba5e 100644 --- a/src/OCE/OBS/obs_grid.F90 +++ b/src/OCE/OBS/obs_grid.F90 @@ -51,13 +51,13 @@ MODULE obs_grid !!* Module variables !! Default values - REAL(dp), PUBLIC :: rn_gridsearchres = 0.5 ! Resolution of grid + REAL(wp), PUBLIC :: rn_gridsearchres = 0.5 ! Resolution of grid INTEGER, PRIVATE :: gsearch_nlons_def ! Num of longitudes INTEGER, PRIVATE :: gsearch_nlats_def ! Num of latitudes - REAL(dp), PRIVATE :: gsearch_lonmin_def ! Min longitude - REAL(dp), PRIVATE :: gsearch_latmin_def ! Min latitude - REAL(dp), PRIVATE :: gsearch_dlon_def ! Lon spacing - REAL(dp), PRIVATE :: gsearch_dlat_def ! Lat spacing + REAL(wp), PRIVATE :: gsearch_lonmin_def ! Min longitude + REAL(wp), PRIVATE :: gsearch_latmin_def ! Min latitude + REAL(wp), PRIVATE :: gsearch_dlon_def ! Lon spacing + REAL(wp), PRIVATE :: gsearch_dlat_def ! Lat spacing !! Variable versions INTEGER, PRIVATE :: nlons ! Num of longitudes INTEGER, PRIVATE :: nlats ! Num of latitudes @@ -110,10 +110,9 @@ CONTAINS !! * Arguments INTEGER :: & & kobsin ! Size of the observation arrays - REAL(KIND=dp), DIMENSION(kobsin), INTENT(IN) :: plam, pphi - - - + REAL(KIND=wp), DIMENSION(kobsin), INTENT(IN) :: & + & plam, & ! Longitude of obsrvations + & pphi ! Latitude of observations INTEGER, DIMENSION(kobsin), INTENT(OUT) :: & & kobsi, & ! I-index of observations & kobsj, & ! J-index of observations @@ -186,21 +185,19 @@ CONTAINS !! * Arguments INTEGER :: kobs ! Size of the observation arrays - REAL(KIND=dp), DIMENSION(kobs), INTENT(IN) :: plam, pphi - - - + REAL(KIND=wp), DIMENSION(kobs), INTENT(IN) :: & + & plam, & ! Longitude of obsrvations + & pphi ! Latitude of observations INTEGER, DIMENSION(kobs), INTENT(OUT) :: & & kobsi, & ! I-index of observations & kobsj, & ! J-index of observations & kproc ! Processor number of observations !! * Local declarations - REAL(KIND=dp), DIMENSION(:), ALLOCATABLE :: zplam - - - REAL(dp) :: zlammax - REAL(dp) :: zlam + REAL(KIND=wp), DIMENSION(:), ALLOCATABLE :: & + & zplam + REAL(wp) :: zlammax + REAL(wp) :: zlam INTEGER :: ji INTEGER :: jj INTEGER :: jk @@ -226,21 +223,19 @@ CONTAINS INTEGER :: jlat INTEGER :: joffset INTEGER :: jostride - REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: zlamg, zphig, zmskg - REAL(KIND=dp), DIMENSION(:,:), ALLOCATABLE :: zphitmax, zphitmin, zlamtmax, zlamtmin - - - - - - - + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax,& + & zphitmin,& + & zlamtmax,& + & zlamtmin LOGICAL, DIMENSION(:,:), ALLOCATABLE :: & & llinvalidcell - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zlamtm, zphitm - - - + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zlamtm, & + & zphitm LOGICAL :: llfourflag INTEGER :: ifourflagcountt INTEGER :: ifourflagcountf @@ -669,16 +664,15 @@ CONTAINS INTEGER :: idlat, idlon, fileexist INTEGER, DIMENSION(2) :: incdim CHARACTER(LEN=20) :: datestr=" ",timestr=" " - REAL(dp) :: tmpx1, tmpx2, tmpy1, tmpy2 - REAL(dp) :: meanxdiff, meanydiff - REAL(dp) :: meanxdiff1, meanydiff1 - REAL(dp) :: meanxdiff2, meanydiff2 + REAL(wp) :: tmpx1, tmpx2, tmpy1, tmpy2 + REAL(wp) :: meanxdiff, meanydiff + REAL(wp) :: meanxdiff1, meanydiff1 + REAL(wp) :: meanxdiff2, meanydiff2 INTEGER :: numx1, numx2, numy1, numy2, df INTEGER :: jimin, jimax, jjmin, jjmax - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: lonsi, latsi - - - + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: & + & lonsi, & + & latsi INTEGER, DIMENSION(:,:), ALLOCATABLE :: & & ixposi, & & iyposi, & @@ -686,10 +680,9 @@ CONTAINS INTEGER, PARAMETER :: histsize=90 INTEGER, DIMENSION(histsize) :: & & histx1, histx2, histy1, histy2 - REAL(dp), DIMENSION(histsize) :: fhistx1, fhistx2, fhisty1, fhisty2 - - - REAL(dp) :: histtol + REAL(wp), DIMENSION(histsize) :: & + & fhistx1, fhistx2, fhisty1, fhisty2 + REAL(wp) :: histtol CHARACTER(LEN=26) :: clfmt ! writing format INTEGER :: idg ! number of digits @@ -719,7 +712,7 @@ CONTAINS IF ( ln_grid_global ) THEN WRITE(cfname, FMT="(A,'_',A)") TRIM(cn_gridsearchfile), 'global.nc' ELSE - idg = MAX( INT(LOG10(REAL(jpnij,dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 ! define the following format: "(a,a,ix.x,a,ix.x,a,ix.x,a)" WRITE(clfmt, "('(a,a,i', i1, '.', i1',a,i', i1, '.', i1',a,i', i1, '.', i1',a)')") idg, idg, idg, idg, idg, idg WRITE(cfname, clfmt ) TRIM(cn_gridsearchfile),'_', narea-1,'of', jpni,'by', jpnj,'.nc' diff --git a/src/OCE/OBS/obs_inter_sup.F90 b/src/OCE/OBS/obs_inter_sup.F90 index 64d4937bf93f4c34b570b3750540435a7318a807..128ae93ca066f3fedd1d721b1746c7b626dade31 100644 --- a/src/OCE/OBS/obs_inter_sup.F90 +++ b/src/OCE/OBS/obs_inter_sup.F90 @@ -21,10 +21,6 @@ MODULE obs_inter_sup !! * Routine accessibility PRIVATE - - INTERFACE obs_int_comm_2d - MODULE PROCEDURE obs_int_comm_2d_dp, obs_int_comm_2d_sp - END INTERFACE PUBLIC obs_int_comm_3d, & ! Get 3D interpolation stencil & obs_int_comm_2d ! Get 2D interpolation stencil @@ -67,12 +63,10 @@ CONTAINS & kgrdj INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & & kproc ! Precomputed processor for each i,j,iobs points - REAL(KIND=dp), DIMENSION(kpi,kpj,kpk), INTENT(IN) :: pval - - - REAL(KIND=dp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) :: pgval - - + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& + & pval ! Local 3D array to extract data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point !! * Local declarations IF (ln_grid_global) THEN @@ -98,7 +92,7 @@ CONTAINS END SUBROUTINE obs_int_comm_3d - SUBROUTINE obs_int_comm_2d_dp( kptsi, kptsj, kobs, kpi, kpj, kgrdi, kgrdj, pval, pgval, & + SUBROUTINE obs_int_comm_2d( kptsi, kptsj, kobs, kpi, kpj, kgrdi, kgrdj, pval, pgval, & & kproc ) !!---------------------------------------------------------------------- !! *** ROUTINE obs_int_comm_2d *** @@ -124,17 +118,14 @@ CONTAINS & kgrdj INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & & kproc ! Precomputed processor for each i,j,iobs points - REAL(KIND=dp), DIMENSION(kpi,kpj), INTENT(IN) :: pval - - - REAL(KIND=dp), DIMENSION(kptsi,kptsj,kobs), INTENT(OUT) :: pgval - - + REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) ::& + & pval ! Local 3D array to extra data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point !! * Local declarations - REAL(KIND=dp), DIMENSION(jpi,jpj,1) :: zval - REAL(KIND=dp), DIMENSION(kptsi,kptsj,1,kobs) :: zgval - - + REAL(KIND=wp), DIMENSION(jpi,jpj,1) :: zval + REAL(KIND=wp), DIMENSION(kptsi,kptsj,1,kobs) ::& + & zgval ! Set up local "3D" buffer @@ -157,69 +148,7 @@ CONTAINS pgval(:,:,:) = zgval(:,:,1,:) - END SUBROUTINE obs_int_comm_2d_dp - - SUBROUTINE obs_int_comm_2d_sp( kptsi, kptsj, kobs, kpi, kpj, kgrdi, kgrdj, pval, pgval, & - & kproc ) - !!---------------------------------------------------------------------- - !! *** ROUTINE obs_int_comm_2d *** - !! - !! ** Purpose : Get 2D interpolation stencil - !! - !! ** Method : Call to obs_int_comm_3d - !! - !! ** Action : - !! - !! History : - !! ! 08-02 (K. Mogensen) Original code - !!---------------------------------------------------------------------- - !! - !! * Arguments - INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil - INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil - INTEGER, INTENT(IN) :: kobs ! Local number of observations - INTEGER, INTENT(IN) :: kpi ! Number of model grid points in i direction - INTEGER, INTENT(IN) :: kpj ! Number of model grid points in j direction - INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & - & kgrdi, & ! i,j indicies for each stencil - & kgrdj - INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & - & kproc ! Precomputed processor for each i,j,iobs points - REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) :: pval - - - REAL(KIND=dp), DIMENSION(kptsi,kptsj,kobs), INTENT(OUT) :: pgval - - - !! * Local declarations - REAL(KIND=dp), DIMENSION(jpi,jpj,1) :: zval - REAL(KIND=dp), DIMENSION(kptsi,kptsj,1,kobs) :: zgval - - - - ! Set up local "3D" buffer - - zval(:,:,1) = pval(:,:) - - ! Call the 3D version - - IF (PRESENT(kproc)) THEN - - CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & - & zgval, kproc=kproc ) - ELSE - - CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & - & zgval ) - - ENDIF - - ! Copy "3D" data back to 2D - - pgval(:,:,:) = zgval(:,:,1,:) - - END SUBROUTINE obs_int_comm_2d_sp - + END SUBROUTINE obs_int_comm_2d SUBROUTINE obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & & pval, pgval, kproc ) @@ -249,17 +178,14 @@ CONTAINS & kgrdj INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & & kproc ! Precomputed processor for each i,j,iobs points - REAL(KIND=dp), DIMENSION(kpi,kpj,kpk), INTENT(IN) :: pval - - - REAL(KIND=dp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) :: pgval - - + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& + & pval ! Local 3D array to extract data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point !! * Local declarations - REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: zrecv - REAL(KIND=dp), DIMENSION(:,:), ALLOCATABLE :: zsend - - + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & + & zsend, & + & zrecv INTEGER, DIMENSION(:), ALLOCATABLE :: & & igrdij_send, & & igrdij_recv @@ -421,12 +347,10 @@ CONTAINS INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & & kgrdi, & ! i,j indicies for each stencil & kgrdj - REAL(KIND=dp), DIMENSION(kpi,kpj,kpk), INTENT(IN) :: pval - - - REAL(KIND=dp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) :: pgval - - + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& + & pval ! Local 3D array to extract data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point !! * Local declarations INTEGER :: ji INTEGER :: jj @@ -458,4 +382,4 @@ CONTAINS END SUBROUTINE obs_int_comm_3d_local -END MODULE obs_inter_sup +END MODULE obs_inter_sup \ No newline at end of file diff --git a/src/OCE/OBS/obs_inter_z1d.F90 b/src/OCE/OBS/obs_inter_z1d.F90 index 81aaf4cac8f7bd821884adfc016bc2d643d5bd09..a3f64859e7ff3a94fa3c5dc6e1f87f711dbf3c09 100644 --- a/src/OCE/OBS/obs_inter_z1d.F90 +++ b/src/OCE/OBS/obs_inter_z1d.F90 @@ -11,8 +11,7 @@ MODULE obs_inter_z1d !! interpolating function for a cubic spline (n1dint=1) !!---------------------------------------------------------------------- !! * Modules used - USE par_kind ! Precision variables - + USE par_kind IMPLICIT NONE @@ -33,4 +32,4 @@ CONTAINS #include "obsinter_z1d.h90" -END MODULE obs_inter_z1d +END MODULE obs_inter_z1d \ No newline at end of file diff --git a/src/OCE/OBS/obs_level_search.h90 b/src/OCE/OBS/obs_level_search.h90 index 51ebc9ac7f7c4a08728f2eed71c2a6563c02923a..b79c1a482e05148f4bab311b5d194062005b76f1 100644 --- a/src/OCE/OBS/obs_level_search.h90 +++ b/src/OCE/OBS/obs_level_search.h90 @@ -24,14 +24,12 @@ !! * Arguments INTEGER, INTENT(IN) :: kgrd ! Number of gridpoints - REAL(KIND=dp), DIMENSION(kgrd), INTENT(INOUT) :: pgrddep - - + REAL(KIND=wp), DIMENSION(kgrd), INTENT(INOUT) :: & + & pgrddep ! Depths of gridpoints INTEGER, INTENT(IN) :: & & kobs ! Number of observations - REAL(KIND=dp), DIMENSION(kobs), INTENT(INOUT) :: pobsdep - - + REAL(KIND=wp), DIMENSION(kobs), INTENT(INOUT) :: & + & pobsdep ! Depths of observations INTEGER ,DIMENSION(kobs), INTENT(OUT) :: & & kobsk ! Level indices of observations diff --git a/src/OCE/OBS/obs_mpp.F90 b/src/OCE/OBS/obs_mpp.F90 index ab3d8faffc7691f170824fd74ad43f5390206229..dda28e1104a554ae3324d0a4aba3597ff61c98fd 100644 --- a/src/OCE/OBS/obs_mpp.F90 +++ b/src/OCE/OBS/obs_mpp.F90 @@ -404,7 +404,7 @@ INCLUDE 'mpif.h' INTEGER , INTENT(in ) :: knoin INTEGER , INTENT(in ) :: knoout INTEGER , DIMENSION(jpnij) :: kinv, koutv - REAL(dp), DIMENSION(knoin) , INTENT(in ) :: pvalsin + REAL(wp), DIMENSION(knoin) , INTENT(in ) :: pvalsin REAL(wp), DIMENSION(knoout), INTENT( out) :: pvalsout !! INTEGER :: ierr diff --git a/src/OCE/OBS/obs_oper.F90 b/src/OCE/OBS/obs_oper.F90 index 08549cb1bf5248f28edbb148d092f46fd064a721..aeb0ae121c2fb221d322533ded6b9e26978989fe 100644 --- a/src/OCE/OBS/obs_oper.F90 +++ b/src/OCE/OBS/obs_oper.F90 @@ -31,7 +31,6 @@ MODULE obs_oper INTEGER, PARAMETER, PUBLIC :: imaxavtypes = 20 !: Max number of daily avgd obs types !! * Substitutions -# include "single_precision_substitute.h90" # include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -106,11 +105,11 @@ CONTAINS INTEGER , INTENT(in ) :: k2dint ! Horizontal interpolation type (see header) INTEGER , INTENT(in ) :: kdaystp ! Number of time steps per day INTEGER , INTENT(in ) :: kvar ! Number of variables in prodatqc - REAL(KIND=dp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar ! Model field - REAL(KIND=dp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask ! Land-sea mask - REAL(KIND=dp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam ! Model longitude - REAL(KIND=dp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi ! Model latitudes - REAL(KIND=dp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pgdept, pgdepw ! depth of T and W levels + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar ! Model field + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask ! Land-sea mask + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam ! Model longitude + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi ! Model latitudes + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pgdept, pgdepw ! depth of T and W levels INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: kdailyavtypes ! Types for daily averages !! * Local declarations @@ -133,30 +132,26 @@ CONTAINS & igrdj INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic - REAL(KIND=dp) :: zlam - REAL(KIND=dp) :: zphi - REAL(KIND=dp) :: zdaystp - REAL(KIND=dp), DIMENSION(kpk) :: zobsk, zobs2k - - - - REAL(KIND=dp), DIMENSION(2,2,1) :: zweig1, zweig - - - - REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: zmask, zint, zinm, zgdept, zgdepw - - - - - - - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zglam, zgphi - - - - REAL(KIND=dp), DIMENSION(1) :: zmsk - REAL(KIND=dp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner + REAL(KIND=wp) :: zlam + REAL(KIND=wp) :: zphi + REAL(KIND=wp) :: zdaystp + REAL(KIND=wp), DIMENSION(kpk) :: & + & zobsk, & + & zobs2k + REAL(KIND=wp), DIMENSION(2,2,1) :: & + & zweig1, & + & zweig + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & + & zmask, & + & zint, & + & zinm, & + & zgdept, & + & zgdepw + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zglam, & + & zgphi + REAL(KIND=wp), DIMENSION(1) :: zmsk + REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner LOGICAL :: ld_dailyav @@ -250,7 +245,7 @@ CONTAINS ALLOCATE( zinm(2,2,kpk,ipro) ) CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, & - & CASTDP(prodatqc%vdmean(:,:,:,kvar)), zinm ) + & prodatqc%vdmean(:,:,:,kvar), zinm ) ENDIF @@ -494,15 +489,13 @@ CONTAINS ! (kit000-1 = restart time) INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) - REAL(dp), INTENT(IN), DIMENSION(kpi,kpj) :: psurf, psurfmask - - - + REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & + & psurf, & ! Model surface field + & psurfmask ! Land-sea mask LOGICAL, INTENT(IN) :: ldnightav ! Logical for averaging night-time data - REAL(KIND=dp), INTENT(IN) :: plamscl, pphiscl - - - + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & ! Diameter in metres of obs footprint in E/W, N/S directions + & pphiscl ! This is the full width (rather than half-width) LOGICAL, INTENT(IN) :: & & lindegrees ! T=> plamscl and pphiscl are specified in degrees, F=> in metres @@ -524,27 +517,25 @@ CONTAINS INTEGER, DIMENSION(:,:), SAVE, ALLOCATABLE :: & & icount_night, & & imask_night - REAL(dp) :: zlam - REAL(dp) :: zphi - REAL(dp), DIMENSION(1) :: zext, zobsmask - REAL(dp) :: zdaystp - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zweig, zmask, zsurf, zsurfm, zsurftmp, zglam, zgphi, zglamf, zgphif - - - - - - - - - - - - REAL(dp), DIMENSION(:,:), SAVE, ALLOCATABLE :: zintmp, zouttmp, zmeanday - - - + REAL(wp) :: zlam + REAL(wp) :: zphi + REAL(wp), DIMENSION(1) :: zext, zobsmask + REAL(wp) :: zdaystp + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zweig, & + & zmask, & + & zsurf, & + & zsurfm, & + & zsurftmp, & + & zglam, & + & zgphi, & + & zglamf, & + & zgphif + REAL(wp), DIMENSION(:,:), SAVE, ALLOCATABLE :: & + & zintmp, & + & zouttmp, & + & zmeanday ! to compute model sst in region of 24h daylight (pole) !------------------------------------------------------------------------ ! Local initialization diff --git a/src/OCE/OBS/obs_prep.F90 b/src/OCE/OBS/obs_prep.F90 index 36ea7f5272faaa74140baabae48f50a899487bb9..ee2f9a91754183067eb43261fd34e8e96d0c2c24 100644 --- a/src/OCE/OBS/obs_prep.F90 +++ b/src/OCE/OBS/obs_prep.F90 @@ -32,7 +32,6 @@ MODULE obs_prep PUBLIC obs_pre_surf ! First level check and screening of surface obs PUBLIC calc_month_len ! Calculate the number of days in the months of a year -# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -277,13 +276,11 @@ CONTAINS INTEGER, INTENT(IN) :: Kmm ! time-level index INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & & kdailyavtypes ! Types for daily averages - REAL(dp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: zmask - - - REAL(dp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: pglam, pgphi - - - + REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & + & zmask + REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & + & pglam, & + & pgphi INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value !! * Local declarations @@ -609,9 +606,9 @@ CONTAINS INTEGER :: idayend INTEGER :: iskip INTEGER :: idaystp - REAL(KIND=dp) :: zminstp - REAL(KIND=dp) :: zhoustp - REAL(KIND=dp) :: zobsstp + REAL(KIND=wp) :: zminstp + REAL(KIND=wp) :: zhoustp + REAL(KIND=wp) :: zobsstp INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year !----------------------------------------------------------------------- @@ -888,7 +885,7 @@ CONTAINS INTEGER , INTENT(in ) :: kpi , kpj ! Number of grid points in (i,j) INTEGER , INTENT(in ), DIMENSION(kobsno) :: kobsi , kobsj ! Observation (i,j) coordinates REAL(wp), INTENT(in ), DIMENSION(kobsno) :: pobslam, pobsphi ! Observation (lon,lat) coordinates - REAL(dp), INTENT(in ), DIMENSION(kpi,kpj) :: plam , pphi ! Model (lon,lat) coordinates + REAL(wp), INTENT(in ), DIMENSION(kpi,kpj) :: plam , pphi ! Model (lon,lat) coordinates REAL(wp), INTENT(in ), DIMENSION(kpi,kpj) :: pmask ! Land mask array INTEGER , INTENT(inout), DIMENSION(kobsno) :: kobsqc ! Observation quality control INTEGER , INTENT(inout) :: kosdobs ! Observations outside space domain @@ -899,10 +896,10 @@ CONTAINS LOGICAL , INTENT(in ) :: ld_bound_reject ! Flag observations near open boundary INTEGER , INTENT(in ) :: kqc_cutoff ! Cutoff QC value ! - REAL(KIND=dp), DIMENSION(2,2,kobsno) :: zgmsk ! Grid mask - REAL(KIND=dp), DIMENSION(2,2,kobsno) :: zbmsk ! Boundary mask - REAL(KIND=dp), DIMENSION(jpi,jpj) :: zbdymask - REAL(KIND=dp), DIMENSION(2,2,kobsno) :: zglam, zgphi ! Model Lon/lat at grid points + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zgmsk ! Grid mask + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zbmsk ! Boundary mask + REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zglam, zgphi ! Model Lon/lat at grid points INTEGER , DIMENSION(2,2,kobsno) :: igrdi, igrdj ! Grid i,j LOGICAL :: lgridobs ! Is observation on a model grid point. INTEGER :: iig, ijg ! i,j of observation on model grid point. @@ -1090,22 +1087,17 @@ CONTAINS & kobsj INTEGER, DIMENSION(kobsno), INTENT(IN) :: & & kobsk ! Observation k coordinate - REAL(KIND=dp), DIMENSION(kprofno), INTENT(IN) :: pobslam, pobsphi - - - - REAL(KIND=dp), DIMENSION(kobsno), INTENT(INOUT) :: pobsdep - - - REAL(KIND=dp), DIMENSION(kpi,kpj), INTENT(IN) :: plam, pphi - - - REAL(KIND=dp), DIMENSION(kpk), INTENT(IN) :: pdep - - - REAL(KIND=dp), DIMENSION(kpi,kpj,kpk), INTENT(IN) :: pmask - - + REAL(KIND=wp), DIMENSION(kprofno), INTENT(IN) :: & + & pobslam, & ! Observation (lon,lat) coordinates + & pobsphi + REAL(KIND=wp), DIMENSION(kobsno), INTENT(INOUT) :: & + & pobsdep ! Observation depths + REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) :: & + & plam, pphi ! Model (lon,lat) coordinates + REAL(KIND=wp), DIMENSION(kpk), INTENT(IN) :: & + & pdep ! Model depth coordinates + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) :: & + & pmask ! Land mask array INTEGER, DIMENSION(kprofno), INTENT(INOUT) :: & & kpobsqc ! Profile quality control INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & @@ -1120,21 +1112,17 @@ CONTAINS INTEGER, INTENT(IN) :: Kmm ! time-level index !! * Local declarations - REAL(KIND=dp), DIMENSION(2,2,kpk,kprofno) :: zgmsk - - - REAL(KIND=dp), DIMENSION(2,2,kprofno) :: zbmsk - - - REAL(KIND=dp), DIMENSION(jpi,jpj) :: zbdymask - REAL(KIND=dp), DIMENSION(2,2,kpk,kprofno) :: zgdepw - - - REAL(KIND=dp), DIMENSION(2,2,kprofno) :: zglam, zgphi - - - - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zdepw + REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & + & zgmsk ! Grid mask + REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & + & zbmsk ! Boundary mask + REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask + REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & + & zgdepw + REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & + & zglam, & ! Model longitude at grid points + & zgphi ! Model latitude at grid points + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepw INTEGER, DIMENSION(2,2,kprofno) :: & & igrdi, & ! Grid i,j & igrdj @@ -1190,7 +1178,7 @@ CONTAINS CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) ENDIF - CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, CASTDP(pmask), zgmsk ) + CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, pmask, zgmsk ) CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, plam, zglam ) CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) DO jk = 1, jpk diff --git a/src/OCE/OBS/obs_profiles_def.F90 b/src/OCE/OBS/obs_profiles_def.F90 index 9c3109f3a6643e76ab80e172899c6ffd4c98fc18..24532a7cdc405b92c9786d8961bafa7b8eb71a07 100644 --- a/src/OCE/OBS/obs_profiles_def.F90 +++ b/src/OCE/OBS/obs_profiles_def.F90 @@ -68,11 +68,10 @@ MODULE obs_profiles_def & nvqc, & !: Variable QC flags & idqc !: Depth QC flag - REAL(KIND=wp), POINTER, DIMENSION(:) :: vobs - REAL(KIND=dp), POINTER, DIMENSION(:) :: vdep, vmod - - - + REAL(KIND=wp), POINTER, DIMENSION(:) :: & + & vdep, & !: Depth coordinate of profile data + & vobs, & !: Profile data + & vmod !: Model counterpart of the profile data vector REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & & vext !: Extra variables @@ -127,10 +126,9 @@ MODULE obs_profiles_def & ipqc, & !: Position QC & itqc !: Time QC - REAL(KIND=dp), POINTER, DIMENSION(:) :: rlam, rphi - - - + REAL(KIND=wp), POINTER, DIMENSION(:) :: & + & rlam, & !: Longitude coordinate of profile data + & rphi !: Latitude coordinate of profile data CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & & cwmo !: Profile WMO indentifier diff --git a/src/OCE/OBS/obs_read_altbias.F90 b/src/OCE/OBS/obs_read_altbias.F90 index 8951cd96eb619383eebe8c3ff24afd940591f085..07196c27086e744875b74f5c2634de142690b68c 100644 --- a/src/OCE/OBS/obs_read_altbias.F90 +++ b/src/OCE/OBS/obs_read_altbias.F90 @@ -86,22 +86,19 @@ CONTAINS INTEGER :: i_file_id ! INTEGER :: i_var_id - REAL(dp), DIMENSION(1) :: zext, zobsmask - - - - REAL(dp), DIMENSION(2,2,1) :: zweig - - - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zmask, zbias, zglam, zgphi - - - - - - REAL(dp), DIMENSION(jpi,jpj) :: z_altbias - REAL(dp) :: zlam - REAL(dp) :: zphi + REAL(wp), DIMENSION(1) :: & + & zext, & + & zobsmask + REAL(wp), DIMENSION(2,2,1) :: & + & zweig + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmask, & + & zbias, & + & zglam, & + & zgphi + REAL(wp), DIMENSION(jpi,jpj) :: z_altbias + REAL(wp) :: zlam + REAL(wp) :: zphi INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & & igrdi, & & igrdj diff --git a/src/OCE/OBS/obs_read_prof.F90 b/src/OCE/OBS/obs_read_prof.F90 index 5f2a2597c032339c948a1aefc1d77e22d802f9b1..22fefe13fd6358e2f71f16fa2629bfdc30b01647 100644 --- a/src/OCE/OBS/obs_read_prof.F90 +++ b/src/OCE/OBS/obs_read_prof.F90 @@ -77,8 +77,8 @@ CONTAINS LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files LOGICAL, INTENT(IN) :: ldsatt ! Compute salinity at all temperature points LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data - REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS - REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS + REAL(wp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS + REAL(wp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & & kdailyavtypes ! Types of daily average observations @@ -129,10 +129,9 @@ CONTAINS & idailyavtypes INTEGER, DIMENSION(kvars) :: & & iv3dt - REAL(dp), DIMENSION(:), ALLOCATABLE :: zphi, zlam - - - + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zphi, & + & zlam REAL(dp), DIMENSION(:), ALLOCATABLE :: & & zdat REAL(dp), DIMENSION(knumfiles) :: & diff --git a/src/OCE/OBS/obs_read_surf.F90 b/src/OCE/OBS/obs_read_surf.F90 index 552aaf1df3fbea8559ff72df9534e56e76213762..82b4992cae7d076ac2e534c78f3ba6dde48396ac 100644 --- a/src/OCE/OBS/obs_read_surf.F90 +++ b/src/OCE/OBS/obs_read_surf.F90 @@ -70,8 +70,8 @@ CONTAINS LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data LOGICAL, INTENT(IN) :: ldnightav ! Observations represent a night-time average - REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS - REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS + REAL(wp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS + REAL(wp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars !! * Local declarations @@ -109,10 +109,9 @@ CONTAINS & iindx, & & ifileidx, & & isurfidx - REAL(dp), DIMENSION(:), ALLOCATABLE :: zphi, zlam - - - + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zphi, & + & zlam REAL(dp), DIMENSION(:), ALLOCATABLE :: & & zdat REAL(dp), DIMENSION(knumfiles) :: & diff --git a/src/OCE/OBS/obs_readmdt.F90 b/src/OCE/OBS/obs_readmdt.F90 index 96c4a5f0ff728f1dabc8d2991136d1fd9f70f5cb..48343f74d111e83999d237cdeef2ed2d9d52f4dc 100644 --- a/src/OCE/OBS/obs_readmdt.F90 +++ b/src/OCE/OBS/obs_readmdt.F90 @@ -33,8 +33,8 @@ MODULE obs_readmdt PUBLIC obs_offset_mdt ! called by obs_rea_mdt INTEGER , PUBLIC :: nn_msshc = 1 ! MDT correction scheme - REAL(dp), PUBLIC :: rn_mdtcorr = 1.61_wp ! User specified MDT correction - REAL(dp), PUBLIC :: rn_mdtcutoff = 65.0_wp ! MDT cutoff for computed correction + REAL(wp), PUBLIC :: rn_mdtcorr = 1.61_wp ! User specified MDT correction + REAL(wp), PUBLIC :: rn_mdtcutoff = 65.0_wp ! MDT cutoff for computed correction !! * Substitutions # include "do_loop_substitute.h90" @@ -71,16 +71,15 @@ CONTAINS INTEGER :: i_nx_id, i_ny_id, i_file_id, i_var_id, i_stat INTEGER :: nummdt ! - REAL(dp), DIMENSION(1) :: zext, zobsmask - REAL(dp), DIMENSION(2,2,1) :: zweig + REAL(wp), DIMENSION(1) :: zext, zobsmask + REAL(wp), DIMENSION(2,2,1) :: zweig ! - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zmask, zmdtl, zglam, zgphi + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmask, zmdtl, zglam, zgphi INTEGER , DIMENSION(:,:,:), ALLOCATABLE :: igrdi, igrdj ! - REAL(dp), DIMENSION(jpi,jpj) :: z_mdt, mdtmask + REAL(wp), DIMENSION(jpi,jpj) :: z_mdt, mdtmask - REAL(wp) :: zinfill! local scalar - REAL(dp) :: zlam, zphi, zfill! local scalar + REAL(wp) :: zlam, zphi, zfill, zinfill ! local scalar !!---------------------------------------------------------------------- IF(lwp)WRITE(numout,*) @@ -187,12 +186,12 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(IN) :: kpi, kpj INTEGER, INTENT(IN) :: Kmm - REAL(dp), DIMENSION(kpi,kpj), INTENT(INOUT) :: mdt ! MDT used on the model grid - REAL(dp) , INTENT(IN ) :: zfill + REAL(wp), DIMENSION(kpi,kpj), INTENT(INOUT) :: mdt ! MDT used on the model grid + REAL(wp) , INTENT(IN ) :: zfill ! INTEGER :: ji, jj - REAL(dp) :: zdxdy, zarea, zeta1, zeta2, zcorr_mdt, zcorr_bcketa, zcorr ! local scalar - REAL(dp), DIMENSION(jpi,jpj) :: zpromsk + REAL(wp) :: zdxdy, zarea, zeta1, zeta2, zcorr_mdt, zcorr_bcketa, zcorr ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zpromsk CHARACTER(LEN=14), PARAMETER :: cpname = 'obs_offset_mdt' !!---------------------------------------------------------------------- diff --git a/src/OCE/OBS/obs_rot_vel.F90 b/src/OCE/OBS/obs_rot_vel.F90 index 0a24b342b9e84c844d2a731643abc5565b4af5b8..3d302f1be119cedfe2eefa78f06319b276b2aeb3 100644 --- a/src/OCE/OBS/obs_rot_vel.F90 +++ b/src/OCE/OBS/obs_rot_vel.F90 @@ -57,34 +57,31 @@ CONTAINS !! * Arguments TYPE(obs_prof), INTENT(INOUT) :: profdata ! Profile data to be read INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation methed - REAL(dp), DIMENSION(:) :: pu, pv - - - + REAL(wp), DIMENSION(:) :: & + & pu, & + & pv !! * Local declarations - REAL(dp), DIMENSION(2,2,1) :: zweig - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zmasku, zmaskv, zcoslu, zsinlu, zcoslv, zsinlv, zglamu, zgphiu, zglamv, zgphiv - - - - - - - - - - - - REAL(dp), DIMENSION(1) :: zsinu, zcosu, zsinv, zcosv - - - - - - REAL(dp) :: zsin - REAL(dp) :: zcos - REAL(dp), DIMENSION(1) :: zobsmask - REAL(dp), DIMENSION(jpi,jpj) :: zsingu,zcosgu,zsingv,zcosgv + REAL(wp), DIMENSION(2,2,1) :: zweig + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmasku, & + & zmaskv, & + & zcoslu, & + & zsinlu, & + & zcoslv, & + & zsinlv, & + & zglamu, & + & zgphiu, & + & zglamv, & + & zgphiv + REAL(wp), DIMENSION(1) :: & + & zsinu, & + & zcosu, & + & zsinv, & + & zcosv + REAL(wp) :: zsin + REAL(wp) :: zcos + REAL(wp), DIMENSION(1) :: zobsmask + REAL(wp), DIMENSION(jpi,jpj) :: zsingu,zcosgu,zsingv,zcosgv INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & & igrdiu, & & igrdju, & diff --git a/src/OCE/OBS/obs_sstbias.F90 b/src/OCE/OBS/obs_sstbias.F90 index 36bf5b030c3e13c097edfb268e2c3ee1cd3c5618..b42947f41de094592537942bc4f7731a0b1d3ddb 100644 --- a/src/OCE/OBS/obs_sstbias.F90 +++ b/src/OCE/OBS/obs_sstbias.F90 @@ -77,32 +77,26 @@ CONTAINS INTEGER :: i_var_id INTEGER, DIMENSION(knumtypes) :: & & ibiastypes ! Array of the bias types in each file - REAL(dp), DIMENSION(jpi,jpj,knumtypes) :: z_sstbias - - - REAL(dp), DIMENSION(jpi,jpj) :: z_sstbias_2d - - - REAL(dp), DIMENSION(1) :: zext, zobsmask - - - - REAL(dp), DIMENSION(2,2,1) :: zweig - - - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zmask, zglam, zgphi - - - - - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zmask_tmp, zglam_tmp, zgphi_tmp - - - - - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zbias - REAL(dp) :: zlam - REAL(dp) :: zphi + REAL(wp), DIMENSION(jpi,jpj,knumtypes) :: & + & z_sstbias ! Array to store the SST bias values + REAL(wp), DIMENSION(jpi,jpj) :: & + & z_sstbias_2d ! Array to store the SST bias values + REAL(wp), DIMENSION(1) :: & + & zext, & + & zobsmask + REAL(wp), DIMENSION(2,2,1) :: & + & zweig + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmask, & + & zglam, & + & zgphi + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmask_tmp, & + & zglam_tmp, & + & zgphi_tmp + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zbias + REAL(wp) :: zlam + REAL(wp) :: zphi INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & & igrdi, & & igrdj diff --git a/src/OCE/OBS/obs_write.F90 b/src/OCE/OBS/obs_write.F90 index 6de0ab71c10b6cff979b5f9f708c993d45757c88..45253c18c4efb1ed53a1e76b1f2ecde92f287c20 100644 --- a/src/OCE/OBS/obs_write.F90 +++ b/src/OCE/OBS/obs_write.F90 @@ -99,7 +99,7 @@ CONTAINS INTEGER :: je INTEGER :: iadd INTEGER :: iext - REAL(dp) :: zpres + REAL(wp) :: zpres IF ( PRESENT( padd ) ) THEN iadd = padd%inum @@ -207,7 +207,7 @@ CONTAINS fbdata%caddname(1) = 'Hx' - idg = MAX( INT(LOG10(REAL(jpnij,dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', narea-1, '.nc' @@ -306,8 +306,8 @@ CONTAINS zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & & REAL(fbdata%pphi(jo),wp) ) fbdata%pob(jk,jo,1) = potemp( & - & REAL(fbdata%padd(jk,jo,1,2),wp), & - & REAL(fbdata%pext(jk,jo,1),wp), & + & REAL(fbdata%padd(jk,jo,1,2), wp), & + & REAL(fbdata%pext(jk,jo,1), wp), & & zpres, 0.0_wp ) ENDIF END DO @@ -472,7 +472,7 @@ CONTAINS fbdata%caddname(1) = 'Hx' - idg = MAX( INT(LOG10(REAL(jpnij,dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', narea-1, '.nc' @@ -585,9 +585,9 @@ CONTAINS INTEGER :: jk INTEGER :: inumgoodobs INTEGER :: inumgoodobsmpp - REAL(dp) :: zsumx - REAL(dp) :: zsumx2 - REAL(dp) :: zomb + REAL(wp) :: zsumx + REAL(wp) :: zsumx2 + REAL(wp) :: zomb IF (lwp) THEN @@ -629,4 +629,4 @@ CONTAINS END SUBROUTINE obs_wri_stats -END MODULE obs_write +END MODULE obs_write \ No newline at end of file diff --git a/src/OCE/OBS/obsinter_h2d.h90 b/src/OCE/OBS/obsinter_h2d.h90 index 18c47038ad898bdc7412c52e428dec92759d3450..103db7a9e72f8c5374d54a3feef1ed081bb86c5f 100644 --- a/src/OCE/OBS/obsinter_h2d.h90 +++ b/src/OCE/OBS/obsinter_h2d.h90 @@ -85,24 +85,19 @@ ! = 2 bilinear (geographical grid) ! = 3 bilinear (quadrilateral grid) ! = 4 polynomial (quadrilateral grid) - REAL(KIND=dp), INTENT(INOUT) :: plam, pphi - - - + REAL(KIND=wp), INTENT(INOUT) :: & + & plam, & + & pphi ! Geographical (lat,lon) coordinates of ! observation - REAL(KIND=dp), DIMENSION(2,2), INTENT(IN) :: pglam, pgphi - - - - REAL(KIND=dp), DIMENSION(2,2,kpk2), INTENT(IN) :: pmask - - - REAL(KIND=dp), DIMENSION(2,2,kpk2), INTENT(OUT) :: pweig - - - REAL(KIND=dp), DIMENSION(kpk2), INTENT(OUT) :: pobsmask - - + REAL(KIND=wp), DIMENSION(2,2), INTENT(IN) :: & + & pglam, & ! Model variable lat + & pgphi ! Model variable lon + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(OUT) :: & + & pweig ! Weights for interpolation + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsmask ! Vertical mask for observations INTEGER, INTENT(IN), OPTIONAL :: & & iminpoints ! Reject point which is not surrounded ! by at least iminpoints sea points @@ -114,31 +109,29 @@ & ikmax, & & iamb1, & & iamb2 - REAL(KIND=dp) :: zphimm, zphimp, zphipm, zphipp, zlammm, zlammp, zlampm, zlampp, zphimin, zphimax, zlammin, zlammax - - - - - - - - - - - - - - REAL(KIND=dp), DIMENSION(kpk2) :: z2dmm, z2dmp, z2dpm, z2dpp, z2dmmt, z2dmpt, z2dpmt, z2dppt, zsum - - - - - - - - - - + REAL(KIND=wp) :: & + & zphimm, & + & zphimp, & + & zphipm, & + & zphipp, & + & zlammm, & + & zlammp, & + & zlampm, & + & zlampp, & + & zphimin, & + & zphimax, & + & zlammin, & + & zlammax + REAL(KIND=wp), DIMENSION(kpk2) :: & + & z2dmm, & + & z2dmp, & + & z2dpm, & + & z2dpp, & + & z2dmmt, & + & z2dmpt, & + & z2dpmt, & + & z2dppt, & + & zsum LOGICAL :: & & ll_ds1, & & ll_skip, & @@ -396,24 +389,20 @@ INTEGER, INTENT(IN) :: & & kpk, & ! Parameter values for automatic arrays & kpk2 - REAL(KIND=dp), DIMENSION(2,2,kpk2), INTENT(IN) :: pweig - - - REAL(KIND=dp), DIMENSION(2,2,kpk2), INTENT(IN) :: pmod - - - REAL(KIND=dp), DIMENSION(kpk2), INTENT(OUT) :: pobsk - - + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pweig ! Interpolation weights + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmod ! Model variable to interpolate + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsk ! Model profile interpolated to obs (i,j) pt !! * Local declarations INTEGER :: & & jk INTEGER :: & & ikmax - REAL(KIND=dp) :: zsum - - + REAL(KIND=wp) :: & + & zsum !------------------------------------------------------------------------ ! Initialize number of levels !------------------------------------------------------------------------ @@ -472,69 +461,65 @@ INTEGER, INTENT(IN) :: & & kpk2, & ! Parameter values for automatic arrays & kmax - REAL(KIND=dp), INTENT(IN) :: pphi, plam, pphimm, pphimp, pphipm, pphipp, plammm, plammp, plampm, plampp - - - - - - - - - - - - REAL(KIND=dp), DIMENSION(2,2,kpk2), INTENT(IN) :: pmask - - - REAL(KIND=dp), DIMENSION(kpk2), INTENT(OUT) :: p2dmm, p2dmp, p2dpm, p2dpp - - - - - + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp !! * Local declarations INTEGER :: & & jk - REAL(KIND=dp) :: zphi2, zlam2, zcola, za2, zb2, zc2, zphimm2, zphimp2, zphipm2, zphipp2, zlammm2, zlammp2, zlampm2, zlampp2, za1mm, za1mp, za1pm, za1pp, zcomm, zcomp, zcopm, zcopp, zb1mm, zb1mp, zb1pm, zb1pp, zc1mm, zc1mp, zc1pm, zc1pp, zsopmpp, zsommmp, zsomm, zsomp, zsopm, zsopp - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + REAL(KIND=wp) :: & + & zphi2, & + & zlam2, & + & zcola, & + & za2, & + & zb2, & + & zc2, & + & zphimm2, & + & zphimp2, & + & zphipm2, & + & zphipp2, & + & zlammm2, & + & zlammp2, & + & zlampm2, & + & zlampp2, & + & za1mm, & + & za1mp, & + & za1pm, & + & za1pp, & + & zcomm, & + & zcomp, & + & zcopm, & + & zcopp, & + & zb1mm, & + & zb1mp, & + & zb1pm, & + & zb1pp, & + & zc1mm, & + & zc1mp, & + & zc1pm, & + & zc1pp, & + & zsopmpp, & + & zsommmp, & + & zsomm, & + & zsomp, & + & zsopm, & + & zsopp !------------------------------------------------------------------------ ! Distance-weighted interpolation using the great circle formula @@ -625,48 +610,44 @@ INTEGER, INTENT(IN) :: & & kpk2, & ! Parameter values for automatic arrays & kmax - REAL(KIND=dp), INTENT(IN) :: pphi, plam, pphimm, pphimp, pphipm, pphipp, plammm, plammp, plampm, plampp - - - - - - - - - - - - REAL(KIND=dp), DIMENSION(2,2,kpk2), INTENT(IN) :: pmask - - - REAL(KIND=dp), DIMENSION(kpk2), INTENT(OUT) :: p2dmm, p2dmp, p2dpm, p2dpp - - - - - + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp !! * Local declarations INTEGER :: & & jk - REAL(KIND=dp) :: zcosp, zdlmm, zdlmp, zdlpm, zdlpp, zdpmm, zdpmp, zdppm, zdppp, zsomm, zsomp, zsopm, zsopp, zsopmpp, zsommmp - - - - - - - - - - - - - - - - + REAL(KIND=wp) :: & + & zcosp, & + & zdlmm, & + & zdlmp, & + & zdlpm, & + & zdlpp, & + & zdpmm, & + & zdpmp, & + & zdppm, & + & zdppp, & + & zsomm, & + & zsomp, & + & zsopm, & + & zsopp, & + & zsopmpp, & + & zsommmp !------------------------------------------------------------------------ ! Distance-weighted interpolation with a small angle approximation @@ -727,33 +708,29 @@ INTEGER, INTENT(IN) :: & & kpk2, & ! Parameter values for automatic arrays & kmax - REAL(KIND=dp), INTENT(IN) :: pphi, plam, pphipm, pphipp, plammp, plampp - - - - - - - - REAL(KIND=dp), DIMENSION(2,2,kpk2), INTENT(IN) :: pmask - - - REAL(KIND=dp), DIMENSION(kpk2), INTENT(OUT) :: p2dmm, p2dmp, p2dpm, p2dpp - - - - - + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphipm, & ! Geographical location of surrounding + & pphipp, & ! model grid points + & plammp, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp !! * Local declarations INTEGER :: & & jk - REAL(KIND=dp) :: zdlmp, zdppm, zdlpp, zdppp - - - - - + REAL(KIND=wp) :: & + & zdlmp, & + & zdppm, & + & zdlpp, & + & zdppp !---------------------------------------------------------------------- ! Bilinear interpolation for geographical grid @@ -798,38 +775,34 @@ INTEGER, INTENT(IN) :: & & kpk2, & ! Parameter values for automatic arrays & kmax - REAL(KIND=dp), INTENT(IN) :: pphi, plam, pphimm, pphimp, pphipm, pphipp, plammm, plammp, plampm, plampp - - - - - - - - - - - - REAL(KIND=dp), DIMENSION(2,2,kpk2), INTENT(IN) :: pmask - - - REAL(KIND=dp), DIMENSION(kpk2), INTENT(OUT) :: p2dmm, p2dmp, p2dpm, p2dpp - - - - - + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp LOGICAL, INTENT(OUT) :: & & ldfail !! * Local declarations INTEGER :: & & jk - REAL(KIND=dp) :: zbiwmm, zbiwmp, zbiwpm, zbiwpp - - - - - + REAL(KIND=wp) :: & + & zbiwmm, & + & zbiwmp, & + & zbiwpm, & + & zbiwpp !---------------------------------------------------------------------- ! Bilinear remapping interpolation for general quadrilateral grid @@ -884,38 +857,33 @@ INTEGER, INTENT(IN) :: & & kpk2, & ! Parameter values for automatic arrays & kmax - REAL(KIND=dp), INTENT(IN) :: pphi, plam, pphimm, pphimp, pphipm, pphipp, plammm, plammp, plampm, plampp - - - - - - - - - - - - REAL(KIND=dp), DIMENSION(2,2,kpk2), INTENT(IN) :: pmask - - - REAL(KIND=dp), DIMENSION(kpk2), INTENT(OUT) :: p2dmm, p2dmp, p2dpm, p2dpp - - - - - + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp !! * Local declarations INTEGER :: & & jk - REAL(KIND=dp) :: zplp - - - REAL(KIND=dp), DIMENSION(4,4) :: zmat, zmati - - - + REAL(KIND=wp) :: & + & zplp + REAL(KIND=wp), DIMENSION(4,4) :: & + & zmat, & + & zmati !------------------------------------------------------------------------ ! Polynomial interpolation @@ -991,24 +959,22 @@ !!----------------------------------------------------------------------- !! * Arguments - REAL(KIND=dp), INTENT(IN) :: pphi, plam, pphimm, pphimp, pphipm, pphipp, plammm, plammp, plampm, plampp - - - - - - - - - - - - REAL(KIND=dp), INTENT(OUT) :: pbiwmm, pbiwmp, pbiwpm, pbiwpp - - - - - + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), INTENT(OUT) :: & + & pbiwmm, & ! Interpolation weights + & pbiwmp, & + & pbiwpm, & + & pbiwpp LOGICAL, INTENT(out) :: & & ldfail @@ -1017,38 +983,37 @@ & jiter INTEGER :: & & itermax - REAL(KIND=dp) :: zphi, zlam, zphimm, zphimp, zphipm, zphipp, zlammm, zlammp, zlampm, zlampp, zdth1, zdth2, zdth3, zdthp, zdph1, zdph2, zdph3, zdphp, zmat1, zmat2, zmat3, zmat4, zdeli, zdelj, ziguess, zjguess, zeps, zdeterm, z2pi, zhpi - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + REAL(KIND=wp) :: & + & zphi, & ! Geographical location of observation + & zlam, & + & zphimm, & ! Geographical location of surrounding + & zphimp, & ! model grid points + & zphipm, & + & zphipp, & + & zlammm, & + & zlammp, & + & zlampm, & + & zlampp, & + & zdth1, & + & zdth2, & + & zdth3, & + & zdthp, & + & zdph1, & + & zdph2, & + & zdph3, & + & zdphp, & + & zmat1, & + & zmat2, & + & zmat3, & + & zmat4, & + & zdeli, & + & zdelj, & + & ziguess, & + & zjguess, & + & zeps, & + & zdeterm, & + & z2pi, & + & zhpi ! Initialization @@ -1195,12 +1160,10 @@ !! * Arguments INTEGER, INTENT(IN) :: & & kdim ! Array dimension - REAL(KIND=dp), DIMENSION(kdim,kdim), INTENT(IN) :: pmatin - - - REAL(KIND=dp), DIMENSION(kdim,kdim), INTENT(OUT) :: pmatou - - + REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(IN) :: & + & pmatin + REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(OUT) :: & + & pmatou !! * Local declarations INTEGER :: & @@ -1208,12 +1171,10 @@ & jj INTEGER, DIMENSION(kdim) :: & & indx - REAL(KIND=dp), DIMENSION(kdim,kdim) :: zmat - - - REAL(KIND=dp) :: zd - - + REAL(KIND=wp), DIMENSION(kdim,kdim) :: & + & zmat + REAL(KIND=wp) :: & + & zd ! Invert the matrix DO jj = 1, kdim @@ -1255,32 +1216,28 @@ & kdim2 INTEGER, DIMENSION(kdim1), INTENT(OUT) :: & & kindex - REAL(KIND=dp), INTENT(OUT) :: pflt - - - REAL(KIND=dp), DIMENSION(kdim2,kdim2), INTENT(INOUT) :: pmatin - - + REAL(KIND=wp), INTENT(OUT) :: & + & pflt + REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(INOUT) :: & + & pmatin !! * Local declarations INTEGER, PARAMETER :: & & jpmax = 100 REAL(KIND=wp), PARAMETER :: & & pptiny = 1.0e-20_wp - REAL(KIND=dp), DIMENSION(jpmax) :: zvv - - + REAL(KIND=wp), DIMENSION(jpmax) :: & + & zvv INTEGER :: & & ji, & & jj, & & jk INTEGER :: & & imax - REAL(KIND=dp) :: zsum, zdum, zaamax - - - - + REAL(KIND=wp) :: & + & zsum, & + & zdum, & + & zaamax imax = -1 ! Main computation @@ -1362,12 +1319,10 @@ & kdim2 INTEGER, DIMENSION(kdim1), INTENT(IN) :: & & kindex - REAL(KIND=dp), DIMENSION(kdim1), INTENT(INOUT) :: pvect - - - REAL(KIND=dp), DIMENSION(kdim2,kdim2), INTENT(IN) :: pmat - - + REAL(KIND=wp), DIMENSION(kdim1), INTENT(INOUT) :: & + & pvect + REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(IN) :: & + & pmat !! * Local declarations INTEGER :: & @@ -1375,9 +1330,8 @@ & jii, & & jj, & & jll - REAL(KIND=dp) :: zsum - - + REAL(KIND=wp) :: & + & zsum ! Main computation jii = 0 diff --git a/src/OCE/OBS/obsinter_z1d.h90 b/src/OCE/OBS/obsinter_z1d.h90 index 8b6095555d23c42a12fc50cb75b67d48ccbb450e..74a9d4af49061dca53e8408f2608801d29120bf3 100644 --- a/src/OCE/OBS/obsinter_z1d.h90 +++ b/src/OCE/OBS/obsinter_z1d.h90 @@ -33,24 +33,21 @@ INTEGER, INTENT(IN) :: kdep ! Number of levels in profile INTEGER, INTENT(IN), DIMENSION(kdep) :: & & kkco ! Array indicies for interpolation - REAL(KIND=dp), INTENT(IN), DIMENSION(kdep) :: pobsdep - - - REAL(KIND=dp), INTENT(IN), DIMENSION(kpk) :: pobsk, pobs2k, pdep, pobsmask - - - - - - REAL(KIND=dp), INTENT(OUT), DIMENSION(kdep) :: pobs - - + REAL(KIND=wp), INTENT(IN), DIMENSION(kdep) :: & + & pobsdep ! Depth of the observation + REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & + & pobsk, & ! Model profile at a given (lon,lat) + & pobs2k, & ! 2nd derivative of the interpolating function + & pdep, & ! Model depth array + & pobsmask ! Vertical mask + REAL(KIND=wp), INTENT(OUT), DIMENSION(kdep) :: & + & pobs ! Model equivalent at observation point !! * Local declarations - REAL(KIND=dp) :: z1dm ! Distance above and below obs to model grid points - REAL(KIND=dp) :: z1dp - REAL(KIND=dp) :: zsum ! Dummy variables for computation - REAL(KIND=dp) :: zsum2 + REAL(KIND=wp) :: z1dm ! Distance above and below obs to model grid points + REAL(KIND=wp) :: z1dp + REAL(KIND=wp) :: zsum ! Dummy variables for computation + REAL(KIND=wp) :: zsum2 INTEGER :: jdep ! Observation depths loop variable !------------------------------------------------------------------------ @@ -124,30 +121,27 @@ !! * Arguments INTEGER, INTENT(IN) :: kpk ! Number of vertical levels - REAL(KIND=dp), INTENT(IN), DIMENSION(kpk) :: pobsk, pdep, pobsmask - - - - - REAL(KIND=dp), INTENT(OUT), DIMENSION(kpk) :: pobs2k - - + REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & + & pobsk, & ! Model profile at a given (lon,lat) + & pdep, & ! Model depth array + & pobsmask ! Vertical mask + REAL(KIND=wp), INTENT(OUT), DIMENSION(kpk) :: & + & pobs2k ! 2nd derivative of the interpolating function !! * Local declarations INTEGER :: jk - REAL(KIND=dp) :: za - REAL(KIND=dp) :: zb - REAL(KIND=dp) :: zc - REAL(KIND=dp) :: zpa - REAL(KIND=dp) :: zkm - REAL(KIND=dp) :: zkp - REAL(KIND=dp) :: zk - REAL(KIND=dp), DIMENSION(kpk-1) :: zs, zp, zu, zv - - - - - + REAL(KIND=wp) :: za + REAL(KIND=wp) :: zb + REAL(KIND=wp) :: zc + REAL(KIND=wp) :: zpa + REAL(KIND=wp) :: zkm + REAL(KIND=wp) :: zkp + REAL(KIND=wp) :: zk + REAL(KIND=wp), DIMENSION(kpk-1) :: & + & zs, & + & zp, & + & zu, & + & zv !----------------------------------------------------------------------- ! Matrix initialisation diff --git a/src/OCE/SBC/abl.F90 b/src/OCE/SBC/abl.F90 index a6b7e0155aac9a79e43729ea883d86b7b9c277d4..6e8243d87faab4a0440d8380d69be0df7b935527 100644 --- a/src/OCE/SBC/abl.F90 +++ b/src/OCE/SBC/abl.F90 @@ -8,16 +8,16 @@ MODULE abl IMPLICIT NONE PRIVATE !! -------------------------- ! - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: u_abl !: i-horizontal velocity [m/s] - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: v_abl !: j-horizontal velocity [m/s] - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: tq_abl !: 4D T-q fields [Kelvin,kg/kg] - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avm_abl !: turbulent viscosity [m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_abl !: turbulent diffusivity [m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: mxl_abl !: mixing length [m] - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: tke_abl !: turbulent kinetic energy [m2/s2] - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: fft_abl !: Coriolis parameter [1/s] - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pblh !: PBL height [m] - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: rest_eq + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: u_abl !: i-horizontal velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: v_abl !: j-horizontal velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: tq_abl !: 4D T-q fields [Kelvin,kg/kg] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avm_abl !: turbulent viscosity [m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_abl !: turbulent diffusivity [m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: mxl_abl !: mixing length [m] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: tke_abl !: turbulent kinetic energy [m2/s2] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: fft_abl !: Coriolis parameter [1/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pblh !: PBL height [m] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: rest_eq ! INTEGER , PUBLIC :: nt_n, nt_a !: now / after indices (equal 1 or 2) ! diff --git a/src/OCE/SBC/cpl_oasis3.F90 b/src/OCE/SBC/cpl_oasis3.F90 index c49cdaac7a91992b240358a04416408c74f21252..2d675985e822a0dfbaab820b6ae10a6c64f86a0f 100644 --- a/src/OCE/SBC/cpl_oasis3.F90 +++ b/src/OCE/SBC/cpl_oasis3.F90 @@ -72,7 +72,7 @@ MODULE cpl_oasis3 LOGICAL :: laction ! To be coupled or not CHARACTER(len = 8) :: clname ! Name of the coupling field CHARACTER(len = 1) :: clgrid ! Grid type - REAL(dp) :: nsgn ! Control of the sign change + REAL(wp) :: nsgn ! Control of the sign change INTEGER, DIMENSION(nmaxcat,nmaxcpl) :: nid ! Id of the field (no more than 9 categories and 9 extrena models) INTEGER :: nct ! Number of categories in field INTEGER :: ncplmodel ! Maximum number of models to/from which this variable may be sent/received @@ -80,7 +80,7 @@ MODULE cpl_oasis3 TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC :: srcv, ssnd !: Coupling fields - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: exfld ! Temporary buffer for receiving + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: exfld ! Temporary buffer for receiving !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -314,7 +314,7 @@ CONTAINS INTEGER , INTENT(in ) :: kid ! variable index in the array INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds - REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pdata + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdata !! INTEGER :: jc,jm ! local loop index !!-------------------------------------------------------------------- @@ -359,8 +359,8 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kid ! variable index in the array INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds - REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: pdata ! IN to keep the value if nothing is done - REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! coupling mask + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdata ! IN to keep the value if nothing is done + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! coupling mask INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument !! INTEGER :: jc,jm ! local loop index @@ -545,7 +545,7 @@ CONTAINS END SUBROUTINE oasis_enddef SUBROUTINE oasis_put(k1,k2,p1,k3) - REAL(dp), DIMENSION(:,:), INTENT(in ) :: p1 + REAL(wp), DIMENSION(:,:), INTENT(in ) :: p1 INTEGER , INTENT(in ) :: k1,k2 INTEGER , INTENT( out) :: k3 k3 = -1 @@ -553,7 +553,7 @@ CONTAINS END SUBROUTINE oasis_put SUBROUTINE oasis_get(k1,k2,p1,k3) - REAL(dp), DIMENSION(:,:), INTENT( out) :: p1 + REAL(wp), DIMENSION(:,:), INTENT( out) :: p1 INTEGER , INTENT(in ) :: k1,k2 INTEGER , INTENT( out) :: k3 p1(1,1) = -1. ; k3 = -1 @@ -577,4 +577,4 @@ CONTAINS #endif !!===================================================================== -END MODULE cpl_oasis3 +END MODULE cpl_oasis3 \ No newline at end of file diff --git a/src/OCE/SBC/fldread.F90 b/src/OCE/SBC/fldread.F90 index c7d3935f274195f559a126aa01d773c4afee330a..2324b5e4dace7c73e2063d71d38f3ad2de9dcf5d 100644 --- a/src/OCE/SBC/fldread.F90 +++ b/src/OCE/SBC/fldread.F90 @@ -76,8 +76,8 @@ MODULE fldread INTEGER :: nbb ! index of before values INTEGER :: naa ! index of after values INTEGER , ALLOCATABLE, DIMENSION(:) :: nrecsec ! - REAL(dp), POINTER, DIMENSION(:,:,: ) :: fnow ! input fields interpolated to now time step - REAL(dp), POINTER, DIMENSION(:,:,:,:) :: fdta ! 2 consecutive record of input fields + REAL(wp), POINTER, DIMENSION(:,:,: ) :: fnow ! input fields interpolated to now time step + REAL(wp), POINTER, DIMENSION(:,:,:,:) :: fdta ! 2 consecutive record of input fields CHARACTER(len = 256) :: wgtname ! current name of the NetCDF weight file acting as a key ! ! into the WGTLIST structure CHARACTER(len = 34) :: vcomp ! symbolic name for a vector component that needs rotation @@ -129,6 +129,7 @@ MODULE fldread !! * Substitutions # include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -153,7 +154,7 @@ CONTAINS INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables INTEGER , INTENT(in ), OPTIONAL :: kit ! subcycle timestep for timesplitting option - REAL(dp) , INTENT(in ), OPTIONAL :: pt_offset ! provide fields at time other than "now" + REAL(wp) , INTENT(in ), OPTIONAL :: pt_offset ! provide fields at time other than "now" INTEGER , INTENT(in ), OPTIONAL :: Kmm ! ocean time level index !! INTEGER :: imf ! size of the structure sd @@ -161,25 +162,25 @@ CONTAINS INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step INTEGER :: ibb, iaa ! shorter name for sd(jf)%nbb and sd(jf)%naa LOGICAL :: ll_firstcall ! true if this is the first call to fld_read for this set of fields - REAL(dp) :: zt_offset ! local time offset variable - REAL(dp) :: ztinta ! ratio applied to after records when doing time interpolation - REAL(dp) :: ztintb ! ratio applied to before records when doing time interpolation + REAL(wp) :: zt_offset ! local time offset variable + REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation + REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation CHARACTER(LEN=1000) :: clfmt ! write format !!--------------------------------------------------------------------- ll_firstcall = kt == nit000 IF( PRESENT(kit) ) ll_firstcall = ll_firstcall .and. kit == 1 - IF( nn_components == jp_iam_sas ) THEN ; zt_offset = REAL( nn_fsbc,dp ) + IF( nn_components == jp_iam_sas ) THEN ; zt_offset = REAL( nn_fsbc, wp ) ELSE ; zt_offset = 0. ENDIF IF( PRESENT(pt_offset) ) zt_offset = pt_offset ! Note that all varibles starting by nsec_* are shifted time by +1/2 time step to be centrered IF( PRESENT(kit) ) THEN ! ignore kn_fsbc in this case - isecsbc = nsec_year + nsec1jan000 + NINT( ( REAL( kit,dp) + zt_offset ) * rn_Dt / REAL(nn_e,dp) ) + isecsbc = nsec_year + nsec1jan000 + NINT( ( REAL( kit,wp) + zt_offset ) * rn_Dt / REAL(nn_e,wp) ) ELSE ! middle of sbc time step ! note: we use kn_fsbc-1 because nsec_year is defined at the middle of the current time step - isecsbc = nsec_year + nsec1jan000 + NINT( ( 0.5*REAL(kn_fsbc-1,dp) + zt_offset ) * rn_Dt ) + isecsbc = nsec_year + nsec1jan000 + NINT( ( 0.5*REAL(kn_fsbc-1,wp) + zt_offset ) * rn_Dt ) ENDIF imf = SIZE( sd ) ! @@ -213,20 +214,20 @@ CONTAINS IF(lwp .AND. ( kt - nit000 <= 20 .OR. nitend - kt <= 20 ) ) THEN clfmt = "(' fld_read: var ', a, ' kt = ', i8, ' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // & & "', records b/a: ', i6.4, '/', i6.4, ' (days ', f9.4,'/', f9.4, ')')" - WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,dp)/rday, nyear, nmonth, nday, & - & sd(jf)%nrec(1,ibb), sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),dp)/rday, REAL(sd(jf)%nrec(2,iaa),dp)/rday + WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & + & sd(jf)%nrec(1,ibb), sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday IF( zt_offset /= 0._wp ) WRITE(numout, *) ' zt_offset is : ', zt_offset ENDIF ! temporal interpolation weights - ztinta = REAL( isecsbc - sd(jf)%nrec(2,ibb),dp ) / REAL( sd(jf)%nrec(2,iaa) - sd(jf)%nrec(2,ibb),dp ) + ztinta = REAL( isecsbc - sd(jf)%nrec(2,ibb), wp ) / REAL( sd(jf)%nrec(2,iaa) - sd(jf)%nrec(2,ibb), wp ) ztintb = 1. - ztinta sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:,ibb) + ztinta * sd(jf)%fdta(:,:,:,iaa) ELSE ! nothing to do... IF(lwp .AND. ( kt - nit000 <= 20 .OR. nitend - kt <= 20 ) ) THEN clfmt = "(' fld_read: var ', a, ' kt = ', i8,' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // & & "', record: ', i6.4, ' (days ', f9.4, ' <-> ', f9.4, ')')" - WRITE(numout, clfmt) TRIM(sd(jf)%clvar), kt, REAL(isecsbc,dp)/rday, nyear, nmonth, nday, & - & sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),dp)/rday, REAL(sd(jf)%nrec(2,iaa),dp)/rday + WRITE(numout, clfmt) TRIM(sd(jf)%clvar), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & + & sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday ENDIF ENDIF ! @@ -355,8 +356,8 @@ CONTAINS INTEGER :: iw ! index into wgts array INTEGER :: idvar ! variable ID INTEGER :: idmspc ! number of spatial dimensions - REAL(dp) :: zsgn ! sign used in the call to lbc_lbk called by iom_get - REAL(dp), DIMENSION(:,:,:), POINTER :: dta_alias ! short cut + REAL(wp) :: zsgn ! sign used in the call to lbc_lbk called by iom_get + REAL(wp), DIMENSION(:,:,:), POINTER :: dta_alias ! short cut !!--------------------------------------------------------------------- iaa = sdjf%naa ! @@ -381,7 +382,7 @@ CONTAINS idmspc = iom_file ( sdjf%num )%ndims( idvar ) IF( iom_file( sdjf%num )%luld( idvar ) ) idmspc = idmspc - 1 ! id of the last spatial dimension CALL iom_get( sdjf%num, jpdom_global, sdjf%clvar, dta_alias(:,:,:), sdjf%nrec(1,iaa), & - & sdjf%cltype, zsgn, kfill = jpfillcopy ) + & sdjf%cltype, CASTDP(zsgn), kfill = jpfillcopy ) ENDIF ! sdjf%rotn(iaa) = .false. ! vector not yet rotated @@ -398,7 +399,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: knum ! stream number CHARACTER(LEN=*) , INTENT(in ) :: cdvar ! variable name - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pdta ! bdy output field on model grid + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta ! bdy output field on model grid INTEGER , INTENT(in ) :: krec ! record number to read (ie time slice) INTEGER , DIMENSION(:) , INTENT(in ) :: kmap ! global-to-local bdy mapping indices ! optional variables used for vertical interpolation: @@ -416,10 +417,10 @@ CONTAINS INTEGER :: indims ! number of dimensions of the variable INTEGER, DIMENSION(4) :: idimsz ! size of variable dimensions REAL(wp) :: zfv ! fillvalue - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zz_read ! work space for global boundary data - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read ! work space local data requiring vertical interpolation - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_z ! work space local data requiring vertical interpolation - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_dz ! work space local data requiring vertical interpolation + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zz_read ! work space for global boundary data + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read ! work space local data requiring vertical interpolation + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_z ! work space local data requiring vertical interpolation + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_dz ! work space local data requiring vertical interpolation CHARACTER(LEN=1),DIMENSION(3) :: cltype LOGICAL :: lluld ! is the variable using the unlimited dimension LOGICAL :: llzint ! local value of ldzint @@ -500,9 +501,9 @@ CONTAINS !! !! ** Purpose : inner core of fld_map !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! global boundary data + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! global boundary data INTEGER, DIMENSION(: ), INTENT(in ) :: kmap ! global-to-local bdy mapping indices - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pdta_bdy ! bdy output field on model grid + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta_bdy ! bdy output field on model grid !! INTEGER, DIMENSION(3) :: idim_read, idim_bdy ! arrays dimensions INTEGER :: ji, jj, jk, jb ! loop counters @@ -544,10 +545,10 @@ CONTAINS !!---------------------------------------------------------------------- USE bdy_oce, ONLY: idx_bdy ! indexing for map <-> ij transformation - REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! data read in bdy file - REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read_z ! depth of the data read in bdy file - REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read_dz ! thickness of the levels in bdy file - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pdta ! output field on model grid (2 dimensional) + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! data read in bdy file + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read_z ! depth of the data read in bdy file + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read_dz ! thickness of the levels in bdy file + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta ! output field on model grid (2 dimensional) REAL(wp) , INTENT(in ) :: pfv ! fillvalue of the data read in bdy file LOGICAL , INTENT(in ) :: ldtotvel ! true if toal ( = barotrop + barocline) velocity INTEGER , INTENT(in ) :: kgrd ! grid type (t, u, v) @@ -558,9 +559,9 @@ CONTAINS INTEGER :: ipkb ! number of vertical levels in boundary data file INTEGER :: ipkmax ! number of vertical levels in boundary data file where no mask INTEGER :: jb, ji, jj, jk, jkb ! loop counters - REAL(dp) :: zcoef, zi ! - REAL(dp) :: ztrans, ztrans_new ! transports - REAL(dp), DIMENSION(jpk) :: zdepth, zdhalf ! level and half-level depth + REAL(wp) :: zcoef, zi ! + REAL(wp) :: ztrans, ztrans_new ! transports + REAL(wp), DIMENSION(jpk) :: zdepth, zdhalf ! level and half-level depth !!--------------------------------------------------------------------- ipi = SIZE( pdta, 1 ) @@ -700,8 +701,8 @@ CONTAINS INTEGER :: ill ! character length INTEGER :: iv ! indice of V component CHARACTER (LEN=100) :: clcomp ! dummy weight name - REAL(dp), DIMENSION(jpi,jpj) :: utmp, vtmp ! temporary arrays for vector rotation - REAL(dp), DIMENSION(:,:,:), POINTER :: dta_u, dta_v ! short cut + REAL(wp), DIMENSION(jpi,jpj) :: utmp, vtmp ! temporary arrays for vector rotation + REAL(wp), DIMENSION(:,:,:), POINTER :: dta_u, dta_v ! short cut !!--------------------------------------------------------------------- ! !! (sga: following code should be modified so that pairs arent searched for each time @@ -758,7 +759,7 @@ CONTAINS INTEGER :: ireclast INTEGER :: ishift, istart INTEGER, DIMENSION(2) :: isave - REAL(dp) :: zfreqs + REAL(wp) :: zfreqs LOGICAL :: llprev, llnext, llstop LOGICAL :: llprevmt, llprevyr LOGICAL :: llnextmt, llnextyr @@ -842,10 +843,10 @@ CONTAINS ELSE ; ireclast = 12 ! consider that the file has 12 record ENDIF ELSE ! higher frequency mean (in hours) - IF( sdjf%clftyp == 'monthly' ) THEN ; ireclast = NINT( 24. * REAL(nmonth_len(indexmt),dp) / sdjf%freqh ) + IF( sdjf%clftyp == 'monthly' ) THEN ; ireclast = NINT( 24. * REAL(nmonth_len(indexmt), wp) / sdjf%freqh ) ELSEIF( sdjf%clftyp(1:4) == 'week' ) THEN ; ireclast = NINT( 24. * 7. / sdjf%freqh ) ELSEIF( sdjf%clftyp == 'daily' ) THEN ; ireclast = NINT( 24. / sdjf%freqh ) - ELSE ; ireclast = NINT( 24. * REAL( nyear_len(indexyr),dp) / sdjf%freqh ) + ELSE ; ireclast = NINT( 24. * REAL( nyear_len(indexyr), wp) / sdjf%freqh ) ENDIF ENDIF @@ -879,7 +880,7 @@ CONTAINS ENDIF zfreqs = sdjf%freqh * rhhmm * rmmss DO jt = 0, sdjf%nreclast - sdjf%nrecsec(jt) = istart + NINT( zfreqs * REAL(jt,dp) ) + sdjf%nrecsec(jt) = istart + NINT( zfreqs * REAL(jt,wp) ) END DO ENDIF ! @@ -1100,7 +1101,7 @@ CONTAINS CHARACTER (len=5) :: clname ! INTEGER , DIMENSION(4) :: ddims INTEGER :: isrc - REAL(dp), DIMENSION(jpi,jpj) :: data_tmp + REAL(wp), DIMENSION(jpi,jpj) :: data_tmp !!---------------------------------------------------------------------- ! IF( nxt_wgt > tot_wgts ) THEN @@ -1221,13 +1222,13 @@ CONTAINS INTEGER, INTENT(in ) :: itmpi,itmpj,itmpz ! lengths INTEGER, INTENT(in ) :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices INTEGER, DIMENSION(3), INTENT(in ) :: rec1_lsm,recn_lsm ! temporary arrays for start and length - REAL(dp),DIMENSION (:,:,:),INTENT(inout) :: zfieldo ! input/output array for seaoverland application + REAL(wp),DIMENSION (:,:,:),INTENT(inout) :: zfieldo ! input/output array for seaoverland application CHARACTER (len=100), INTENT(in ) :: clmaskfile ! land/sea mask file name ! INTEGER :: inum,jni,jnj,jnz,jc ! local indices - REAL(dp),DIMENSION (:,:,:),ALLOCATABLE :: zslmec1 ! local array for land point detection - REAL(dp),DIMENSION (:,:), ALLOCATABLE :: zfieldn ! array of forcing field with undeff for land points - REAL(dp),DIMENSION (:,:), ALLOCATABLE :: zfield ! array of forcing field + REAL(wp),DIMENSION (:,:,:),ALLOCATABLE :: zslmec1 ! local array for land point detection + REAL(wp),DIMENSION (:,:), ALLOCATABLE :: zfieldn ! array of forcing field with undeff for land points + REAL(wp),DIMENSION (:,:), ALLOCATABLE :: zfield ! array of forcing field !!--------------------------------------------------------------------- ! ALLOCATE ( zslmec1(itmpi,itmpj,itmpz), zfieldn(itmpi,itmpj), zfield(itmpi,itmpj) ) @@ -1284,13 +1285,13 @@ CONTAINS !! D. Delrosso INGV !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: ileni,ilenj ! lengths - REAL(dp), DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points - REAL(dp), DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field + REAL(wp), DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points + REAL(wp), DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field ! - REAL(dp) , DIMENSION (ileni,ilenj) :: zmat1, zmat2, zmat3, zmat4 ! local arrays - REAL(dp) , DIMENSION (ileni,ilenj) :: zmat5, zmat6, zmat7, zmat8 ! - - - REAL(dp) , DIMENSION (ileni,ilenj) :: zlsm2d ! - - - REAL(dp) , DIMENSION (ileni,ilenj,8) :: zlsm3d ! - - + REAL(wp) , DIMENSION (ileni,ilenj) :: zmat1, zmat2, zmat3, zmat4 ! local arrays + REAL(wp) , DIMENSION (ileni,ilenj) :: zmat5, zmat6, zmat7, zmat8 ! - - + REAL(wp) , DIMENSION (ileni,ilenj) :: zlsm2d ! - - + REAL(wp) , DIMENSION (ileni,ilenj,8) :: zlsm3d ! - - LOGICAL , DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection LOGICAL , DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection !!---------------------------------------------------------------------- @@ -1324,7 +1325,7 @@ CONTAINS CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name INTEGER , INTENT(in ) :: kw ! weights number INTEGER , INTENT(in ) :: kk ! vertical dimension of kk - REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: dta ! output field on model grid + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: dta ! output field on model grid INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) CHARACTER(LEN=*) , INTENT(in ) :: lsmfile ! land sea mask file name ! @@ -1341,7 +1342,7 @@ CONTAINS INTEGER :: jpi1,jpi2,jpj1,jpj2 ! temporary indices INTEGER :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices INTEGER :: itmpi,itmpj,itmpz ! lengths - REAL(dp),DIMENSION(:,:,:), ALLOCATABLE :: ztmp_fly_dta ! local array of values on input grid + REAL(wp),DIMENSION(:,:,:), ALLOCATABLE :: ztmp_fly_dta ! local array of values on input grid !!---------------------------------------------------------------------- ipk = SIZE(dta, 3) ! @@ -1588,4 +1589,4 @@ CONTAINS END FUNCTION ksec_week !!====================================================================== -END MODULE fldread +END MODULE fldread \ No newline at end of file diff --git a/src/OCE/SBC/geo2ocean.F90 b/src/OCE/SBC/geo2ocean.F90 index db8d132cd54177addc9330e46dbaaa2ba0a0772e..83d25aeab1710ddb062f1b250f863e27becb491c 100644 --- a/src/OCE/SBC/geo2ocean.F90 +++ b/src/OCE/SBC/geo2ocean.F90 @@ -31,13 +31,13 @@ MODULE geo2ocean PUBLIC obs_rot ! called in obs_rot_vel and obs_write ! ! cos/sin between model grid lines and NP direction - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsint, gcost ! at T point - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinu, gcosu ! at U point - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinv, gcosv ! at V point - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinf, gcosf ! at F point + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsint, gcost ! at T point + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinu, gcosu ! at U point + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinv, gcosv ! at V point + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinf, gcosf ! at F point LOGICAL , SAVE, DIMENSION(4) :: linit = .FALSE. - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gsinlon, gcoslon, gsinlat, gcoslat + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gsinlon, gcoslon, gsinlat, gcoslat LOGICAL :: lmust_init = .TRUE. !: used to initialize the cos/sin variables (see above) @@ -57,14 +57,14 @@ CONTAINS !! ** Purpose : Rotate the Repere: Change vector componantes between !! geographic grid <--> stretched coordinates grid. !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pxin, pyin ! vector componantes + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxin, pyin ! vector componantes CHARACTER(len=1), INTENT(in ) :: cd_type ! define the nature of pt2d array grid-points CHARACTER(len=5), INTENT(in ) :: cdtodo ! type of transpormation: ! ! 'en->i' = east-north to i-component ! ! 'en->j' = east-north to j-component ! ! 'ij->e' = (i,j) components to east ! ! 'ij->n' = (i,j) components to north - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: prot + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: prot !!---------------------------------------------------------------------- ! IF( lmust_init ) THEN ! at 1st call only: set gsin. & gcos. @@ -131,20 +131,20 @@ CONTAINS !!---------------------------------------------------------------------- ! WARNING: for an unexplained reason, we need to pass all glam, gphi arrays as input parameters in ! order to get AGRIF working with -03 compilation option - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: plamt, pphit, plamu, pphiu, plamv, pphiv, plamf, pphif + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: plamt, pphit, plamu, pphiu, plamv, pphiv, plamf, pphif ! INTEGER :: ji, jj ! dummy loop indices INTEGER :: ierr ! local integer - REAL(dp) :: zlam, zphi ! local scalars - REAL(dp) :: zlan, zphh ! - - - REAL(dp) :: zxnpt, zynpt, znnpt ! x,y components and norm of the vector: T point to North Pole - REAL(dp) :: zxnpu, zynpu, znnpu ! x,y components and norm of the vector: U point to North Pole - REAL(dp) :: zxnpv, zynpv, znnpv ! x,y components and norm of the vector: V point to North Pole - REAL(dp) :: zxnpf, zynpf, znnpf ! x,y components and norm of the vector: F point to North Pole - REAL(dp) :: zxvvt, zyvvt, znvvt ! x,y components and norm of the vector: between V points below and above a T point - REAL(dp) :: zxffu, zyffu, znffu ! x,y components and norm of the vector: between F points below and above a U point - REAL(dp) :: zxffv, zyffv, znffv ! x,y components and norm of the vector: between F points left and right a V point - REAL(dp) :: zxuuf, zyuuf, znuuf ! x,y components and norm of the vector: between U points below and above a F point + REAL(wp) :: zlam, zphi ! local scalars + REAL(wp) :: zlan, zphh ! - - + REAL(wp) :: zxnpt, zynpt, znnpt ! x,y components and norm of the vector: T point to North Pole + REAL(wp) :: zxnpu, zynpu, znnpu ! x,y components and norm of the vector: U point to North Pole + REAL(wp) :: zxnpv, zynpv, znnpv ! x,y components and norm of the vector: V point to North Pole + REAL(wp) :: zxnpf, zynpf, znnpf ! x,y components and norm of the vector: F point to North Pole + REAL(wp) :: zxvvt, zyvvt, znvvt ! x,y components and norm of the vector: between V points below and above a T point + REAL(wp) :: zxffu, zyffu, znffu ! x,y components and norm of the vector: between F points below and above a U point + REAL(wp) :: zxffv, zyffv, znffv ! x,y components and norm of the vector: between F points left and right a V point + REAL(wp) :: zxuuf, zyuuf, znuuf ! x,y components and norm of the vector: between U points below and above a F point !!---------------------------------------------------------------------- ! ALLOCATE( gsint(jpi,jpj), gcost(jpi,jpj), & @@ -271,8 +271,8 @@ CONTAINS ! Lateral boundary conditions ! ! =========================== ! ! ! lateral boundary cond.: T-, U-, V-, F-pts, sgn - CALL lbc_lnk( 'geo2ocean', gcost, 'T', -1.0_dp, gsint, 'T', -1.0_dp, gcosu, 'U', -1.0_dp, gsinu, 'U', -1.0_dp, & - & gcosv, 'V', -1.0_dp, gsinv, 'V', -1.0_dp, gcosf, 'F', -1.0_dp, gsinf, 'F', -1.0_dp ) + CALL lbc_lnk( 'geo2ocean', gcost, 'T', -1.0_wp, gsint, 'T', -1.0_wp, gcosu, 'U', -1.0_wp, gsinu, 'U', -1.0_wp, & + & gcosv, 'V', -1.0_wp, gsinv, 'V', -1.0_wp, gcosf, 'F', -1.0_wp, gsinf, 'F', -1.0_wp ) ! END SUBROUTINE angle @@ -286,9 +286,9 @@ CONTAINS !! ** Method : Change a vector from geocentric to east/north !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pxx, pyy, pzz + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxx, pyy, pzz CHARACTER(len=1) , INTENT(in ) :: cgrid - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pte, ptn + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pte, ptn ! REAL(wp), PARAMETER :: rpi = 3.141592653e0 REAL(wp), PARAMETER :: rad = rpi / 180.e0 @@ -363,9 +363,9 @@ CONTAINS !! !! History : ! (A. Caubel) oce2geo - Original code !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( IN ) :: pte, ptn + REAL(wp), DIMENSION(jpi,jpj), INTENT( IN ) :: pte, ptn CHARACTER(len=1) , INTENT( IN ) :: cgrid - REAL(dp), DIMENSION(jpi,jpj), INTENT( OUT ) :: pxx , pyy , pzz + REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT ) :: pxx , pyy , pzz !! REAL(wp), PARAMETER :: rpi = 3.141592653E0 REAL(wp), PARAMETER :: rad = rpi / 180.e0 @@ -439,7 +439,7 @@ CONTAINS !! !! History : 9.2 ! 09-02 (K. Mogensen) !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT( OUT ):: psinu, pcosu, psinv, pcosv ! copy of data + REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT ):: psinu, pcosu, psinv, pcosv ! copy of data !!---------------------------------------------------------------------- ! ! Initialization of gsin* and gcos* at first call @@ -460,4 +460,4 @@ CONTAINS END SUBROUTINE obs_rot !!====================================================================== -END MODULE geo2ocean +END MODULE geo2ocean \ No newline at end of file diff --git a/src/OCE/SBC/ocealb.F90 b/src/OCE/SBC/ocealb.F90 index 23a6bc6edceddc1abac2e517bd50464e806d9b8f..74d55aa6f28ec4809d656155eb104acb49fc1b91 100644 --- a/src/OCE/SBC/ocealb.F90 +++ b/src/OCE/SBC/ocealb.F90 @@ -31,11 +31,11 @@ CONTAINS !! !! ** Purpose : Computation of the albedo of the ocean !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:), INTENT(out) :: palb_os ! albedo of ocean under overcast sky - REAL(dp), DIMENSION(:,:), INTENT(out) :: palb_cs ! albedo of ocean under clear sky + REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_os ! albedo of ocean under overcast sky + REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_cs ! albedo of ocean under clear sky !! - REAL(dp) :: zcoef - REAL(dp) :: rmue = 0.40 ! cosine of local solar altitude + REAL(wp) :: zcoef + REAL(wp) :: rmue = 0.40 ! cosine of local solar altitude !!---------------------------------------------------------------------- ! zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 ) ! Parameterization of Briegled and Ramanathan, 1982 diff --git a/src/OCE/SBC/sbc_ice.F90 b/src/OCE/SBC/sbc_ice.F90 index 8d061caf9fa8b0c968554bfe162d6f869881e423..8197e178808ba7598dfc7774fb92561062944741 100644 --- a/src/OCE/SBC/sbc_ice.F90 +++ b/src/OCE/SBC/sbc_ice.F90 @@ -38,13 +38,13 @@ MODULE sbc_ice LOGICAL , PUBLIC, PARAMETER :: lk_cice = .TRUE. !: CICE ice model # endif - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qns_ice !: non solar heat flux over ice [W/m2] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice !: solar heat flux over ice [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qns_ice !: non solar heat flux over ice [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice !: solar heat flux over ice [W/m2] REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qla_ice !: latent flux over ice [W/m2] REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dqla_ice !: latent sensibility over ice [W/m2/K] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dqns_ice !: non solar heat flux over ice (LW+SEN+LA) [W/m2/K] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice !: ice surface temperature [K] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: alb_ice !: ice albedo [-] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dqns_ice !: non solar heat flux over ice (LW+SEN+LA) [W/m2/K] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice !: ice surface temperature [K] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: alb_ice !: ice albedo [-] REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qml_ice !: heat available for snow / ice surface melting [W/m2] REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice !: heat conduction flux in the layer below surface [W/m2] @@ -52,10 +52,10 @@ MODULE sbc_ice REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_ice !: atmos-ice u-stress. VP: I-pt ; EVP: U,V-pts [N/m2] REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau_ice !: atmos-ice v-stress. VP: I-pt ; EVP: U,V-pts [N/m2] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation - precip over sea ice [kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation - precip over sea ice [kg/m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt !: category topmelt - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: botmelt !: category botmelt + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt !: category topmelt + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: botmelt !: category botmelt #if defined key_si3 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: evap_ice !: sublimation [kg/m2/s] @@ -89,19 +89,19 @@ MODULE sbc_ice ! variables used in the coupled interface INTEGER , PUBLIC, PARAMETER :: jpl = ncat - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! already defined in ice.F90 for SI3 - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i, h_s + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i, h_s REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tatm_ice !: air temperature [K] #endif !! arrays relating to embedding ice in the ocean - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass !: mass of snow and ice at current ice time step [Kg/m2] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass_b !: mass of snow and ice at previous ice time step [Kg/m2] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_fmass !: time evolution of mass of snow+ice [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass !: mass of snow and ice at current ice time step [Kg/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass_b !: mass of snow and ice at previous ice time step [Kg/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_fmass !: time evolution of mass of snow+ice [Kg/m2/s] !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) diff --git a/src/OCE/SBC/sbc_oce.F90 b/src/OCE/SBC/sbc_oce.F90 index 5d056d9c8e4b7fc710586c34112aa2708d8586e4..e9e508917dd11f0206f020521700d872596ecba2 100644 --- a/src/OCE/SBC/sbc_oce.F90 +++ b/src/OCE/SBC/sbc_oce.F90 @@ -103,62 +103,61 @@ MODULE sbc_oce INTEGER , PUBLIC :: ncpl_qsr_freq = 0 !: qsr coupling frequency per days from atmosphere (used by top) ! !! !! now ! before !! - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau , utau_b !: sea surface i-stress (ocean referential) [N/m2] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau , vtau_b !: sea surface j-stress (ocean referential) [N/m2] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_icb, vtau_icb !: sea surface (i,j)-stress used by icebergs [N/m2] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: taum !: module of sea surface stress (at T-point) [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau , utau_b !: sea surface i-stress (ocean referential) [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau , vtau_b !: sea surface j-stress (ocean referential) [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_icb, vtau_icb !: sea surface (i,j)-stress used by icebergs [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: taum !: module of sea surface stress (at T-point) [N/m2] !! wndm is used compute surface gases exchanges in ice-free ocean or leads - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm !: wind speed module at T-point (=|U10m-Uoce|) [m/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhoa !: air density at KTHX8OO m above the sea [kg/m3] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr !: sea heat flux: solar [W/m2] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns , qns_b !: sea heat flux: non solar [W/m2] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_tot !: total solar heat flux (over sea and ice) [W/m2] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns_tot !: total non solar heat flux (over sea and ice) [W/m2] - REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp!: freshwater budget: volume flux [Kg/m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_b!: freshwater budget: volume flux [Kg/m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx , sfx_b !: salt flux [PSS.kg/m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_tot !: total E-P over ocean and ice [Kg/m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fmmflx !: freshwater budget: freezing/melting [Kg/m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf , rnf_b !: river runoff [Kg/m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwficb , fwficb_b !: iceberg melting [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm !: wind speed module at T-point (=|U10m-Uoce|) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhoa !: air density at "rn_zu" m above the sea [kg/m3] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr !: sea heat flux: solar [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns , qns_b !: sea heat flux: non solar [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_tot !: total solar heat flux (over sea and ice) [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns_tot !: total non solar heat flux (over sea and ice) [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp , emp_b !: freshwater budget: volume flux [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx , sfx_b !: salt flux [PSS.kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_tot !: total E-P over ocean and ice [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fmmflx !: freshwater budget: freezing/melting [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf , rnf_b !: river runoff [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwficb , fwficb_b !: iceberg melting [Kg/m2/s] !! - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sbc_tsc, sbc_tsc_b !: sbc content trend [K.m/s] jpi,jpj,jpts - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_hc , qsr_hc_b !: heat content trend due to qsr flux [K.m/s] jpi,jpj,jpk + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sbc_tsc, sbc_tsc_b !: sbc content trend [K.m/s] jpi,jpj,jpts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_hc , qsr_hc_b !: heat content trend due to qsr flux [K.m/s] jpi,jpj,jpk !! !! - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tprecip !: total precipitation [Kg/m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sprecip !: solid precipitation [Kg/m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_i !: ice fraction = 1 - lead fraction (between 0 to 1) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: atm_co2 !: atmospheric pCO2 [ppm] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask !: coupling mask for ln_mixcpl (warning: allocated in sbccpl) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: cloud_fra !: cloud cover (fraction of cloud in a gridcell) [-] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tprecip !: total precipitation [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sprecip !: solid precipitation [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_i !: ice fraction = 1 - lead fraction (between 0 to 1) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: atm_co2 !: atmospheric pCO2 [ppm] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask !: coupling mask for ln_mixcpl (warning: allocated in sbccpl) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: cloud_fra !: cloud cover (fraction of cloud in a gridcell) [-] !!--------------------------------------------------------------------- !! ABL Vertical Domain size !!--------------------------------------------------------------------- INTEGER , PUBLIC :: jpka = 2 !: ABL number of vertical levels (default definition) INTEGER , PUBLIC :: jpkam1 = 1 !: jpka-1 - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ght_abl, ghw_abl !: ABL geopotential height (needed for iom) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_abl, e3w_abl !: ABL vertical scale factors (needed for iom) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ght_abl, ghw_abl !: ABL geopotential height (needed for iom) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_abl, e3w_abl !: ABL vertical scale factors (needed for iom) !!---------------------------------------------------------------------- !! Sea Surface Mean fields !!---------------------------------------------------------------------- INTEGER , PUBLIC :: nn_fsbc !: frequency of sbc computation (as well as sea-ice model) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssu_m !: mean (nn_fsbc time-step) surface sea i-current (U-point) [m/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssv_m !: mean (nn_fsbc time-step) surface sea j-current (V-point) [m/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sst_m !: mean (nn_fsbc time-step) surface sea temperature [Celsius] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sss_m !: mean (nn_fsbc time-step) surface sea salinity [psu] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssh_m !: mean (nn_fsbc time-step) sea surface height [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tsk_m !: mean (nn_fsbc time-step) SKIN surface sea temp. [Celsius] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3t_m !: mean (nn_fsbc time-step) sea surface layer thickness [m] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_m !: mean (nn_fsbc time-step) fraction of solar net radiation absorbed in the 1st T level [-] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssu_m !: mean (nn_fsbc time-step) surface sea i-current (U-point) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssv_m !: mean (nn_fsbc time-step) surface sea j-current (V-point) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sst_m !: mean (nn_fsbc time-step) surface sea temperature [Celsius] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sss_m !: mean (nn_fsbc time-step) surface sea salinity [psu] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssh_m !: mean (nn_fsbc time-step) sea surface height [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tsk_m !: mean (nn_fsbc time-step) SKIN surface sea temp. [Celsius] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3t_m !: mean (nn_fsbc time-step) sea surface layer thickness [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_m !: mean (nn_fsbc time-step) fraction of solar net radiation absorbed in the 1st T level [-] !!---------------------------------------------------------------------- !! Surface atmospheric fields !!---------------------------------------------------------------------- - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_air_zt !: specific humidity of air at z=zt [kg/kg]ww - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: theta_air_zt !: potential temperature of air at z=zt [K] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_air_zt !: specific humidity of air at z=zt [kg/kg]ww + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: theta_air_zt !: potential temperature of air at z=zt [K] !! * Substitutions @@ -216,9 +215,9 @@ CONTAINS !!--------------------------------------------------------------------- USE dom_oce ! ocean space and time domain USE lbclnk ! ocean lateral boundary conditions (or mpp link) - REAL(dp) :: zrhoa = 1.22 ! Air density kg/m3 - REAL(dp) :: zcdrag = 1.5e-3 ! drag coefficient - REAL(dp) :: ztx, zty, ztau, zcoef ! temporary variables + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: ztx, zty, ztau, zcoef ! temporary variables INTEGER :: ji, jj ! dummy indices !!--------------------------------------------------------------------- zcoef = 0.5 / ( zrhoa * zcdrag ) @@ -228,9 +227,9 @@ CONTAINS ztau = SQRT( ztx * ztx + zty * zty ) wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1) END_2D - CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1.0_dp ) + CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1.0_wp ) ! END SUBROUTINE sbc_tau2wnd !!====================================================================== -END MODULE sbc_oce +END MODULE sbc_oce \ No newline at end of file diff --git a/src/OCE/SBC/sbc_phy.F90 b/src/OCE/SBC/sbc_phy.F90 index f5c4a07b20db3373b7fc78a436afd2f4507e89c1..b2bfb4566926f86f9e2d86d1c9f7676c90bcbb5b 100644 --- a/src/OCE/SBC/sbc_phy.F90 +++ b/src/OCE/SBC/sbc_phy.F90 @@ -65,7 +65,7 @@ MODULE sbc_phy REAL(wp), PARAMETER, PUBLIC :: z0_sea_max = 0.0025_wp !: maximum realistic value for roughness length of sea-surface... [m] - REAL(dp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] + REAL(wp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] REAL(wp), PARAMETER, PUBLIC :: Cx_min = 0.1E-3_wp ! smallest value allowed for bulk transfer coefficients (usually in stable conditions with now wind) @@ -187,7 +187,6 @@ MODULE sbc_phy PUBLIC z0tq_LKB !! * Substitutions -# include "single_precision_substitute.h90" # include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -209,9 +208,9 @@ CONTAINS !! Author: L. Brodeau, June 2019 / AeroBulk !! (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------------ - REAL(dp) :: virt_temp_sclr !: virtual temperature [K] - REAL(dp), INTENT(in) :: pta !: absolute or potential air temperature [K] - REAL(dp), INTENT(in) :: pqa !: specific humidity of air [kg/kg] + REAL(wp) :: virt_temp_sclr !: virtual temperature [K] + REAL(wp), INTENT(in) :: pta !: absolute or potential air temperature [K] + REAL(wp), INTENT(in) :: pqa !: specific humidity of air [kg/kg] !!------------------------------------------------------------------- ! virt_temp_sclr = pta * (1._wp + rctv0*pqa) @@ -224,9 +223,9 @@ CONTAINS FUNCTION virt_temp_vctr( pta, pqa ) - REAL(dp), DIMENSION(jpi,jpj) :: virt_temp_vctr !: virtual temperature [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute or potential air temperature [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: specific humidity of air [kg/kg] + REAL(wp), DIMENSION(jpi,jpj) :: virt_temp_vctr !: virtual temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute or potential air temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: specific humidity of air [kg/kg] virt_temp_vctr(:,:) = pta(:,:) * (1._wp + rctv0*pqa(:,:)) @@ -243,13 +242,13 @@ CONTAINS !! ** Author: G. Samson, Feb 2021 !!------------------------------------------------------------------------------- - REAL(dp) :: pres_temp_sclr ! air pressure [Pa] - REAL(dp), INTENT(in ) :: pqspe ! air specific humidity [kg/kg] - REAL(dp), INTENT(in ) :: pslp ! sea-level pressure [Pa] - REAL(dp), INTENT(in ) :: pz ! height above surface [m] - REAL(dp), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K] - REAL(dp), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K] - REAL(dp) :: ztpot, zta, zpa, zxm, zmask, zqsat + REAL(wp) :: pres_temp_sclr ! air pressure [Pa] + REAL(wp), INTENT(in ) :: pqspe ! air specific humidity [kg/kg] + REAL(wp), INTENT(in ) :: pslp ! sea-level pressure [Pa] + REAL(wp), INTENT(in ) :: pz ! height above surface [m] + REAL(wp), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K] + REAL(wp), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K] + REAL(wp) :: ztpot, zta, zpa, zxm, zmask, zqsat INTEGER :: it, niter = 3 ! iteration indice and number LOGICAL , INTENT(in) , OPTIONAL :: l_ice ! sea-ice presence LOGICAL :: lice ! sea-ice presence @@ -291,12 +290,12 @@ CONTAINS !! ** Author: G. Samson, Feb 2021 !!------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: pres_temp_vctr ! air pressure [Pa] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pqspe ! air specific humidity [kg/kg] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pslp ! sea-level pressure [Pa] - REAL(dp), INTENT(in ) :: pz ! height above surface [m] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K] + REAL(wp), DIMENSION(jpi,jpj) :: pres_temp_vctr ! air pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqspe ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pslp ! sea-level pressure [Pa] + REAL(wp), INTENT(in ) :: pz ! height above surface [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K] INTEGER :: ji, jj ! loop indices LOGICAL , INTENT(in) , OPTIONAL :: l_ice ! sea-ice presence LOGICAL :: lice ! sea-ice presence @@ -327,9 +326,9 @@ CONTAINS !! ** Author: G. Samson, Feb 2021 !!------------------------------------------------------------------------------- - REAL(dp) :: theta_exner_sclr ! air/surface potential temperature [K] - REAL(dp), INTENT(in) :: pta ! air/surface absolute temperature [K] - REAL(dp), INTENT(in) :: ppa ! air/surface pressure [Pa] + REAL(wp) :: theta_exner_sclr ! air/surface potential temperature [K] + REAL(wp), INTENT(in) :: pta ! air/surface absolute temperature [K] + REAL(wp), INTENT(in) :: ppa ! air/surface pressure [Pa] theta_exner_sclr = pta * ( rpref / ppa ) ** rgamma_dry @@ -345,9 +344,9 @@ CONTAINS !! ** Author: G. Samson, Feb 2021 !!------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: theta_exner_vctr ! air/surface potential temperature [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pta ! air/surface absolute temperature [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! air/surface pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj) :: theta_exner_vctr ! air/surface potential temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta ! air/surface absolute temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! air/surface pressure [Pa] INTEGER :: ji, jj ! loop indices DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -365,10 +364,10 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! pressure in [Pa] - REAL(dp), DIMENSION(jpi,jpj) :: rho_air_vctr ! density of moist air [kg/m^3] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! pressure in [Pa] + REAL(wp), DIMENSION(jpi,jpj) :: rho_air_vctr ! density of moist air [kg/m^3] !!------------------------------------------------------------------------------- rho_air_vctr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp ) @@ -383,10 +382,10 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------------------- - REAL(dp), INTENT(in) :: ptak ! air temperature [K] - REAL(dp), INTENT(in) :: pqa ! air specific humidity [kg/kg] - REAL(dp), INTENT(in) :: ppa ! pressure in [Pa] - REAL(dp) :: rho_air_sclr ! density of moist air [kg/m^3] + REAL(wp), INTENT(in) :: ptak ! air temperature [K] + REAL(wp), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), INTENT(in) :: ppa ! pressure in [Pa] + REAL(wp) :: rho_air_sclr ! density of moist air [kg/m^3] !!------------------------------------------------------------------------------- rho_air_sclr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp ) @@ -399,10 +398,10 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp) :: visc_air_sclr ! kinetic viscosity (m^2/s) - REAL(dp), INTENT(in) :: ptak ! air temperature in (K) + REAL(wp) :: visc_air_sclr ! kinetic viscosity (m^2/s) + REAL(wp), INTENT(in) :: ptak ! air temperature in (K) ! - REAL(dp) :: ztc, ztc2 ! local scalar + REAL(wp) :: ztc, ztc2 ! local scalar !!---------------------------------------------------------------------------------- ! ztc = ptak - rt0 ! air temp, in deg. C @@ -413,8 +412,8 @@ CONTAINS FUNCTION visc_air_vctr(ptak) - REAL(dp), DIMENSION(jpi,jpj) :: visc_air_vctr ! kinetic viscosity (m^2/s) - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature in (K) + REAL(wp), DIMENSION(jpi,jpj) :: visc_air_vctr ! kinetic viscosity (m^2/s) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature in (K) INTEGER :: ji, jj ! dummy loop indices DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -432,7 +431,7 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: L_vap_vctr ! latent heat of vaporization [J/kg] + REAL(wp), DIMENSION(jpi,jpj) :: L_vap_vctr ! latent heat of vaporization [J/kg] REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K] !!---------------------------------------------------------------------------------- ! @@ -448,7 +447,7 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp) :: L_vap_sclr ! latent heat of vaporization [J/kg] + REAL(wp) :: L_vap_sclr ! latent heat of vaporization [J/kg] REAL(wp), INTENT(in) :: psst ! water temperature [K] !!---------------------------------------------------------------------------------- ! @@ -466,7 +465,7 @@ CONTAINS !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------------------- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] - REAL(dp), DIMENSION(jpi,jpj) :: cp_air_vctr ! specific heat of moist air [J/K/kg] + REAL(wp), DIMENSION(jpi,jpj) :: cp_air_vctr ! specific heat of moist air [J/K/kg] !!------------------------------------------------------------------------------- cp_air_vctr = rCp_dry + rCp_vap * pqa @@ -481,8 +480,8 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------------------- - REAL(dp), INTENT(in) :: pqa ! air specific humidity [kg/kg] - REAL(dp) :: cp_air_sclr ! specific heat of moist air [J/K/kg] + REAL(wp), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp) :: cp_air_sclr ! specific heat of moist air [J/K/kg] !!------------------------------------------------------------------------------- cp_air_sclr = rCp_dry + rCp_vap * pqa @@ -498,11 +497,11 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp) :: gamma_moist_sclr ! [K/m] + REAL(wp) :: gamma_moist_sclr ! [K/m] REAL(wp), INTENT(in) :: ptak ! absolute air temperature [K] !#LB: double check it's absolute !!! REAL(wp), INTENT(in) :: pqa ! specific humidity [kg/kg] ! - REAL(dp) :: zta, zqa, zwa, ziRT, zLvap ! local scalars + REAL(wp) :: zta, zqa, zwa, ziRT, zLvap ! local scalars !!---------------------------------------------------------------------------------- zta = MAX( ptak, 180._wp) ! prevents screw-up over masked regions where field == 0. zqa = MAX( pqa, 1.E-6_wp) ! " " " @@ -517,7 +516,7 @@ CONTAINS FUNCTION gamma_moist_vctr( ptak, pqa ) - REAL(dp), DIMENSION(jpi,jpj) :: gamma_moist_vctr + REAL(wp), DIMENSION(jpi,jpj) :: gamma_moist_vctr REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa INTEGER :: ji, jj @@ -538,14 +537,14 @@ CONTAINS !! Author: L. Brodeau, June 2019 / AeroBulk !! (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------------ - REAL(dp), DIMENSION(jpi,jpj) :: One_on_L !: 1./(Obukhov length) [m^-1] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ptha !: reference potential temperature of air [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: reference specific humidity of air [kg/kg] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: u*: friction velocity [m/s] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pts, pqs !: \theta* and q* friction aka turb. scales for temp. and spec. hum. + REAL(wp), DIMENSION(jpi,jpj) :: One_on_L !: 1./(Obukhov length) [m^-1] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha !: reference potential temperature of air [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: reference specific humidity of air [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: u*: friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts, pqs !: \theta* and q* friction aka turb. scales for temp. and spec. hum. ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zqa ! local scalar + REAL(wp) :: zqa ! local scalar !!------------------------------------------------------------------- ! DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -573,19 +572,19 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp) :: Ri_bulk_sclr - REAL(dp), INTENT(in) :: pz ! height above the sea (aka SELJDD5BQ) [m] - REAL(dp), INTENT(in) :: psst ! potential SST [K] - REAL(dp), INTENT(in) :: ptha ! pot. air temp. at height 6IPN [K] - REAL(dp), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] - REAL(dp), INTENT(in) :: pqa ! air spec. hum. at height 38I3 [kg/kg] - REAL(dp), INTENT(in) :: pub ! bulk wind speed [m/s] + REAL(wp) :: Ri_bulk_sclr + REAL(wp), INTENT(in) :: pz ! height above the sea (aka "delta z") [m] + REAL(wp), INTENT(in) :: psst ! potential SST [K] + REAL(wp), INTENT(in) :: ptha ! pot. air temp. at height "pz" [K] + REAL(wp), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] + REAL(wp), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg] + REAL(wp), INTENT(in) :: pub ! bulk wind speed [m/s] REAL(wp), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] REAL(wp), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] !! LOGICAL :: l_ptqa_l_prvd = .FALSE. - REAL(dp) :: zqa, zta, zgamma, zdthv, ztv, zsstv ! local scalars - REAL(dp) :: ztptv + REAL(wp) :: zqa, zta, zgamma, zdthv, ztv, zsstv ! local scalars + REAL(wp) :: ztptv !!------------------------------------------------------------------- IF( PRESENT(pta_layer) .AND. PRESENT(pqa_layer) ) l_ptqa_l_prvd = .TRUE. ! @@ -599,13 +598,13 @@ CONTAINS FUNCTION Ri_bulk_vctr( pz, psst, ptha, pssq, pqa, pub, pta_layer, pqa_layer ) - REAL(dp), DIMENSION(jpi,jpj) :: Ri_bulk_vctr - REAL(dp) , INTENT(in) :: pz ! height above the sea (aka 4E64M09AJ) [m] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! SST [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ptha ! pot. air temp. at height 6PRR [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air spec. hum. at height KKA7 [kg/kg] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pub ! bulk wind speed [m/s] + REAL(wp), DIMENSION(jpi,jpj) :: Ri_bulk_vctr + REAL(wp) , INTENT(in) :: pz ! height above the sea (aka "delta z") [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! SST [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha ! pot. air temp. at height "pz" [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub ! bulk wind speed [m/s] REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] !! @@ -638,9 +637,9 @@ CONTAINS !! !! Note: what rt0 should be here, is 273.16 (triple point of water) and not 273.15 like here !!---------------------------------------------------------------------------------- - REAL(dp) :: e_sat_sclr ! water vapor at saturation [kg/kg] - REAL(dp), INTENT(in) :: ptak ! air temperature [K] - REAL(dp) :: zta, ztmp ! local scalar + REAL(wp) :: e_sat_sclr ! water vapor at saturation [kg/kg] + REAL(wp), INTENT(in) :: ptak ! air temperature [K] + REAL(wp) :: zta, ztmp ! local scalar !!---------------------------------------------------------------------------------- zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... ztmp = rt0 / zta !#LB: rt0 or rtt0 ???? (273.15 vs 273.16 ) @@ -653,11 +652,11 @@ CONTAINS END FUNCTION e_sat_sclr FUNCTION e_sat_vctr(ptak) - REAL(dp), DIMENSION(jpi,jpj) :: e_sat_vctr !: vapour pressure at saturation [Pa] + REAL(wp), DIMENSION(jpi,jpj) :: e_sat_vctr !: vapour pressure at saturation [Pa] REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: temperature (K) INTEGER :: ji, jj ! dummy loop indices DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - e_sat_vctr(ji,jj) =e_sat_sclr(CASTDP(ptak(ji,jj))) + e_sat_vctr(ji,jj) = e_sat_sclr(ptak(ji,jj)) END_2D END FUNCTION e_sat_vctr @@ -666,10 +665,10 @@ CONTAINS !!--------------------------------------------------------------------------------- !! Same as "e_sat" but over ice rather than water! !!--------------------------------------------------------------------------------- - REAL(dp) :: e_sat_ice_sclr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp) :: e_sat_ice_sclr !: vapour pressure at saturation in presence of ice [Pa] REAL(wp), INTENT(in) :: ptak !! - REAL(dp) :: zta, zle, ztmp + REAL(wp) :: zta, zle, ztmp !!--------------------------------------------------------------------------------- zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... ztmp = rtt0/zta @@ -682,7 +681,7 @@ CONTAINS FUNCTION e_sat_ice_vctr(ptak) !! Same as "e_sat" but over ice rather than water! - REAL(dp), DIMENSION(jpi,jpj) :: e_sat_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp), DIMENSION(jpi,jpj) :: e_sat_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak INTEGER :: ji, jj !!---------------------------------------------------------------------------------- @@ -699,21 +698,21 @@ CONTAINS !! Analytical exact formulation: double checked!!! !! => DOUBLE-check possible / finite-difference version with "./bin/test_phymbl.x" !!--------------------------------------------------------------------------------- - REAL(dp) :: de_sat_dt_ice_sclr !: [Pa/K] + REAL(wp) :: de_sat_dt_ice_sclr !: [Pa/K] REAL(wp), INTENT(in) :: ptak !! - REAL(dp) :: zta, zde + REAL(wp) :: zta, zde !!--------------------------------------------------------------------------------- zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... !! zde = -(rAg_i*rtt0)/(zta*zta) - rBg_i/(zta*LOG(10._wp)) - rCg_i/rtt0 !! - de_sat_dt_ice_sclr =LOG(10._wp) * zde * e_sat_ice_sclr(CASTSP(zta)) + de_sat_dt_ice_sclr = LOG(10._wp) * zde * e_sat_ice_sclr(zta) END FUNCTION de_sat_dt_ice_sclr FUNCTION de_sat_dt_ice_vctr(ptak) !! Same as "e_sat" but over ice rather than water! - REAL(dp), DIMENSION(jpi,jpj) :: de_sat_dt_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp), DIMENSION(jpi,jpj) :: de_sat_dt_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak INTEGER :: ji, jj !!---------------------------------------------------------------------------------- @@ -732,17 +731,17 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp) :: q_sat_sclr - REAL(dp), INTENT(in) :: pta !: absolute temperature of air [K] - REAL(dp), INTENT(in) :: ppa !: atmospheric pressure [Pa] + REAL(wp) :: q_sat_sclr + REAL(wp), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), INTENT(in) :: ppa !: atmospheric pressure [Pa] LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice - REAL(dp) :: ze_s + REAL(wp) :: ze_s LOGICAL :: lice !!---------------------------------------------------------------------------------- lice = .FALSE. IF( PRESENT(l_ice) ) lice = l_ice IF( lice ) THEN - ze_s =e_sat_ice( CASTSP(pta) ) + ze_s = e_sat_ice( pta ) ELSE ze_s = e_sat( pta ) ! Vapour pressure at saturation (Goff) : END IF @@ -752,9 +751,9 @@ CONTAINS FUNCTION q_sat_vctr( pta, ppa, l_ice ) - REAL(dp), DIMENSION(jpi,jpj) :: q_sat_vctr - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj) :: q_sat_vctr + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice LOGICAL :: lice INTEGER :: ji, jj @@ -775,10 +774,10 @@ CONTAINS !! Analytical exact formulation: double checked!!! !! => DOUBLE-check possible / finite-difference version with "./bin/test_phymbl.x" !!---------------------------------------------------------------------------------- - REAL(dp) :: dq_sat_dt_ice_sclr + REAL(wp) :: dq_sat_dt_ice_sclr REAL(wp), INTENT(in) :: pta !: absolute temperature of air [K] REAL(wp), INTENT(in) :: ppa !: atmospheric pressure [Pa] - REAL(dp) :: ze_s, zde_s_dt, ztmp + REAL(wp) :: ze_s, zde_s_dt, ztmp !!---------------------------------------------------------------------------------- ze_s = e_sat_ice_sclr( pta ) ! Vapour pressure at saturation in presence of ice (Goff) zde_s_dt = de_sat_dt_ice( pta ) @@ -791,7 +790,7 @@ CONTAINS FUNCTION dq_sat_dt_ice_vctr( pta, ppa ) - REAL(dp), DIMENSION(jpi,jpj) :: dq_sat_dt_ice_vctr + REAL(wp), DIMENSION(jpi,jpj) :: dq_sat_dt_ice_vctr REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K] REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] INTEGER :: ji, jj @@ -809,13 +808,13 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: q_air_rh - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: prha !: relative humidity [fraction, not %!!!] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: air temperature [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj) :: q_air_rh + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prha !: relative humidity [fraction, not %!!!] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: air temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: ze ! local scalar + REAL(wp) :: ze ! local scalar !!---------------------------------------------------------------------------------- ! DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -834,26 +833,26 @@ CONTAINS !! and the module of the wind stress => pTau = Tau !! ** Author: L. Brodeau, Sept. 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pust ! u* - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ptst ! t* - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqst ! q* - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: prlw ! downwelling longwave radiative flux [W/m^2] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! air density [kg/m3] + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pust ! u* + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptst ! t* + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqst ! q* + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prlw ! downwelling longwave radiative flux [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! air density [kg/m3] ! - REAL(dp), DIMENSION(jpi,jpj), INTENT(out) :: pQns ! non-solar heat flux to the ocean aka CTIV9F3QVOQ0PXWSD6M [W/m^2]] - REAL(dp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQns ! non-solar heat flux to the ocean aka "Qlat + Qsen + Qlw" [W/m^2]] + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2] ! - REAL(dp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(out) :: Qlat + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(out) :: Qlat ! - REAL(dp) :: zdt, zdq, zCd, zCh, zCe, zz0, zQlat, zQsen, zQlw + REAL(wp) :: zdt, zdq, zCd, zCh, zCe, zz0, zQlat, zQsen, zQlw INTEGER :: ji, jj ! dummy loop indices !!---------------------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -886,27 +885,27 @@ CONTAINS & pTau, pQsen, pQlat, & & pEvap, pfact_evap ) !!---------------------------------------------------------------------------------- - REAL(dp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) - REAL(dp), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] - REAL(dp), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] - REAL(dp), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] - REAL(dp), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] - REAL(dp), INTENT(in) :: pCd - REAL(dp), INTENT(in) :: pCh - REAL(dp), INTENT(in) :: pCe - REAL(dp), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] - REAL(dp), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] - REAL(dp), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] - REAL(dp), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3] + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), INTENT(in) :: pCd + REAL(wp), INTENT(in) :: pCh + REAL(wp), INTENT(in) :: pCe + REAL(wp), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3] !! - REAL(dp), INTENT(out) :: pTau ! module of the wind stress [N/m^2] - REAL(dp), INTENT(out) :: pQsen ! [W/m^2] - REAL(dp), INTENT(out) :: pQlat ! [W/m^2] + REAL(wp), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + REAL(wp), INTENT(out) :: pQsen ! [W/m^2] + REAL(wp), INTENT(out) :: pQlat ! [W/m^2] !! - REAL(dp), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] - REAL(dp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) + REAL(wp), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] + REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) !! - REAL(dp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap + REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap INTEGER :: jq !!---------------------------------------------------------------------------------- zfact_evap = 1._wp @@ -918,7 +917,7 @@ CONTAINS zevap = zUrho * pCe * (pqa - pqs) pQsen = zUrho * pCh * (pTa - pTs) * cp_air(pqa) - pQlat =L_vap(CASTSP(pTs)) * zevap + pQlat = L_vap(pTs) * zevap IF( PRESENT(pEvap) ) pEvap = - zfact_evap * zevap @@ -930,27 +929,27 @@ CONTAINS & pTau, pQsen, pQlat, & & pEvap, pfact_evap ) !!---------------------------------------------------------------------------------- - REAL(dp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pCd - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pCh - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pCe - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3] + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCh + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCe + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3] !! - REAL(dp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2] - REAL(dp), DIMENSION(jpi,jpj), INTENT(out) :: pQsen ! [W/m^2] - REAL(dp), DIMENSION(jpi,jpj), INTENT(out) :: pQlat ! [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQsen ! [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQlat ! [W/m^2] !! - REAL(dp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] - REAL(dp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) + REAL(wp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] + REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) !! - REAL(dp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap + REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap INTEGER :: ji, jj !!---------------------------------------------------------------------------------- zfact_evap = 1._wp @@ -978,7 +977,7 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: alpha_sw_vctr ! thermal expansion coefficient of sea-water [1/K] + REAL(wp), DIMENSION(jpi,jpj) :: alpha_sw_vctr ! thermal expansion coefficient of sea-water [1/K] REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K] !!---------------------------------------------------------------------------------- alpha_sw_vctr = 2.1e-5_wp * MAX(psst(:,:)-rt0 + 3.2_wp, 0._wp)**0.79 @@ -993,8 +992,8 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp) :: alpha_sw_sclr ! thermal expansion coefficient of sea-water [1/K] - REAL(dp), INTENT(in) :: psst ! sea-water temperature [K] + REAL(wp) :: alpha_sw_sclr ! thermal expansion coefficient of sea-water [1/K] + REAL(wp), INTENT(in) :: psst ! sea-water temperature [K] !!---------------------------------------------------------------------------------- alpha_sw_sclr = 2.1e-5_wp * MAX(psst-rt0 + 3.2_wp, 0._wp)**0.79 @@ -1007,11 +1006,11 @@ CONTAINS !! !! ** Purpose : Estimate of the net longwave flux at the surface !!---------------------------------------------------------------------------------- - REAL(dp) :: qlw_net_sclr - REAL(dp), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] - REAL(dp), INTENT(in) :: pts !: surface temperature [K] + REAL(wp) :: qlw_net_sclr + REAL(wp), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] + REAL(wp), INTENT(in) :: pts !: surface temperature [K] LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice - REAL(dp) :: zemiss, zt2 + REAL(wp) :: zemiss, zt2 LOGICAL :: lice !!---------------------------------------------------------------------------------- lice = .FALSE. @@ -1028,9 +1027,9 @@ CONTAINS FUNCTION qlw_net_vctr( pdwlw, pts, l_ice ) - REAL(dp), DIMENSION(jpi,jpj) :: qlw_net_vctr - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pts !: surface temperature [K] + REAL(wp), DIMENSION(jpi,jpj) :: qlw_net_vctr + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts !: surface temperature [K] LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice LOGICAL :: lice INTEGER :: ji, jj @@ -1046,10 +1045,10 @@ CONTAINS FUNCTION z0_from_Cd( pzu, pCd, ppsi ) - REAL(dp), DIMENSION(jpi,jpj) :: z0_from_Cd !: roughness length [m] + REAL(wp), DIMENSION(jpi,jpj) :: z0_from_Cd !: roughness length [m] REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: (neutral or non-neutral) drag coefficient [] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: GWERYF1H31L5WS stability correction profile for momentum [] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: (neutral or non-neutral) drag coefficient [] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] !! !! If pCd is the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given !! If pCd is the drag coefficient (in stable or unstable conditions) then pssi must be provided @@ -1067,9 +1066,9 @@ CONTAINS FUNCTION Cd_from_z0( pzu, pz0, ppsi ) - REAL(dp), DIMENSION(jpi,jpj) :: Cd_from_z0 !: (neutral or non-neutral) drag coefficient [] + REAL(wp), DIMENSION(jpi,jpj) :: Cd_from_z0 !: (neutral or non-neutral) drag coefficient [] REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length [m] REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] !! !! If we want to return the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given @@ -1092,13 +1091,13 @@ CONTAINS !! Stability correction function for MOMENTUM !! Louis (1979) !!---------------------------------------------------------------------------------- - REAL(dp) :: f_m_louis_sclr ! term ZJ1JU in Eq.(6) when option 5HTL6XY rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), + REAL(wp) :: f_m_louis_sclr ! term "f_m" in Eq.(6) when option "Louis" rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), REAL(wp), INTENT(in) :: pzu ! reference height (height for pwnd) [m] - REAL(dp), INTENT(in) :: pRib ! Bulk Richardson number - REAL(dp), INTENT(in) :: pCdn ! neutral drag coefficient - REAL(dp), INTENT(in) :: pz0 ! roughness length [m] + REAL(wp), INTENT(in) :: pRib ! Bulk Richardson number + REAL(wp), INTENT(in) :: pCdn ! neutral drag coefficient + REAL(wp), INTENT(in) :: pz0 ! roughness length [m] !!---------------------------------------------------------------------------------- - REAL(dp) :: ztu, zts, zstab + REAL(wp) :: ztu, zts, zstab !!---------------------------------------------------------------------------------- zstab = 0.5 + SIGN(0.5_wp, pRib) ; ! Unstable (Ri<0) => zstab = 0 | Stable (Ri>0) => zstab = 1 ! @@ -1112,11 +1111,11 @@ CONTAINS FUNCTION f_m_louis_vctr( pzu, pRib, pCdn, pz0 ) - REAL(dp), DIMENSION(jpi,jpj) :: f_m_louis_vctr + REAL(wp), DIMENSION(jpi,jpj) :: f_m_louis_vctr REAL(wp), INTENT(in) :: pzu - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pRib - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pCdn - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCdn + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 INTEGER :: ji, jj DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -1131,13 +1130,13 @@ CONTAINS !! Stability correction function for HEAT !! Louis (1979) !!---------------------------------------------------------------------------------- - REAL(dp) :: f_h_louis_sclr ! term TVIWW in Eq.(6) when option P7CAVL1 rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), + REAL(wp) :: f_h_louis_sclr ! term "f_h" in Eq.(6) when option "Louis" rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), REAL(wp), INTENT(in) :: pzu ! reference height (height for pwnd) [m] - REAL(dp), INTENT(in) :: pRib ! Bulk Richardson number - REAL(dp), INTENT(in) :: pChn ! neutral heat transfer coefficient - REAL(dp), INTENT(in) :: pz0 ! roughness length [m] + REAL(wp), INTENT(in) :: pRib ! Bulk Richardson number + REAL(wp), INTENT(in) :: pChn ! neutral heat transfer coefficient + REAL(wp), INTENT(in) :: pz0 ! roughness length [m] !!---------------------------------------------------------------------------------- - REAL(dp) :: ztu, zts, zstab + REAL(wp) :: ztu, zts, zstab !!---------------------------------------------------------------------------------- zstab = 0.5 + SIGN(0.5_wp, pRib) ; ! Unstable (Ri<0) => zstab = 0 | Stable (Ri>0) => zstab = 1 ! @@ -1151,11 +1150,11 @@ CONTAINS FUNCTION f_h_louis_vctr( pzu, pRib, pChn, pz0 ) - REAL(dp), DIMENSION(jpi,jpj) :: f_h_louis_vctr + REAL(wp), DIMENSION(jpi,jpj) :: f_h_louis_vctr REAL(wp), INTENT(in) :: pzu - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pRib - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pChn - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pChn + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 INTEGER :: ji, jj DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -1169,11 +1168,11 @@ CONTAINS !!---------------------------------------------------------------------------------- !! Provides the neutral-stability wind speed at 10 m !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: UN10_from_ustar !: neutral stability wind speed at 10m [m/s] - REAL(dp), INTENT(in) :: pzu !: measurement heigh of wind speed [m] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pUzu !: bulk wind speed at height pzu m [m/s] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: friction velocity [m/s] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: 7MJDGVTLB3U8GP stability correction profile for momentum [] + REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_ustar !: neutral stability wind speed at 10m [m/s] + REAL(wp), INTENT(in) :: pzu !: measurement heigh of wind speed [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUzu !: bulk wind speed at height pzu m [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] !!---------------------------------------------------------------------------------- UN10_from_ustar(:,:) = pUzu(:,:) - pus(:,:)/vkarmn * ( LOG(pzu/10._wp) - ppsi(:,:) ) !! @@ -1184,16 +1183,16 @@ CONTAINS !!---------------------------------------------------------------------------------- !! Provides the neutral-stability wind speed at 10 m !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: UN10_from_CD !: [m/s] - REAL(dp), INTENT(in) :: pzu !: measurement heigh of bulk wind speed - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pUb !: bulk wind speed at height pzu m [m/s] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: drag coefficient - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: 668DLZ06TEOGDU stability correction profile for momentum [] + REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_CD !: [m/s] + REAL(wp), INTENT(in) :: pzu !: measurement heigh of bulk wind speed + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb !: bulk wind speed at height pzu m [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: drag coefficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] !!---------------------------------------------------------------------------------- !! Reminder: UN10 = u*/vkarmn * log(10/z0) !! and: u* = sqrt(Cd) * Ub !! u*/vkarmn * log( 10 / z0 ) - UN10_from_CD(:,:) =SQRT(pCd(:,:))*pUb/vkarmn * LOG( 10._wp / z0_from_Cd( CASTSP(pzu), pCd(:,:), ppsi=ppsi(:,:) ) ) + UN10_from_CD(:,:) = SQRT(pCd(:,:))*pUb/vkarmn * LOG( 10._wp / z0_from_Cd( pzu, pCd(:,:), ppsi=ppsi(:,:) ) ) !! END FUNCTION UN10_from_CD @@ -1215,10 +1214,10 @@ CONTAINS !! !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: z0tq_LKB + REAL(wp), DIMENSION(jpi,jpj) :: z0tq_LKB INTEGER, INTENT(in) :: iflag !: 1 => dealing with temperature; 2 => dealing with humidity - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pRer !: roughness Reynolds number [z_0 u*]/Nu_{air} - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length (for momentum) [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRer !: roughness Reynolds number [z_0 u*]/Nu_{air} + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length (for momentum) [m] !------------------------------------------------------------------- ! Scalar Re_r relation from Liu et al. REAL(wp), DIMENSION(8,2), PARAMETER :: & @@ -1246,7 +1245,7 @@ CONTAINS !------------------------------------------------------------------- LOGICAL :: lfound=.FALSE. - REAL(dp) :: zrr + REAL(wp) :: zrr INTEGER :: ji, jj, jm z0tq_LKB(:,:) = -999._wp diff --git a/src/OCE/SBC/sbcapr.F90 b/src/OCE/SBC/sbcapr.F90 index 33d4f597297e252e55362ab1c7cab4badcfbb495..30af75b41c88295583637c32aa1888df80472487 100644 --- a/src/OCE/SBC/sbcapr.F90 +++ b/src/OCE/SBC/sbcapr.F90 @@ -28,14 +28,14 @@ MODULE sbcapr ! !!* namsbc_apr namelist (Atmospheric PRessure) * LOGICAL, PUBLIC :: ln_apr_obc = .false. !: inverse barometer added to OBC ssh data LOGICAL, PUBLIC :: ln_ref_apr !: ref. pressure: global mean Patm (F) or a constant (F) - REAL(dp) :: rn_pref ! reference atmospheric pressure [N/m2] + REAL(wp) :: rn_pref ! reference atmospheric pressure [N/m2] - REAL(dp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: ssh_ib ! Inverse barometer now sea surface height [m] - REAL(dp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: ssh_ibb ! Inverse barometer before sea surface height [m] - REAL(dp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: apr ! atmospheric pressure at kt [N/m2] + REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: ssh_ib ! Inverse barometer now sea surface height [m] + REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: ssh_ibb ! Inverse barometer before sea surface height [m] + REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: apr ! atmospheric pressure at kt [N/m2] - REAL(dp) :: tarea ! whole domain mean masked ocean surface - REAL(dp) :: r1_grau ! = 1.e0 / (grav * rho0) + REAL(wp) :: tarea ! whole domain mean masked ocean surface + REAL(wp) :: r1_grau ! = 1.e0 / (grav * rho0) TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_apr ! structure of input fields (file informations, fields read) diff --git a/src/OCE/SBC/sbcblk.F90 b/src/OCE/SBC/sbcblk.F90 index 3f0e48b9533f7444d958aa2701bd1b28472d47cd..cc57f53a912d68317c4f41a136557fa0eae092dd 100644 --- a/src/OCE/SBC/sbcblk.F90 +++ b/src/OCE/SBC/sbcblk.F90 @@ -107,24 +107,24 @@ MODULE sbcblk ! !#LB: LOGICAL :: ln_Cx_ice_cst ! use constant air-ice bulk transfer coefficients (value given in namelist's rn_Cd_i, rn_Ce_i & rn_Ch_i) - REAL(dp) :: rn_Cd_i, rn_Ce_i, rn_Ch_i ! values for IINAMZ + REAL(wp) :: rn_Cd_i, rn_Ce_i, rn_Ch_i ! values for " " LOGICAL :: ln_Cx_ice_AN05 ! air-ice bulk transfer coefficients based on Andreas et al., 2005 LOGICAL :: ln_Cx_ice_LU12 ! air-ice bulk transfer coefficients based on Lupkes et al., 2012 LOGICAL :: ln_Cx_ice_LG15 ! air-ice bulk transfer coefficients based on Lupkes & Gryanik, 2015 !#LB. ! LOGICAL :: ln_crt_fbk ! Add surface current feedback to the wind stress computation (Renault et al. 2020) - REAL(dp) :: rn_stau_a ! Alpha and Beta coefficients of Renault et al. 2020, eq. 10: Stau = Alpha * Wnd + Beta - REAL(dp) :: rn_stau_b ! + REAL(wp) :: rn_stau_a ! Alpha and Beta coefficients of Renault et al. 2020, eq. 10: Stau = Alpha * Wnd + Beta + REAL(wp) :: rn_stau_b ! ! - REAL(dp) :: rn_pfac ! multiplication factor for precipitation - REAL(dp), PUBLIC :: rn_efac ! multiplication factor for evaporation - REAL(dp) :: rn_zqt ! z(q,t) : height of humidity and temperature measurements - REAL(dp) :: rn_zu ! z(u) : height of wind measurements + REAL(wp) :: rn_pfac ! multiplication factor for precipitation + REAL(wp), PUBLIC :: rn_efac ! multiplication factor for evaporation + REAL(wp) :: rn_zqt ! z(q,t) : height of humidity and temperature measurements + REAL(wp) :: rn_zu ! z(u) : height of wind measurements ! INTEGER :: nn_iter_algo ! Number of iterations in bulk param. algo ("stable ABL + weak wind" requires more) - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: theta_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme) + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: theta_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme) #if defined key_si3 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: Cd_ice , Ch_ice , Ce_ice !#LB transfert coefficients over ice @@ -503,8 +503,8 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: kt ! ocean time step !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, zlat, zevp, zpre, ztheta - REAL(dp) :: ztst + REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, zlat, zevp, zpre, ztheta + REAL(wp) :: ztst LOGICAL :: llerr !!---------------------------------------------------------------------- ! @@ -630,39 +630,39 @@ CONTAINS !! - pevp : evaporation (mm/s) #lolo !!--------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! time step index - REAL(dp), INTENT(in ), DIMENSION(:,:) :: pwndi ! atmospheric wind at T-point [m/s] - REAL(dp), INTENT(in ), DIMENSION(:,:) :: pwndj ! atmospheric wind at T-point [m/s] - REAL(dp), INTENT(in ), DIMENSION(:,:) :: pqair ! specific humidity at T-points [kg/kg] - REAL(dp), INTENT(in ), DIMENSION(:,:) :: ptair ! potential temperature at T-points [Kelvin] - REAL(dp), INTENT(in ), DIMENSION(:,:) :: pslp ! sea-level pressure [Pa] - REAL(dp), INTENT(in ), DIMENSION(:,:) :: pst ! surface temperature [Celsius] - REAL(dp), INTENT(in ), DIMENSION(:,:) :: pu ! surface current at U-point (i-component) [m/s] - REAL(dp), INTENT(in ), DIMENSION(:,:) :: pv ! surface current at V-point (j-component) [m/s] - REAL(dp), INTENT(in ), DIMENSION(:,:) :: puatm ! surface current seen by the atm at T-point (i-component) [m/s] - REAL(dp), INTENT(in ), DIMENSION(:,:) :: pvatm ! surface current seen by the atm at T-point (j-component) [m/s] - REAL(dp), INTENT(in ), DIMENSION(:,:) :: pdqsr ! downwelling solar (shortwave) radiation at surface [W/m^2] - REAL(dp), INTENT(in ), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] - REAL(dp), INTENT( out), DIMENSION(:,:) :: ptsk ! skin temp. (or SST if CS & WL not used) [Celsius] - REAL(dp), INTENT( out), DIMENSION(:,:) :: pssq ! specific humidity at pst [kg/kg] - REAL(dp), INTENT( out), DIMENSION(:,:) :: pcd_du - REAL(dp), INTENT( out), DIMENSION(:,:) :: psen - REAL(dp), INTENT( out), DIMENSION(:,:) :: plat - REAL(dp), INTENT( out), DIMENSION(:,:) :: pevp + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndi ! atmospheric wind at T-point [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndj ! atmospheric wind at T-point [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pqair ! specific humidity at T-points [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: ptair ! potential temperature at T-points [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pslp ! sea-level pressure [Pa] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pst ! surface temperature [Celsius] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pu ! surface current at U-point (i-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pv ! surface current at V-point (j-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: puatm ! surface current seen by the atm at T-point (i-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pvatm ! surface current seen by the atm at T-point (j-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqsr ! downwelling solar (shortwave) radiation at surface [W/m^2] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] + REAL(wp), INTENT( out), DIMENSION(:,:) :: ptsk ! skin temp. (or SST if CS & WL not used) [Celsius] + REAL(wp), INTENT( out), DIMENSION(:,:) :: pssq ! specific humidity at pst [kg/kg] + REAL(wp), INTENT( out), DIMENSION(:,:) :: pcd_du + REAL(wp), INTENT( out), DIMENSION(:,:) :: psen + REAL(wp), INTENT( out), DIMENSION(:,:) :: plat + REAL(wp), INTENT( out), DIMENSION(:,:) :: pevp ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zztmp ! local variable - REAL(dp) :: zstmax, zstau + REAL(wp) :: zztmp ! local variable + REAL(wp) :: zstmax, zstau #if defined key_cyclone REAL(wp), DIMENSION(jpi,jpj) :: zwnd_i, zwnd_j ! wind speed components at T-point #endif - REAL(dp), DIMENSION(jpi,jpj) :: ztau_i, ztau_j ! wind stress components at T-point - REAL(dp), DIMENSION(jpi,jpj) :: zU_zu ! bulk wind speed at height zu [m/s] - REAL(dp), DIMENSION(jpi,jpj) :: zcd_oce ! momentum transfert coefficient over ocean - REAL(dp), DIMENSION(jpi,jpj) :: zch_oce ! sensible heat transfert coefficient over ocean - REAL(dp), DIMENSION(jpi,jpj) :: zce_oce ! latent heat transfert coefficient over ocean - REAL(dp), DIMENSION(jpi,jpj) :: zsspt ! potential sea-surface temperature [K] - REAL(dp), DIMENSION(jpi,jpj) :: zpre, ztabs ! air pressure [Pa] & absolute temperature [K] - REAL(dp), DIMENSION(jpi,jpj) :: zztmp1, zztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: ztau_i, ztau_j ! wind stress components at T-point + REAL(wp), DIMENSION(jpi,jpj) :: zU_zu ! bulk wind speed at height zu [m/s] + REAL(wp), DIMENSION(jpi,jpj) :: zcd_oce ! momentum transfert coefficient over ocean + REAL(wp), DIMENSION(jpi,jpj) :: zch_oce ! sensible heat transfert coefficient over ocean + REAL(wp), DIMENSION(jpi,jpj) :: zce_oce ! latent heat transfert coefficient over ocean + REAL(wp), DIMENSION(jpi,jpj) :: zsspt ! potential sea-surface temperature [K] + REAL(wp), DIMENSION(jpi,jpj) :: zpre, ztabs ! air pressure [Pa] & absolute temperature [K] + REAL(wp), DIMENSION(jpi,jpj) :: zztmp1, zztmp2 !!--------------------------------------------------------------------- ! ! local scalars ( place there for vector optimisation purposes) @@ -854,9 +854,9 @@ CONTAINS END_2D IF( ln_crt_fbk ) THEN - CALL lbc_lnk( 'sbcblk', utau, 'U', -1._dp, vtau, 'V', -1._dp, taum, 'T', 1._dp ) + CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp, taum, 'T', 1._wp ) ELSE - CALL lbc_lnk( 'sbcblk', utau, 'U', -1._dp, vtau, 'V', -1._dp ) + CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp ) ENDIF ! Saving open-ocean wind-stress (module and components) on T-points: @@ -865,13 +865,13 @@ CONTAINS CALL iom_put( "utau_oce", ztau_i(:,:)*tmask(:,:,1) ) ! utau at T-points! CALL iom_put( "vtau_oce", ztau_j(:,:)*tmask(:,:,1) ) ! vtau at T-points! - IF(sn_cfctl%l_prtctl) THEN + ! IF(sn_cfctl%l_prtctl) THEN !CALL prt_ctl( tab2d_1=pssq , clinfo1=' blk_oce_1: pssq : ') !CALL prt_ctl( tab2d_1=wndm , clinfo1=' blk_oce_1: wndm : ') !CALL prt_ctl( tab2d_1=utau , clinfo1=' blk_oce_1: utau : ', mask1=umask, & - ! & tab2d_2=vtau , clinfo2=' vtau : ', mask2=vmask ) + ! & tab2d_2=vtau , clinfo2=' vtau : ', mask2=vmask ) !CALL prt_ctl( tab2d_1=zcd_oce, clinfo1=' blk_oce_1: Cd : ') - ENDIF + ! ENDIF ! ENDIF ! ln_blk / ln_abl @@ -902,19 +902,19 @@ CONTAINS !! - qns : Non Solar heat flux over the ocean (W/m2) !! - emp : evaporation minus precipitation (kg/m2/s) !!--------------------------------------------------------------------- - REAL(dp), INTENT(in), DIMENSION(:,:) :: ptair ! potential temperature of air #LB: confirm! - REAL(dp), INTENT(in), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] - REAL(dp), INTENT(in), DIMENSION(:,:) :: pprec - REAL(dp), INTENT(in), DIMENSION(:,:) :: psnow - REAL(dp), INTENT(in), DIMENSION(:,:) :: ptsk ! SKIN surface temperature [Celsius] - REAL(dp), INTENT(in), DIMENSION(:,:) :: psen - REAL(dp), INTENT(in), DIMENSION(:,:) :: plat - REAL(dp), INTENT(in), DIMENSION(:,:) :: pevp + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptair ! potential temperature of air #LB: confirm! + REAL(wp), INTENT(in), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] + REAL(wp), INTENT(in), DIMENSION(:,:) :: pprec + REAL(wp), INTENT(in), DIMENSION(:,:) :: psnow + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptsk ! SKIN surface temperature [Celsius] + REAL(wp), INTENT(in), DIMENSION(:,:) :: psen + REAL(wp), INTENT(in), DIMENSION(:,:) :: plat + REAL(wp), INTENT(in), DIMENSION(:,:) :: pevp ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zztmp,zz1,zz2,zz3 ! local variable - REAL(dp), DIMENSION(jpi,jpj) :: zqlw ! net long wave radiative heat flux - REAL(dp), DIMENSION(jpi,jpj) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg) + REAL(wp) :: zztmp,zz1,zz2,zz3 ! local variable + REAL(wp), DIMENSION(jpi,jpj) :: zqlw ! net long wave radiative heat flux + REAL(wp), DIMENSION(jpi,jpj) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg) !!--------------------------------------------------------------------- ! ! Heat content per unit mass (J/kg) @@ -964,13 +964,13 @@ CONTAINS CALL iom_put( "qt_oce" , qns+qsr ) ! output total downward heat over the ocean ENDIF ! - IF(sn_cfctl%l_prtctl) THEN + ! IF(sn_cfctl%l_prtctl) THEN !CALL prt_ctl(tab2d_1=zqlw , clinfo1=' blk_oce_2: zqlw : ') !CALL prt_ctl(tab2d_1=psen , clinfo1=' blk_oce_2: psen : ' ) !CALL prt_ctl(tab2d_1=plat , clinfo1=' blk_oce_2: plat : ' ) !CALL prt_ctl(tab2d_1=qns , clinfo1=' blk_oce_2: qns : ' ) !CALL prt_ctl(tab2d_1=emp , clinfo1=' blk_oce_2: emp : ') - ENDIF + ! ENDIF ! END SUBROUTINE blk_oce_2 @@ -1092,8 +1092,8 @@ CONTAINS END_2D CALL lbc_lnk( 'sbcblk', putaui, 'U', -1._wp, pvtaui, 'V', -1._wp ) ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=putaui , clinfo1=' blk_ice: putaui : ' & - ! & , tab2d_2=pvtaui , clinfo2=' pvtaui : ' ) + ! IF(sn_cfctl%l_prtctl) !CALL prt_ctl( tab2d_1=putaui , clinfo1=' blk_ice: putaui : ' & + ! & , tab2d_2=pvtaui , clinfo2=' pvtaui : ' ) ELSE ! ln_abl DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -1105,7 +1105,7 @@ CONTAINS ENDIF ! ln_blk / ln_abl ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl(tab2d_1=wndm_ice , clinfo1=' blk_ice: wndm_ice : ') + !IF(sn_cfctl%l_prtctl) !CALL prt_ctl(tab2d_1=wndm_ice , clinfo1=' blk_ice: wndm_ice : ') ! END SUBROUTINE blk_ice_1 @@ -1300,14 +1300,14 @@ CONTAINS CALL iom_put( 'hflx_subl_cea', SUM( a_i_b(:,:,:) * qevap_ice(:,:,:), dim=3 ) * tmask(:,:,1) ) ! Heat flux from sublimation (cell average) ENDIF ! - IF(sn_cfctl%l_prtctl) THEN + ! IF(sn_cfctl%l_prtctl) THEN !CALL prt_ctl(tab3d_1=qla_ice , clinfo1=' blk_ice: qla_ice : ', tab3d_2=z_qsb , clinfo2=' z_qsb : ', kdim=jpl) !CALL prt_ctl(tab3d_1=z_qlw , clinfo1=' blk_ice: z_qlw : ', tab3d_2=dqla_ice, clinfo2=' dqla_ice : ', kdim=jpl) !CALL prt_ctl(tab3d_1=z_dqsb , clinfo1=' blk_ice: z_dqsb : ', tab3d_2=z_dqlw , clinfo2=' z_dqlw : ', kdim=jpl) !CALL prt_ctl(tab3d_1=dqns_ice, clinfo1=' blk_ice: dqns_ice : ', tab3d_2=qsr_ice , clinfo2=' qsr_ice : ', kdim=jpl) !CALL prt_ctl(tab3d_1=ptsu , clinfo1=' blk_ice: ptsu : ', tab3d_2=qns_ice , clinfo2=' qns_ice : ', kdim=jpl) !CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice: tprecip : ', tab2d_2=sprecip , clinfo2=' sprecip : ') - ENDIF + ! ENDIF !#LB: ! air-ice heat flux components that are not written from ice_stp()@icestp.F90: @@ -1414,4 +1414,4 @@ CONTAINS #endif !!====================================================================== -END MODULE sbcblk +END MODULE sbcblk \ No newline at end of file diff --git a/src/OCE/SBC/sbcblk_algo_andreas.F90 b/src/OCE/SBC/sbcblk_algo_andreas.F90 index dbc4613747c5234d03880a5467058de41da244ce..c8fa35b2720ccbea9ee5e97aca41dbf89043eb4f 100644 --- a/src/OCE/SBC/sbcblk_algo_andreas.F90 +++ b/src/OCE/SBC/sbcblk_algo_andreas.F90 @@ -47,7 +47,6 @@ MODULE sbcblk_algo_andreas PUBLIC :: TURB_ANDREAS, psi_m_andreas, psi_h_andreas !! * Substitutions -# include "single_precision_substitute.h90" # include "do_loop_substitute.h90" !!---------------------------------------------------------------------- @@ -86,34 +85,34 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(dp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] ! INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN ! INTEGER :: nbit, jit ! iterations... LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U !! - REAL(dp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star - REAL(dp), DIMENSION(jpi,jpj) :: z0 ! roughness length (momentum) [m] - REAL(dp), DIMENSION(jpi,jpj) :: UN10 ! Neutral wind speed at zu [m/s] - REAL(dp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu - REAL(dp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 - REAL(dp), DIMENSION(jpi,jpj) :: RiB ! square root of Cd + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: z0 ! roughness length (momentum) [m] + REAL(wp), DIMENSION(jpi,jpj) :: UN10 ! Neutral wind speed at zu [m/s] + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: RiB ! square root of Cd !! !!---------------------------------------------------------------------------------- nbit = nb_iter0 @@ -162,7 +161,7 @@ CONTAINS Cd = MAX( ztmp0*ztmp0 , Cx_min ) !! Roughness length: - z0 =MIN( z0_from_Cd( CASTSP(zu), Cd, ppsi=psi_m_andreas(zeta_u) ) , z0_sea_max ) + z0 = MIN( z0_from_Cd( zu, Cd, ppsi=psi_m_andreas(zeta_u) ) , z0_sea_max ) !! z0t and z0q, based on LKB, just like into COARE 2.5: ztmp0 = z0 * u_star / visc_air(t_zu) ! Re_r @@ -218,11 +217,11 @@ CONTAINS !! !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pun10 !: neutral-stability scalar wind speed at 10m (m/s) - REAL(dp), DIMENSION(jpi,jpj) :: u_star_andreas !: friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pun10 !: neutral-stability scalar wind speed at 10m (m/s) + REAL(wp), DIMENSION(jpi,jpj) :: u_star_andreas !: friction velocity [m/s] ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: za, zt, zw ! local scalars + REAL(wp) :: za, zt, zw ! local scalars !!---------------------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) zw = pun10(ji,jj) @@ -244,8 +243,8 @@ CONTAINS !! !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_m_andreas - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_andreas + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! REAL(wp), PARAMETER :: zam = 5._wp ! a_m (just below Eq.(9b) REAL(wp), PARAMETER :: zbm = zam/6.5_wp ! b_m (just below Eq.(9b) @@ -254,7 +253,7 @@ CONTAINS REAL(wp), PARAMETER :: zsr3 = SQRT(3._wp) ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zx2, zx, zpsi_unst, zbbm, zpsi_stab, zstab ! local scalars + REAL(wp) :: zta, zx2, zx, zpsi_unst, zbbm, zpsi_stab, zstab ! local scalars !!---------------------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! @@ -299,8 +298,8 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_h_andreas - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_andreas + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! REAL(wp), PARAMETER :: zah = 5._wp ! a_h (just below Eq.(9b) REAL(wp), PARAMETER :: zbh = 5._wp ! b_h (just below Eq.(9b) @@ -308,7 +307,7 @@ CONTAINS REAL(wp), PARAMETER :: zbbh = SQRT(5._wp) ! B_h (just below Eq.(13) ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zz, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars + REAL(wp) :: zta, zz, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars !!---------------------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! diff --git a/src/OCE/SBC/sbcblk_algo_coare3p0.F90 b/src/OCE/SBC/sbcblk_algo_coare3p0.F90 index 380875cf503ed3f163bcbd0f40a28e38f1fedd16..55a398309be314008803dcdb1d9b7f3fa398a308 100644 --- a/src/OCE/SBC/sbcblk_algo_coare3p0.F90 +++ b/src/OCE/SBC/sbcblk_algo_coare3p0.F90 @@ -152,46 +152,46 @@ CONTAINS !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- INTEGER, INTENT(in ) :: kt ! current time step - REAL(dp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(dp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(dp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(dp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] ! INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen - REAL(dp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] - REAL(dp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] - REAL(dp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] ! INTEGER :: nbit, jit LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U ! - REAL(dp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star - REAL(dp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu - REAL(dp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air - REAL(dp), DIMENSION(jpi,jpj) :: z0, z0t - REAL(dp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu - REAL(dp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 - REAL(dp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu + REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] ! - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST ! CHARACTER(len=40), PARAMETER :: crtnm = 'turb_coare3p0@sbcblk_algo_coare3p0' !!---------------------------------------------------------------------------------- @@ -392,11 +392,11 @@ CONTAINS !! !! Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: charn_coare3p0 - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed + REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p0 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zw, zgt10, zgt18 + REAL(wp) :: zw, zgt10, zgt18 !!------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! @@ -426,11 +426,11 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_m_coare - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab !!---------------------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! @@ -474,11 +474,11 @@ CONTAINS !! Author: L. Brodeau, June 2016 / AeroBulk !! (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_h_coare - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab !!---------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! diff --git a/src/OCE/SBC/sbcblk_algo_coare3p6.F90 b/src/OCE/SBC/sbcblk_algo_coare3p6.F90 index 15270fc8f1bc1d89c5392d9dcc188add1f2393d6..171d6578efa4374cc2a05b0075e846aa11e927dd 100644 --- a/src/OCE/SBC/sbcblk_algo_coare3p6.F90 +++ b/src/OCE/SBC/sbcblk_algo_coare3p6.F90 @@ -142,46 +142,46 @@ CONTAINS !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- INTEGER, INTENT(in ) :: kt ! current time step - REAL(dp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(dp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(dp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(dp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] ! INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen - REAL(dp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] - REAL(dp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] - REAL(dp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] ! INTEGER :: nbit, jit LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U ! - REAL(dp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star - REAL(dp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu - REAL(dp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air - REAL(dp), DIMENSION(jpi,jpj) :: z0, z0t - REAL(dp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu - REAL(dp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 - REAL(dp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu + REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] ! - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST ! CHARACTER(len=40), PARAMETER :: crtnm = 'turb_coare3p6@sbcblk_algo_coare3p6' !!---------------------------------------------------------------------------------- @@ -378,8 +378,8 @@ CONTAINS !! !! Author: L. Brodeau, July 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: charn_coare3p6 - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! neutral wind speed at 10m + REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! neutral wind speed at 10m ! REAL(wp), PARAMETER :: charn0_max = 0.028 !: value above which the Charnock parameter levels off for winds > 18 m/s !!------------------------------------------------------------------- @@ -395,7 +395,7 @@ CONTAINS !! !! Author: L. Brodeau, October 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: charn_coare3p6_wave + REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6_wave REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! friction velocity [m/s] REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwsh ! significant wave height [m] REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwps ! phase speed of dominant waves [m/s] @@ -418,11 +418,11 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_m_coare - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab !!---------------------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! @@ -466,11 +466,11 @@ CONTAINS !! Author: L. Brodeau, June 2016 / AeroBulk !! (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_h_coare - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab !!---------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! diff --git a/src/OCE/SBC/sbcblk_algo_ecmwf.F90 b/src/OCE/SBC/sbcblk_algo_ecmwf.F90 index dc616dd4d756f9d7dd16f5fc030c3a87613299dd..2a37be0092bd0c04bd6d093ed2d5c46612fddf2f 100644 --- a/src/OCE/SBC/sbcblk_algo_ecmwf.F90 +++ b/src/OCE/SBC/sbcblk_algo_ecmwf.F90 @@ -48,7 +48,6 @@ MODULE sbcblk_algo_ecmwf REAL(wp), PARAMETER :: alpha_Q = 0.62 ! !! * Substitutions -# include "single_precision_substitute.h90" # include "do_loop_substitute.h90" !!---------------------------------------------------------------------- @@ -149,47 +148,47 @@ CONTAINS !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- INTEGER, INTENT(in ) :: kt ! current time step - REAL(dp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(dp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(dp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(dp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] ! INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen - REAL(dp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] - REAL(dp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] - REAL(dp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] ! INTEGER :: nbit, jit LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U ! - REAL(dp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star - REAL(dp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu - REAL(dp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air - REAL(dp), DIMENSION(jpi,jpj) :: Linv !: 1/L (inverse of Monin Obukhov length... - REAL(dp), DIMENSION(jpi,jpj) :: z0, z0t, z0q - REAL(dp), DIMENSION(jpi,jpj) :: zrhoa, zpre, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu + REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(jpi,jpj) :: Linv !: 1/L (inverse of Monin Obukhov length... + REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t, z0q + REAL(wp), DIMENSION(jpi,jpj) :: zrhoa, zpre, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] ! - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST ! - REAL(dp), DIMENSION(jpi,jpj) :: func_m, func_h - REAL(dp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: func_m, func_h + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ecmwf@sbcblk_algo_ecmwf.F90' !!---------------------------------------------------------------------------------- IF( kt == nit000 ) CALL SBCBLK_ALGO_ECMWF_INIT(l_use_cs, l_use_wl) @@ -210,7 +209,7 @@ CONTAINS ALLOCATE ( zsst(jpi,jpj) ) zsst = T_s ! backing up the bulk SST IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction - q_s =rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), CASTDP(slp)) ! First guess of q_s + q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s ENDIF @@ -349,33 +348,33 @@ CONTAINS func_h = log(zu) - LOG(z0t) - psi_h_ecmwf(ztmp0) + psi_h_ecmwf(z0t*Linv) IF(( l_use_cs ).OR.( l_use_wl )) THEN - zpre(:,:) =pres_temp( q_zu(:,:), CASTDP(slp(:,:)), CASTDP(zu), ptpot=t_zu(:,:), pta=zta(:,:) ) + zpre(:,:) = pres_temp( q_zu(:,:), slp(:,:), zu, ptpot=t_zu(:,:), pta=zta(:,:) ) zrhoa(:,:) = rho_air( zta(:,:), q_zu(:,:), zpre(:,:) ) ENDIF IF( l_use_cs ) THEN !! Cool-skin contribution - CALL UPDATE_QNSOL_TAU( CASTDP(zu), T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, CASTDP(U_zu), Ubzu, CASTDP(slp), CASTDP(rad_lw), zrhoa, & + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & & ztmp1, ztmp0, Qlat=ztmp2) ! Qnsol -> ztmp1 / Tau -> ztmp0 CALL CS_ECMWF( Qsw, ztmp1, u_star, zsst ) ! Qnsol -> ztmp1 T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1) IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) - q_s(:,:) =rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), CASTDP(slp(:,:))) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) ENDIF IF( l_use_wl ) THEN !! Warm-layer contribution - CALL UPDATE_QNSOL_TAU( CASTDP(zu), T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, CASTDP(U_zu), Ubzu, CASTDP(slp), CASTDP(rad_lw), zrhoa, & + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & & ztmp1, ztmp2) ! Qnsol -> ztmp1 / Tau -> ztmp2 CALL WL_ECMWF( Qsw, ztmp1, u_star, zsst ) !! Updating T_s and q_s !!! T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1) ! IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1) - q_s(:,:) =rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), CASTDP(slp(:,:))) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) ENDIF IF( l_use_cs .OR. l_use_wl .OR. (.NOT. l_zt_equal_zu) ) THEN @@ -414,11 +413,11 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_m_ecmwf - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ecmwf + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zx2, zx, ztmp, zpsi_unst, zpsi_stab, zstab, zc + REAL(wp) :: zta, zx2, zx, ztmp, zpsi_unst, zpsi_stab, zstab, zc !!---------------------------------------------------------------------------------- zc = 5._wp/0.35_wp DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -455,11 +454,11 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_h_ecmwf - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ecmwf + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab, zc + REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab, zc !!---------------------------------------------------------------------------------- zc = 5._wp/0.35_wp ! diff --git a/src/OCE/SBC/sbcblk_algo_ice_an05.F90 b/src/OCE/SBC/sbcblk_algo_ice_an05.F90 index a4fde8893380da11247550e97882a6c68ad797a4..287277b002645e2199424099c3c1bfff1a6d6875 100644 --- a/src/OCE/SBC/sbcblk_algo_ice_an05.F90 +++ b/src/OCE/SBC/sbcblk_algo_ice_an05.F90 @@ -86,27 +86,27 @@ CONTAINS REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] !!---------------------------------------------------------------------------------- - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: Ubzu - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: ztmp0, ztmp1, ztmp2 ! temporary stuff - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: z0, dt_zu, dq_zu - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: u_star, t_star, q_star - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: znu_a !: Nu_air = kinematic viscosity of air - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zeta_u, zeta_t ! stability parameter at height zu - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z0tq + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp0, ztmp1, ztmp2 ! temporary stuff + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: z0, dt_zu, dq_zu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: u_star, t_star, q_star + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: znu_a !: Nu_air = kinematic viscosity of air + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_u, zeta_t ! stability parameter at height zu + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: z0tq !! INTEGER :: jit LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U @@ -227,12 +227,12 @@ CONTAINS !! !! Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: rough_leng_m ! roughness length over sea-ice [m] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] + REAL(wp), DIMENSION(jpi,jpj) :: rough_leng_m ! roughness length over sea-ice [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] !! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zus, zz + REAL(wp) :: zus, zz !!---------------------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) zus = MAX( pus(ji,jj) , 1.E-9_wp ) @@ -251,14 +251,14 @@ CONTAINS !! !! Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj,2) :: rough_leng_tq ! temp.,hum. roughness lengthes over sea-ice [m] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 ! roughness length [m] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] + REAL(wp), DIMENSION(jpi,jpj,2) :: rough_leng_tq ! temp.,hum. roughness lengthes over sea-ice [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 ! roughness length [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] !! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zz0, zus, zre, zsmoot, ztrans, zrough - REAL(dp) :: zb0, zb1, zb2, zlog, zlog2, zlog_z0s_on_z0 + REAL(wp) :: zz0, zus, zre, zsmoot, ztrans, zrough + REAL(wp) :: zb0, zb1, zb2, zlog, zlog2, zlog_z0s_on_z0 !!---------------------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) zz0 = pz0(ji,jj) @@ -315,11 +315,11 @@ CONTAINS !! !! ** Author: L. Brodeau, 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_m_ice - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ice + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zx, zpsi_u, zpsi_s, zstab + REAL(wp) :: zta, zx, zpsi_u, zpsi_s, zstab !!---------------------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! zta = pzeta(ji,jj) @@ -360,11 +360,11 @@ CONTAINS !! !! ** Author: L. Brodeau, 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_h_ice - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ice + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zx, zpsi_u, zpsi_s, zstab + REAL(wp) :: zta, zx, zpsi_u, zpsi_s, zstab !!---------------------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! zta = pzeta(ji,jj) diff --git a/src/OCE/SBC/sbcblk_algo_ice_cdn.F90 b/src/OCE/SBC/sbcblk_algo_ice_cdn.F90 index a1a5c2938939fe984121cf6e52a0926142a8f6e4..f57e7af3119e3c88076abe831f03c1bf60dbfca1 100644 --- a/src/OCE/SBC/sbcblk_algo_ice_cdn.F90 +++ b/src/OCE/SBC/sbcblk_algo_ice_cdn.F90 @@ -59,7 +59,7 @@ CONTAINS !! ** References : Lupkes et al. JGR 2012 (theory) !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: CdN10_f_LU12 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), DIMENSION(jpi,jpj) :: CdN10_f_LU12 ! neutral FORM drag coefficient contribution over sea-ice REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc, phf and pDi all provided... REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0w ! roughness length over water [m] REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pSc ! shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances) @@ -67,7 +67,7 @@ CONTAINS REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m] !!---------------------------------------------------------------------- LOGICAL :: l_known_Sc=.FALSE., l_known_hf=.FALSE., l_known_Di=.FALSE. - REAL(dp) :: ztmp, zrlog, zfri, zfrw, zSc, zhf, zDi + REAL(wp) :: ztmp, zrlog, zfri, zfrw, zSc, zhf, zDi INTEGER :: ji, jj !!---------------------------------------------------------------------- l_known_Sc = PRESENT(pSc) @@ -113,11 +113,11 @@ CONTAINS FUNCTION CdN_f_LU12_eq36( pzu, pfrice ) !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: CdN_f_LU12_eq36 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LU12_eq36 ! neutral FORM drag coefficient contribution over sea-ice REAL(wp), INTENT(in) :: pzu ! reference height [m] REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc, phf and pDi all provided... !!---------------------------------------------------------------------- - REAL(dp) :: ztmp, zrlog, zfri, zhf, zDi + REAL(wp) :: ztmp, zrlog, zfri, zhf, zDi INTEGER :: ji, jj !!---------------------------------------------------------------------- !zhf = 0.28 ! h_fc @@ -167,11 +167,11 @@ CONTAINS !! Lupkes et al. GRL 2013 (application to GCM) !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: CdN10_f_LU13 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), DIMENSION(jpi,jpj) :: CdN10_f_LU13 ! neutral FORM drag coefficient contribution over sea-ice REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b !!---------------------------------------------------------------------- INTEGER :: ji, jj - REAL(dp) :: zcoef + REAL(wp) :: zcoef !!---------------------------------------------------------------------- zcoef = rNu_0 + 1._wp / ( 10._wp * rBeta_0 ) @@ -203,16 +203,16 @@ CONTAINS !! ** References : Lupkes & Gryanik (2015) !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: CdN_f_LG15 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LG15 ! neutral FORM drag coefficient contribution over sea-ice REAL(wp), INTENT(in ) :: pzu ! reference height [m] REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc, phf and pDi all provided... - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pz0i ! roughness length over ICE [m] (in LU12, it's over water ???) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0i ! roughness length over ICE [m] (in LU12, it's over water ???) REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pSc ! shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances) REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m] REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m] !!---------------------------------------------------------------------- LOGICAL :: l_known_Sc=.FALSE., l_known_hf=.FALSE., l_known_Di=.FALSE. - REAL(dp) :: ztmp, zrlog, zfri, zfrw, zSc, zhf, zDi + REAL(wp) :: ztmp, zrlog, zfri, zfrw, zSc, zhf, zDi INTEGER :: ji, jj !!---------------------------------------------------------------------- l_known_Sc = PRESENT(pSc) @@ -270,12 +270,12 @@ CONTAINS !! ** References : Lupkes & Gryanik (2015) !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: CdN_f_LG15_light ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LG15_light ! neutral FORM drag coefficient contribution over sea-ice REAL(wp), INTENT(in) :: pzu ! reference height [m] REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pz0w ! roughness length over water [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0w ! roughness length over water [m] !!---------------------------------------------------------------------- - REAL(dp) :: ztmp, zrlog, zfri + REAL(wp) :: ztmp, zrlog, zfri INTEGER :: ji, jj !!---------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) diff --git a/src/OCE/SBC/sbcblk_algo_ice_lg15.F90 b/src/OCE/SBC/sbcblk_algo_ice_lg15.F90 index 79b4b5247af6f53dc12bb616797973a7dc13779c..550d2e71fdcf5b2510172ff749e478b32452a9f1 100644 --- a/src/OCE/SBC/sbcblk_algo_ice_lg15.F90 +++ b/src/OCE/SBC/sbcblk_algo_ice_lg15.F90 @@ -43,8 +43,6 @@ MODULE sbcblk_algo_ice_lg15 INTEGER , PARAMETER :: nbit = 8 ! number of itterations !!---------------------------------------------------------------------- -# include "single_precision_substitute.h90" -# include "single_precision_substitute.h90" CONTAINS SUBROUTINE turb_ice_lg15( zt, zu, Ts_i, t_zt, qs_i, q_zt, U_zu, frice, & @@ -102,25 +100,25 @@ CONTAINS REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: frice ! sea-ice concentration (fraction) - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] !!---------------------------------------------------------------------------------- - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: Ubzu - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: ztmp1, ztmp2 ! temporary stuff - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dt_zu, dq_zu - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zz0_s, zz0_f, RiB ! third dimensions (size=2): - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zCdN_s, zChN_s, zCdN_f, zChN_f + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp1, ztmp2 ! temporary stuff + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dt_zu, dq_zu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zz0_s, zz0_f, RiB ! third dimensions (size=2): + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zCdN_s, zChN_s, zCdN_f, zChN_f !! INTEGER :: jit LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U @@ -180,7 +178,7 @@ CONTAINS !! Some other first guess values, needed to compute wind at zt: Cd_i(:,:) = zCdN_s(:,:) + zCdN_f(:,:) Ch_i(:,:) = zChN_s(:,:) + zChN_f(:,:) - RiB(:,:) =Ri_bulk( CASTDP(zt), CASTDP(Ts_i(:,:)), CASTDP(t_zt(:,:)), CASTDP(qs_i(:,:)), CASTDP(q_zt(:,:)), Ubzu(:,:) ) ! over ice (index=1) + RiB(:,:) = Ri_bulk( zt, Ts_i(:,:), t_zt(:,:), qs_i(:,:), q_zt(:,:), Ubzu(:,:) ) ! over ice (index=1) !! ITERATION BLOCK @@ -208,7 +206,7 @@ CONTAINS ELSE ztmp2(:,:) = Ubzu(:,:) END IF - RiB(:,:) =Ri_bulk( CASTDP(zt), CASTDP(Ts_i(:,:)), CASTDP(t_zt(:,:)), CASTDP(qs_i(:,:)), CASTDP(q_zt(:,:)), ztmp2(:,:) ) ! over ice (index=1) + RiB(:,:) = Ri_bulk( zt, Ts_i(:,:), t_zt(:,:), qs_i(:,:), q_zt(:,:), ztmp2(:,:) ) ! over ice (index=1) IF(l_dbg_print) PRINT *, 'LOLO: RiB_zt =', RiB(:,:) diff --git a/src/OCE/SBC/sbcblk_algo_ice_lu12.F90 b/src/OCE/SBC/sbcblk_algo_ice_lu12.F90 index 9f234d7ab69e2c07ac11299b9747d9f9afae710c..d69076fbccf7fed4225ebbf8ae51ecfea3c7d278 100644 --- a/src/OCE/SBC/sbcblk_algo_ice_lu12.F90 +++ b/src/OCE/SBC/sbcblk_algo_ice_lu12.F90 @@ -87,22 +87,22 @@ CONTAINS REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: frice ! sea-ice concentration (fraction) - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] - REAL(dp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] !!---------------------------------------------------------------------------------- - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) - REAL(dp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dt_zu, dq_zu, z0 - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: Ubzu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dt_zu, dq_zu, z0 + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu !! LOGICAL :: lreturn_cdn=.FALSE., lreturn_chn=.FALSE., lreturn_cen=.FALSE. LOGICAL :: lreturn_z0=.FALSE., lreturn_ustar=.FALSE., lreturn_L=.FALSE., lreturn_UN10=.FALSE. diff --git a/src/OCE/SBC/sbcblk_algo_ncar.F90 b/src/OCE/SBC/sbcblk_algo_ncar.F90 index 05babbb009937a98f61a9421a406df0050c3247b..27bd7466eefb9a652f0377df39960d3d0ca9f7d0 100644 --- a/src/OCE/SBC/sbcblk_algo_ncar.F90 +++ b/src/OCE/SBC/sbcblk_algo_ncar.F90 @@ -79,32 +79,32 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] - REAL(dp), INTENT(in ) :: zu ! height for U_zu [m] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] - REAL(dp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] - REAL(dp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] ! INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN - REAL(dp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN ! INTEGER :: nbit, jit ! iterations... LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U ! - REAL(dp), DIMENSION(jpi,jpj) :: zCdN, zCeN, zChN ! 10m neutral latent/sensible coefficient - REAL(dp), DIMENSION(jpi,jpj) :: zsqrt_Cd, zsqrt_CdN ! root square of Cd and Cd_neutral - REAL(dp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu - REAL(dp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: zCdN, zCeN, zChN ! 10m neutral latent/sensible coefficient + REAL(wp), DIMENSION(jpi,jpj) :: zsqrt_Cd, zsqrt_CdN ! root square of Cd and Cd_neutral + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 !!---------------------------------------------------------------------------------- nbit = nb_iter0 IF( PRESENT(nb_iter) ) nbit = nb_iter @@ -231,11 +231,11 @@ CONTAINS !! !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pw10 ! scalar wind speed at 10m (m/s) - REAL(dp), DIMENSION(jpi,jpj) :: cd_n10_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pw10 ! scalar wind speed at 10m (m/s) + REAL(wp), DIMENSION(jpi,jpj) :: cd_n10_ncar ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zgt33, zw, zw6 ! local scalars + REAL(wp) :: zgt33, zw, zw6 ! local scalars !!---------------------------------------------------------------------------------- ! DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -264,9 +264,9 @@ CONTAINS !! Origin: Large & Yeager 2008, Eq. (9) and (12) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: ch_n10_ncar - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pstab ! stable ABL => 1 / unstable ABL => 0 + REAL(wp), DIMENSION(jpi,jpj) :: ch_n10_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pstab ! stable ABL => 1 / unstable ABL => 0 !!---------------------------------------------------------------------------------- IF( ANY(pstab < -0.00001) .OR. ANY(pstab > 1.00001) ) THEN PRINT *, 'ERROR: ch_n10_ncar@mod_blk_ncar.f90: pstab =' @@ -283,8 +283,8 @@ CONTAINS !! Estimate of the neutral heat transfer coefficient at 10m !! !! Origin: Large & Yeager 2008, Eq. (9) and (13) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: ce_n10_ncar - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) + REAL(wp), DIMENSION(jpi,jpj) :: ce_n10_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) !!---------------------------------------------------------------------------------- ce_n10_ncar = MAX( 1.e-3_wp * ( 34.6_wp * psqrtcdn10 ) , Cx_min ) ! @@ -301,11 +301,11 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_m_ncar - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zx2, zx, zpsi_unst, zpsi_stab, zstab ! local scalars + REAL(wp) :: zta, zx2, zx, zpsi_unst, zpsi_stab, zstab ! local scalars !!---------------------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) zta = pzeta(ji,jj) @@ -339,11 +339,11 @@ CONTAINS !! !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) !!---------------------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: psi_h_ncar - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars + REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars !!---------------------------------------------------------------------------------- ! DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) diff --git a/src/OCE/SBC/sbcblk_skin_coare.F90 b/src/OCE/SBC/sbcblk_skin_coare.F90 index feb63f2e2e06e29cd9bf5eb260c017db8c643bc1..54dedf9e24ed6f4a8a949299d45dd050fa5482ab 100644 --- a/src/OCE/SBC/sbcblk_skin_coare.F90 +++ b/src/OCE/SBC/sbcblk_skin_coare.F90 @@ -35,18 +35,18 @@ MODULE sbcblk_skin_coare # include "do_loop_substitute.h90" !! Cool-skin related parameters: - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_cs !: dT due to cool-skin effect + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_cs !: dT due to cool-skin effect ! ! => temperature difference between air-sea interface (z=0) ! ! and right below viscous layer (z=delta) !! Warm-layer related parameters: - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_wl !: dT due to warm-layer effect + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_wl !: dT due to warm-layer effect ! ! => difference between "almost surface (right below ! ! viscous layer, z=delta) and depth of bulk SST (z=gdept_1d(1)) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Hz_wl !: depth (aka thickness) of warm-layer [m] - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Qnt_ac !: time integral / accumulated heat stored by the warm layer + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Hz_wl !: depth (aka thickness) of warm-layer [m] + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Qnt_ac !: time integral / accumulated heat stored by the warm layer ! ! Qxdt => [J/m^2] (reset to zero every midnight) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Tau_ac !: time integral / accumulated momentum + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Tau_ac !: time integral / accumulated momentum ! ! Tauxdt => [N.s/m^2] (reset to zero every midnight) REAL(wp), PARAMETER, PUBLIC :: Hwl_max = 20._wp !: maximum depth of warm layer (adjustable) @@ -79,14 +79,14 @@ CONTAINS !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] !! *pQlat* surface latent heat flux [K] !!------------------------------------------------------------------ - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pQlat ! latent heat flux [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQlat ! latent heat flux [W/m^2] !!--------------------------------------------------------------------- INTEGER :: ji, jj, jc - REAL(dp) :: zQabs, zdlt, zfr, zalfa, zqlat, zus + REAL(wp) :: zQabs, zdlt, zfr, zalfa, zqlat, zus !!--------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -129,20 +129,20 @@ CONTAINS !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] !! *iwait* if /= 0 then wait before updating accumulated fluxes, we are within a converging itteration loop... !!--------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pTau ! wind stress [N/m^2] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTau ! wind stress [N/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] INTEGER , INTENT(in) :: iwait ! if /= 0 then wait before updating accumulated fluxes !! INTEGER :: ji,jj ! - REAL(dp) :: zdTwl, zHwl, zQabs, zfr - REAL(dp) :: zqac, ztac - REAL(dp) :: zalfa, zcd1, zcd2, flg + REAL(wp) :: zdTwl, zHwl, zQabs, zfr + REAL(wp) :: zqac, ztac + REAL(wp) :: zalfa, zcd1, zcd2, flg !!--------------------------------------------------------------------- - REAL(dp) :: ztime, znoon, zmidn + REAL(wp) :: ztime, znoon, zmidn INTEGER :: jl LOGICAL :: l_exit, l_destroy_wl @@ -153,7 +153,7 @@ CONTAINS IF( .NOT. ln_dm2dc ) CALL sbc_dcy_param() ! we need to call sbc_dcy_param (sbcdcy.F90) because rdawn_dcy and rdusk_dcy are unkonwn otherwize! - ztime = REAL(nsec_day,dp)/(24._wp*3600._wp) ! time of current time step since 00:00 for current day (UTC) -> ztime = 0 -> 00:00 / ztime = 0.5 -> 12:00 ... + ztime = REAL(nsec_day,wp)/(24._wp*3600._wp) ! time of current time step since 00:00 for current day (UTC) -> ztime = 0 -> 00:00 / ztime = 0.5 -> 12:00 ... DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -270,14 +270,14 @@ CONTAINS !! !! L. Brodeau, october 2019 !!--------------------------------------------------------------------- - REAL(dp) :: delta_skin_layer - REAL(dp), INTENT(in) :: palpha ! thermal expansion coefficient of sea-water (SST accurate enough!) - REAL(dp), INTENT(in) :: pQd ! < 0 !!! part of the net heat flux actually absorbed in the WL [W/m^2] + REAL(wp) :: delta_skin_layer + REAL(wp), INTENT(in) :: palpha ! thermal expansion coefficient of sea-water (SST accurate enough!) + REAL(wp), INTENT(in) :: pQd ! < 0 !!! part of the net heat flux actually absorbed in the WL [W/m^2] ! ! => term "Q + Rs*fs" in eq.6 of Fairall et al. 1996 - REAL(dp), INTENT(in) :: pQlat ! latent heat flux [W/m^2] - REAL(dp), INTENT(in) :: pustar_a ! friction velocity in the air (u*) [m/s] + REAL(wp), INTENT(in) :: pQlat ! latent heat flux [W/m^2] + REAL(wp), INTENT(in) :: pustar_a ! friction velocity in the air (u*) [m/s] !!--------------------------------------------------------------------- - REAL(dp) :: zusw, zusw2, zlamb, zQd, ztf, ztmp + REAL(wp) :: zusw, zusw2, zlamb, zQd, ztf, ztmp !!--------------------------------------------------------------------- zQd = pQd + 0.026*MIN(pQlat,0._wp)*rCp0_w/rLevap/palpha ! #LB: Double check sign + division by palpha !!! units are okay! @@ -301,8 +301,8 @@ CONTAINS !!--------------------------------------------------------------------- !! Fraction of solar heat flux absorbed inside warm layer !!--------------------------------------------------------------------- - REAL(dp) :: frac_solar_abs - REAL(dp), INTENT(in) :: pHwl ! thickness of warm-layer [m] + REAL(wp) :: frac_solar_abs + REAL(wp), INTENT(in) :: pHwl ! thickness of warm-layer [m] !!--------------------------------------------------------------------- frac_solar_abs = 1._wp - ( 0.28*0.014 *(1._wp - EXP(-pHwl/0.014)) & & + 0.27*0.357*(1._wp - EXP(-pHwl/0.357)) & diff --git a/src/OCE/SBC/sbcblk_skin_ecmwf.F90 b/src/OCE/SBC/sbcblk_skin_ecmwf.F90 index e1e7626e27cd88a9d74d7c2512c4c5d290304d89..cf9b9906c133c88d29ff53af38bc262daf2e9b3d 100644 --- a/src/OCE/SBC/sbcblk_skin_ecmwf.F90 +++ b/src/OCE/SBC/sbcblk_skin_ecmwf.F90 @@ -46,19 +46,18 @@ MODULE sbcblk_skin_ecmwf PUBLIC :: CS_ECMWF, WL_ECMWF !! * Substitutions -# include "single_precision_substitute.h90" # include "do_loop_substitute.h90" !! Cool-skin related parameters: - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_cs !: dT due to cool-skin effect + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_cs !: dT due to cool-skin effect ! ! => temperature difference between air-sea interface (z=0) ! ! and right below viscous layer (z=delta) !! Warm-layer related parameters: - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_wl !: dT due to warm-layer effect + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_wl !: dT due to warm-layer effect ! ! => difference between "almost surface (right below ! ! viscous layer, z=delta) and depth of bulk SST (z=gdept_1d(1)) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Hz_wl !: depth (aka thickness) of warm-layer [m] + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Hz_wl !: depth (aka thickness) of warm-layer [m] ! REAL(wp), PARAMETER, PUBLIC :: rd0 = 3. !: Depth scale [m] of warm layer, "d" in Eq.11 (Zeng & Beljaars 2005) REAL(wp), PARAMETER :: zRhoCp_w = rho0_w*rCp0_w @@ -88,13 +87,13 @@ CONTAINS !! *pustar* friction velocity u* [m/s] !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] !!------------------------------------------------------------------ - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K] !!--------------------------------------------------------------------- INTEGER :: ji, jj, jc - REAL(dp) :: zQabs, zdlt, zfr, zalfa, zus + REAL(wp) :: zQabs, zdlt, zfr, zalfa, zus !!--------------------------------------------------------------------- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) @@ -148,25 +147,25 @@ CONTAINS !! *pustar* friction velocity u* [m/s] !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] !!------------------------------------------------------------------ - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity [m/s] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] !! REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pustk ! surface Stokes velocity [m/s] ! INTEGER :: ji, jj, jc ! - REAL(dp) :: zHwl !: thickness of the warm-layer [m] - REAL(dp) :: ztcorr !: correction of dT w.r.t measurement depth of bulk SST (first T-point) - REAL(dp) :: zalfa !: thermal expansion coefficient of sea-water [1/K] - REAL(dp) :: zdTwl_b, zdTwl_n !: temp. diff. between "almost surface (right below viscous layer) and bottom of WL - REAL(dp) :: zfr, zeta - REAL(dp) :: zusw, zusw2 - REAL(dp) :: zLa, zfLa - REAL(dp) :: flg, zwf, zQabs - REAL(dp) :: ZA, ZB, zL1, zL2 - REAL(dp) :: zcst0, zcst1, zcst2, zcst3 + REAL(wp) :: zHwl !: thickness of the warm-layer [m] + REAL(wp) :: ztcorr !: correction of dT w.r.t measurement depth of bulk SST (first T-point) + REAL(wp) :: zalfa !: thermal expansion coefficient of sea-water [1/K] + REAL(wp) :: zdTwl_b, zdTwl_n !: temp. diff. between "almost surface (right below viscous layer) and bottom of WL + REAL(wp) :: zfr, zeta + REAL(wp) :: zusw, zusw2 + REAL(wp) :: zLa, zfLa + REAL(wp) :: flg, zwf, zQabs + REAL(wp) :: ZA, ZB, zL1, zL2 + REAL(wp) :: zcst0, zcst1, zcst2, zcst3 ! LOGICAL :: l_pustk_known !!--------------------------------------------------------------------- @@ -188,7 +187,7 @@ CONTAINS !! => but of course in general the bulk SST is taken shallower than zHwl !!! So correction less pronounced! !! => so here since pdT is difference between surface and gdept_1d(1), need to increase fof zdTwl ! - zalfa =alpha_sw( CASTDP(pSST(ji,jj)) ) ! (crude) thermal expansion coefficient of sea-water [1/K] (SST accurate enough!) + zalfa = alpha_sw( pSST(ji,jj) ) ! (crude) thermal expansion coefficient of sea-water [1/K] (SST accurate enough!) ! *** zfr = Fraction of solar radiation absorbed in warm layer (-) zfr = 1._wp - 0.28_wp*EXP(-71.5_wp*zHwl) - 0.27_wp*EXP(-2.8_wp*zHwl) - 0.45_wp*EXP(-0.07_wp*zHwl) !: Eq. 8.157 @@ -265,13 +264,13 @@ CONTAINS !! !! L. Brodeau, october 2019 !!--------------------------------------------------------------------- - REAL(dp) :: delta_skin_layer - REAL(dp), INTENT(in) :: palpha ! thermal expansion coefficient of sea-water (SST accurate enough!) - REAL(dp), INTENT(in) :: pQd ! < 0 !!! part of the net heat flux actually absorbed in the WL [W/m^2] + REAL(wp) :: delta_skin_layer + REAL(wp), INTENT(in) :: palpha ! thermal expansion coefficient of sea-water (SST accurate enough!) + REAL(wp), INTENT(in) :: pQd ! < 0 !!! part of the net heat flux actually absorbed in the WL [W/m^2] ! ! => term "Q + Rs*fs" in eq.6 of Fairall et al. 1996 - REAL(dp), INTENT(in) :: pustar_a ! friction velocity in the air (u*) [m/s] + REAL(wp), INTENT(in) :: pustar_a ! friction velocity in the air (u*) [m/s] !!--------------------------------------------------------------------- - REAL(dp) :: zusw, zusw2, zlamb, ztf, ztmp + REAL(wp) :: zusw, zusw2, zlamb, ztf, ztmp !!--------------------------------------------------------------------- ztf = 0.5_wp + SIGN(0.5_wp, pQd) ! Qabs < 0 => cooling of the viscous layer => ztf = 0 (regular case) ! ! Qabs > 0 => warming of the viscous layer => ztf = 1 @@ -295,10 +294,10 @@ CONTAINS !! Eq.(5) !! L. Brodeau, october 2019 !!--------------------------------------------------------------------- - REAL(dp) :: PHI - REAL(dp), INTENT(in) :: pzeta ! stability parameter + REAL(wp) :: PHI + REAL(wp), INTENT(in) :: pzeta ! stability parameter !!--------------------------------------------------------------------- - REAL(dp) :: ztf, zzt2 + REAL(wp) :: ztf, zzt2 !!--------------------------------------------------------------------- zzt2 = pzeta*pzeta ztf = 0.5_wp + SIGN(0.5_wp, pzeta) ! zeta > 0 => ztf = 1 diff --git a/src/OCE/SBC/sbcclo.F90 b/src/OCE/SBC/sbcclo.F90 index d32f9f7990cdce6c208d39ccdd2e6044d3359500..edcb2341caab6b1b5db78dda84f065f2f5e7e047 100644 --- a/src/OCE/SBC/sbcclo.F90 +++ b/src/OCE/SBC/sbcclo.F90 @@ -38,9 +38,9 @@ MODULE sbcclo PUBLIC sbc_clo PUBLIC sbc_clo_init ! - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcg, rsurftrgg !: closed sea source/target glo surface areas - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcr, rsurftrgr !: closed sea source/target rnf surface areas - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrce, rsurftrge !: closed sea source/target emp surface areas + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcg, rsurftrgg !: closed sea source/target glo surface areas + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcr, rsurftrgr !: closed sea source/target rnf surface areas + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrce, rsurftrge !: closed sea source/target emp surface areas ! INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: mcsgrpg, mcsgrpr, mcsgrpe !: closed sea group for glo, rnf and emp ! @@ -104,7 +104,7 @@ MODULE sbcclo !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! ocean model time step ! - REAL(dp), DIMENSION(jpi,jpj) :: zwcs, zqcs ! water flux and heat flux correction due to closed seas + REAL(wp), DIMENSION(jpi,jpj) :: zwcs, zqcs ! water flux and heat flux correction due to closed seas !!---------------------------------------------------------------------- ! ! 0. initialisation @@ -138,7 +138,7 @@ MODULE sbcclo ! subroutine parameters INTEGER , INTENT(in ) :: kncs ! closed sea number INTEGER , DIMENSION(:,:), INTENT(in ) :: kmaskcs ! closed sea mask - REAL(dp), DIMENSION(:) , INTENT( out) :: psurfsrc ! source surface area + REAL(wp), DIMENSION(:) , INTENT( out) :: psurfsrc ! source surface area ! local variables INTEGER :: jcs ! loop index @@ -174,7 +174,7 @@ MODULE sbcclo ! output INTEGER , DIMENSION(:) , INTENT( out) :: kcsgrp ! closed sea group number - REAL(dp), DIMENSION(:) , INTENT( out) :: psurftrg ! target surface area + REAL(wp), DIMENSION(:) , INTENT( out) :: psurftrg ! target surface area ! local variables INTEGER :: jcs, jtmp ! tmp @@ -223,7 +223,7 @@ MODULE sbcclo INTEGER, INTENT(in ) :: kncs ! closed sea number INTEGER, DIMENSION(:) , INTENT(in ) :: kcsgrp ! closed sea group number ! - REAL(dp), DIMENSION(:), INTENT(in ) :: psurfsrc, psurftrg ! source and target surface area + REAL(wp), DIMENSION(:), INTENT(in ) :: psurfsrc, psurftrg ! source and target surface area ! CHARACTER(LEN=3) , INTENT(in ) :: cdcstype ! closed sea scheme used for redistribution !!---------------------------------------------------------------------- @@ -261,17 +261,17 @@ MODULE sbcclo INTEGER, DIMENSION(: ), INTENT(in) :: kcsgrp ! closed sea group id INTEGER, DIMENSION(:,:), INTENT(in) :: kmsk_src, kmsk_grp, kmsk_opnsea ! source, target, open ocean mask - REAL(dp), DIMENSION(:) , INTENT(in ) :: psurfsrc, psurftrg, psurf_opnsea ! source, target and open ocean surface area - REAL(dp), DIMENSION(:,:), INTENT(inout) :: pwcs, pqcs ! water and heat flux correction due to closed seas + REAL(wp), DIMENSION(:) , INTENT(in ) :: psurfsrc, psurftrg, psurf_opnsea ! source, target and open ocean surface area + REAL(wp), DIMENSION(:,:), INTENT(inout) :: pwcs, pqcs ! water and heat flux correction due to closed seas ! local variables INTEGER :: jcs ! loop index over closed sea INTEGER, DIMENSION(jpi,jpj) :: imsk_src, imsk_trg ! tmp array source and target closed sea masks - REAL(dp) :: zcsfw, zcsh ! total fresh water and associated heat over one closed sea - REAL(dp) :: zcsfwf ! mean fresh water flux over one closed sea - REAL(dp) :: zsurftrg, zsurfsrc ! total target surface area + REAL(wp) :: zcsfw, zcsh ! total fresh water and associated heat over one closed sea + REAL(wp) :: zcsfwf ! mean fresh water flux over one closed sea + REAL(wp) :: zsurftrg, zsurfsrc ! total target surface area !!---------------------------------------------------------------------- ! DO jcs = 1, kncs ! loop over closed seas @@ -330,7 +330,7 @@ MODULE sbcclo ! subroutine parameters INTEGER, INTENT(in) :: klen INTEGER, ALLOCATABLE, DIMENSION(:), INTENT( out) :: kvargrp - REAL(dp), ALLOCATABLE, DIMENSION(:), INTENT( out) :: pvarsrc, pvartrg + REAL(wp), ALLOCATABLE, DIMENSION(:), INTENT( out) :: pvarsrc, pvartrg ! ! local variables INTEGER :: ierr diff --git a/src/OCE/SBC/sbccpl.F90 b/src/OCE/SBC/sbccpl.F90 index b85891415a760dc84f1a3537112211fdc0330818..b6db6481ff9442f6b8b05d76c2e17d26fe0c4e60 100644 --- a/src/OCE/SBC/sbccpl.F90 +++ b/src/OCE/SBC/sbccpl.F90 @@ -209,12 +209,12 @@ MODULE sbccpl LOGICAL :: ln_scale_ice_flux ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) TYPE :: DYNARR - REAL(dp), POINTER, DIMENSION(:,:,:) :: z3 + REAL(wp), POINTER, DIMENSION(:,:,:) :: z3 END TYPE DYNARR TYPE( DYNARR ), SAVE, DIMENSION(jprcv) :: frcv ! all fields recieved from the atmosphere - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: alb_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: alb_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky) #if defined key_si3 || defined key_cice REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_last_couple !: Ice fractional area at last coupling time #endif @@ -272,7 +272,7 @@ CONTAINS ! INTEGER :: jn ! dummy loop index INTEGER :: ios, inum ! Local integer - REAL(dp), DIMENSION(jpi,jpj) :: zacs, zaos + REAL(wp), DIMENSION(jpi,jpj) :: zacs, zaos !! NAMELIST/namsbc_cpl/ nn_cplmodel , ln_usecplmask, nn_cats_cpl , ln_scale_ice_flux, & & sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , & @@ -1181,13 +1181,13 @@ CONTAINS LOGICAL :: llnewtx, llnewtau ! update wind stress components and module?? INTEGER :: ji, jj, jn ! dummy loop indices INTEGER :: isec ! number of seconds since nit000 (assuming rdt did not change since nit000) - REAL(dp) :: zcumulneg, zcumulpos ! temporary scalars - REAL(dp) :: zcoef ! temporary scalar - REAL(dp) :: zrhoa = 1.22 ! Air density kg/m3 - REAL(dp) :: zcdrag = 1.5e-3 ! drag coefficient - REAL(dp) :: zzx, zzy ! temporary variables - REAL(dp) :: r1_grau ! = 1.e0 / (grav * rho0) - REAL(dp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr, zcloud_fra + REAL(wp) :: zcumulneg, zcumulpos ! temporary scalars + REAL(wp) :: zcoef ! temporary scalar + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: zzx, zzy ! temporary variables + REAL(wp) :: r1_grau ! = 1.e0 / (grav * rho0) + REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr, zcloud_fra !!---------------------------------------------------------------------- ! IF( kt == nit000 ) THEN @@ -1253,7 +1253,7 @@ CONTAINS frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) ) frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) END_2D - CALL lbc_lnk( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1.0_dp, frcv(jpr_oty1)%z3(:,:,1), 'V', -1.0_dp ) + CALL lbc_lnk( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V', -1.0_wp ) ENDIF llnewtx = .TRUE. ELSE @@ -1278,7 +1278,7 @@ CONTAINS zzy = frcv(jpr_oty1)%z3(ji ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1) frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) END_2D - CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1.0_dp ) + CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1.0_wp ) llnewtau = .TRUE. ELSE llnewtau = .FALSE. @@ -1594,13 +1594,13 @@ CONTAINS !! !! ** Action : return ptau_i, ptau_j, the stress over the ice !!---------------------------------------------------------------------- - REAL(dp), INTENT(inout), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2] - REAL(dp), INTENT(inout), DIMENSION(:,:) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid) + REAL(wp), INTENT(inout), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2] + REAL(wp), INTENT(inout), DIMENSION(:,:) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid) !! INTEGER :: ji, jj ! dummy loop indices INTEGER :: itx ! index of taux over ice - REAL(dp) :: zztmp1, zztmp2 - REAL(dp), DIMENSION(jpi,jpj) :: ztx, zty + REAL(wp) :: zztmp1, zztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty !!---------------------------------------------------------------------- ! #if defined key_si3 || defined key_cice @@ -1745,17 +1745,17 @@ CONTAINS ! !! ! optional arguments, used only in 'mixed oce-ice' case or for Met-Office coupling REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo REAL(wp), INTENT(in) , DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] - REAL(dp), INTENT(inout), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] => inout for Met-Office + REAL(wp), INTENT(inout), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] => inout for Met-Office REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phs ! snow depth [m] REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phi ! ice thickness [m] ! INTEGER :: ji, jj, jl ! dummy loop index - REAL(dp), DIMENSION(jpi,jpj) :: zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw - REAL(dp), DIMENSION(jpi,jpj) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip , zevap_oce, zdevap_ice - REAL(dp), DIMENSION(jpi,jpj) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice - REAL(dp), DIMENSION(jpi,jpj) :: zevap_ice_total - REAL(dp), DIMENSION(jpi,jpj,jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top, ztsu - REAL(dp), DIMENSION(jpi,jpj) :: ztri + REAL(wp), DIMENSION(jpi,jpj) :: zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw + REAL(wp), DIMENSION(jpi,jpj) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip , zevap_oce, zdevap_ice + REAL(wp), DIMENSION(jpi,jpj) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice + REAL(wp), DIMENSION(jpi,jpj) :: zevap_ice_total + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top, ztsu + REAL(wp), DIMENSION(jpi,jpj) :: ztri !!---------------------------------------------------------------------- ! #if defined key_si3 || defined key_cice @@ -2299,9 +2299,9 @@ CONTAINS ! INTEGER :: ji, jj, jl ! dummy loop indices INTEGER :: isec, info ! local integer - REAL(dp) :: zumax, zvmax - REAL(dp), DIMENSION(jpi,jpj) :: zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 - REAL(dp), DIMENSION(jpi,jpj,jpl) :: ztmp3, ztmp4 + REAL(wp) :: zumax, zvmax + REAL(wp), DIMENSION(jpi,jpj) :: zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 + REAL(wp), DIMENSION(jpi,jpj,jpl) :: ztmp3, ztmp4 !!---------------------------------------------------------------------- ! isec = ( kt - nit000 ) * NINT( rn_Dt ) ! date of exchanges @@ -2317,7 +2317,7 @@ CONTAINS ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) ! send temperature as it is (potential or conservative) -> use of l_useCT on the received part ELSE ! we must send the surface potential temperature - IF( l_useCT ) THEN ; ztmp1(:,:) = eos_pt_from_ct( ts(:,:,1,jp_tem,Kmm), ts(:,:,1,jp_sal,Kmm) ) + IF( l_useCT ) THEN ; ztmp1(:,:) =eos_pt_from_ct( CASTSP(ts(:,:,1,jp_tem,Kmm)), CASTSP(ts(:,:,1,jp_sal,Kmm)) ) ELSE ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) ENDIF ! @@ -2598,7 +2598,7 @@ CONTAINS zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) END_2D - CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_dp, zity1, 'T', -1.0_dp ) + CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T DO_2D( 0, 0, 0, 0 ) zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) & @@ -2607,7 +2607,7 @@ CONTAINS & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) END_2D END SELECT - CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_dp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_dp ) + CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp ) ! ENDIF ! @@ -2675,7 +2675,7 @@ CONTAINS zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) END_2D - CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_dp, zity1, 'T', -1.0_dp ) + CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T DO_2D( 0, 0, 0, 0 ) zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) & @@ -2684,7 +2684,7 @@ CONTAINS & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) END_2D END SELECT - CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_dp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_dp ) + CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) ! ! IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components @@ -2751,11 +2751,11 @@ CONTAINS ENDIF ! ! SSS IF( ssnd(jps_soce )%laction ) THEN - CALL cpl_snd( jps_soce , isec, RESHAPE ( ts(:,:,1,jp_sal,Kmm), (/jpi,jpj,1/) ), info ) + CALL cpl_snd( jps_soce , isec, CASTSP(RESHAPE ( ts(:,:,1,jp_sal,Kmm), (/jpi,jpj,1/) )), info ) ENDIF ! ! first T level thickness IF( ssnd(jps_e3t1st )%laction ) THEN - CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( e3t(:,:,1,Kmm) , (/jpi,jpj,1/) ), info ) + CALL cpl_snd( jps_e3t1st, isec, CASTSP(RESHAPE ( e3t(:,:,1,Kmm) , (/jpi,jpj,1/) )), info ) ENDIF ! ! Qsr fraction IF( ssnd(jps_fraqsr)%laction ) THEN @@ -2766,7 +2766,7 @@ CONTAINS ! ! Solar heat flux IF( ssnd(jps_qsroce)%laction ) CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr , (/jpi,jpj,1/) ), info ) IF( ssnd(jps_qnsoce)%laction ) CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns , (/jpi,jpj,1/) ), info ) - IF( ssnd(jps_oemp )%laction ) CALL cpl_snd( jps_oemp , isec, CASTDP(RESHAPE ( emp , (/jpi,jpj,1/) )), info ) + IF( ssnd(jps_oemp )%laction ) CALL cpl_snd( jps_oemp , isec, RESHAPE ( emp , (/jpi,jpj,1/) ), info ) IF( ssnd(jps_sflx )%laction ) CALL cpl_snd( jps_sflx , isec, RESHAPE ( sfx , (/jpi,jpj,1/) ), info ) IF( ssnd(jps_otx1 )%laction ) CALL cpl_snd( jps_otx1 , isec, RESHAPE ( utau, (/jpi,jpj,1/) ), info ) IF( ssnd(jps_oty1 )%laction ) CALL cpl_snd( jps_oty1 , isec, RESHAPE ( vtau, (/jpi,jpj,1/) ), info ) @@ -2786,4 +2786,4 @@ CONTAINS END SUBROUTINE sbc_cpl_snd !!====================================================================== -END MODULE sbccpl +END MODULE sbccpl \ No newline at end of file diff --git a/src/OCE/SBC/sbcdcy.F90 b/src/OCE/SBC/sbcdcy.F90 index 9f51edd0647984f4776f21a2ffad8a6c511fc57a..0372d38a957d9002e04b4d35fbdc5dacf5838c7d 100644 --- a/src/OCE/SBC/sbcdcy.F90 +++ b/src/OCE/SBC/sbcdcy.F90 @@ -29,9 +29,9 @@ MODULE sbcdcy INTEGER, PUBLIC :: nday_qsr !: day when parameters were computed - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: raa , rbb , rcc , rab ! diurnal cycle parameters - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: rtmd, rscal ! - - - - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rdawn_dcy, rdusk_dcy ! - - - + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: raa , rbb , rcc , rab ! diurnal cycle parameters + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: rtmd, rscal ! - - - + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rdawn_dcy, rdusk_dcy ! - - - PUBLIC sbc_dcy ! routine called by sbc PUBLIC sbc_dcy_param ! routine used here and called by warm-layer parameterization (sbcblk_skin_coare*) @@ -72,21 +72,21 @@ CONTAINS !! Part 1: a diurnally forced OGCM. Climate Dynamics 29:6, 575-590. !!---------------------------------------------------------------------- LOGICAL , OPTIONAL , INTENT(in) :: l_mask ! use the routine for night mask computation - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pqsrin ! input daily QSR flux - REAL(dp), DIMENSION(jpi,jpj) :: zqsrout ! output QSR flux with diurnal cycle + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqsrin ! input daily QSR flux + REAL(wp), DIMENSION(jpi,jpj) :: zqsrout ! output QSR flux with diurnal cycle !! INTEGER :: ji, jj ! dummy loop indices INTEGER, DIMENSION(jpi,jpj) :: imask_night ! night mask - REAL(dp) :: zlo, zup, zlousd, zupusd - REAL(dp) :: ztmp, ztmp1, ztmp2 - REAL(dp) :: ztmpm, ztmpm1, ztmpm2 + REAL(wp) :: zlo, zup, zlousd, zupusd + REAL(wp) :: ztmp, ztmp1, ztmp2 + REAL(wp) :: ztmpm, ztmpm1, ztmpm2 !!--------------------------------------------------------------------- ! ! Initialization ! -------------- ! When are we during the day (from 0 to 1) - zlo = ( REAL(nsec_day,dp) - 0.5_wp * rn_Dt ) / rday - zup = zlo + ( REAL(nn_fsbc,dp) * rn_Dt ) / rday + zlo = ( REAL(nsec_day, wp) - 0.5_wp * rn_Dt ) / rday + zup = zlo + ( REAL(nn_fsbc, wp) * rn_Dt ) / rday ! IF( nday_qsr == -1 ) THEN ! first time step only IF(lwp) THEN @@ -162,8 +162,8 @@ CONTAINS !! INTEGER :: ji, jj ! dummy loop indices !INTEGER, DIMENSION(jpi,jpj) :: imask_night ! night mask - REAL(dp) :: zdsws, zdecrad, ztx, zsin, zcos - REAL(dp) :: ztmp, ztest + REAL(wp) :: zdsws, zdecrad, ztx, zsin, zcos + REAL(wp) :: ztmp, ztest !---------------------------statement functions------------------------ ! IF( nday_qsr == -1 ) THEN ! first time step only @@ -186,9 +186,9 @@ CONTAINS ! save the day of the year and the daily mean of qsr nday_qsr = nday ! number of days since the previous winter solstice (supposed to be always 21 December) - zdsws = REAL(11 + nday_year,dp) + zdsws = REAL(11 + nday_year, wp) ! declination of the earths orbit - zdecrad = (-23.5_wp * rad) * COS( zdsws * 2._wp*rpi / REAL(nyear_len(1),dp) ) + zdecrad = (-23.5_wp * rad) * COS( zdsws * 2._wp*rpi / REAL(nyear_len(1),wp) ) ! Compute A and B needed to compute the time integral of the diurnal cycle zsin = SIN( zdecrad ) ; zcos = COS( zdecrad ) @@ -235,14 +235,14 @@ CONTAINS ENDIF ELSE ! day time in two parts IF( (rdusk_dcy(ji,jj) + (1._wp - rdawn_dcy(ji,jj)) ) .ge. 0.001_wp ) THEN - rscal(ji,jj) = fintegral(0._dp, rdusk_dcy(ji,jj), raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) & - & + fintegral(rdawn_dcy(ji,jj), 1._dp, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + rscal(ji,jj) = fintegral(0._wp, rdusk_dcy(ji,jj), raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) & + & + fintegral(rdawn_dcy(ji,jj), 1._wp, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) rscal(ji,jj) = 1. / rscal(ji,jj) ENDIF ENDIF ELSE IF( raa(ji,jj) > rbb(ji,jj) ) THEN ! 24h day - rscal(ji,jj) = fintegral(0._dp, 1._dp, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + rscal(ji,jj) = fintegral(0._wp, 1._wp, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) rscal(ji,jj) = 1._wp / rscal(ji,jj) ELSE ! No day rscal(ji,jj) = 0.0_wp @@ -250,7 +250,7 @@ CONTAINS ENDIF END_2D ! - ztmp = rday / ( rn_Dt * REAL(nn_fsbc,dp) ) + ztmp = rday / ( rn_Dt * REAL(nn_fsbc, wp) ) rscal(:,:) = rscal(:,:) * ztmp ! ENDIF !IF( nday_qsr /= nday ) @@ -259,11 +259,11 @@ CONTAINS FUNCTION fintegral( pt1, pt2, paaa, pbbb, pccc ) - REAL(dp), INTENT(in) :: pt1, pt2, paaa, pbbb, pccc - REAL(dp) :: fintegral + REAL(wp), INTENT(in) :: pt1, pt2, paaa, pbbb, pccc + REAL(wp) :: fintegral fintegral = paaa * pt2 + 1._wp/(2._wp*rpi) * pbbb * SIN(pccc + 2._wp*rpi*pt2) & & - paaa * pt1 - 1._wp/(2._wp*rpi) * pbbb * SIN(pccc + 2._wp*rpi*pt1) END FUNCTION fintegral !!====================================================================== -END MODULE sbcdcy +END MODULE sbcdcy \ No newline at end of file diff --git a/src/OCE/SBC/sbcflx.F90 b/src/OCE/SBC/sbcflx.F90 index 5b3a0632f4f8333743053c3c3160542de2d7425e..503e1e55ab6834cd919a85b12f6068430c688b38 100644 --- a/src/OCE/SBC/sbcflx.F90 +++ b/src/OCE/SBC/sbcflx.F90 @@ -80,10 +80,10 @@ CONTAINS INTEGER :: ji, jj, jf ! dummy indices INTEGER :: ierror ! return error code INTEGER :: ios ! Local integer output status for namelist read - REAL(dp) :: zfact ! temporary scalar - REAL(dp) :: zrhoa = 1.22 ! Air density kg/m3 - REAL(dp) :: zcdrag = 1.5e-3 ! drag coefficient - REAL(dp) :: ztx, zty, zmod, zcoef ! temporary variables + REAL(wp) :: zfact ! temporary scalar + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: ztx, zty, zmod, zcoef ! temporary variables !! CHARACTER(len=100) :: cn_dir ! Root directory for location of flx files TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist information structures @@ -181,9 +181,9 @@ CONTAINS wndm(ji,jj) = SQRT( zmod * zcoef ) !!clem: not used? END_2D ! - CALL lbc_lnk( 'sbcflx', taum, 'T', 1._dp, wndm, 'T', 1._dp ) + CALL lbc_lnk( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp ) ! END SUBROUTINE sbc_flx !!====================================================================== -END MODULE sbcflx +END MODULE sbcflx \ No newline at end of file diff --git a/src/OCE/SBC/sbcfwb.F90 b/src/OCE/SBC/sbcfwb.F90 index 2a52d736f654f6de3661bb6b16d25c7d52aea4d4..3bb8cf91741b6577e50befacc12a4afb20d57271 100644 --- a/src/OCE/SBC/sbcfwb.F90 +++ b/src/OCE/SBC/sbcfwb.F90 @@ -34,11 +34,11 @@ MODULE sbcfwb PUBLIC sbc_fwb ! routine called by step - REAL(dp) :: rn_fwb0 ! initial freshwater adjustment flux [kg/m2/s] (nn_fwb = 2 only) - REAL(dp) :: a_fwb ! annual domain averaged freshwater budget from the previous year - REAL(dp) :: a_fwb_b ! annual domain averaged freshwater budget from the year before or at initial state - REAL(dp) :: a_fwb_ini ! initial domain averaged freshwater budget - REAL(dp) :: area ! global mean ocean surface (interior domain) + REAL(wp) :: rn_fwb0 ! initial freshwater adjustment flux [kg/m2/s] (nn_fwb = 2 only) + REAL(wp) :: a_fwb ! annual domain averaged freshwater budget from the previous year + REAL(wp) :: a_fwb_b ! annual domain averaged freshwater budget from the year before or at initial state + REAL(wp) :: a_fwb_ini ! initial domain averaged freshwater budget + REAL(wp) :: area ! global mean ocean surface (interior domain) !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -67,10 +67,10 @@ CONTAINS INTEGER, INTENT( in ) :: Kmm ! ocean time level index ! INTEGER :: ios, inum, ikty ! local integers - REAL(dp) :: z_fwf, z_fwf_nsrf, zsum_fwf, zsum_erp ! local scalars - REAL(dp) :: zsurf_neg, zsurf_pos, zsurf_tospread, zcoef ! - - - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_neg, ztmsk_pos, z_wgt ! 2D workspaces - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_tospread, zerp_cor ! - - + REAL(wp) :: z_fwf, z_fwf_nsrf, zsum_fwf, zsum_erp ! local scalars + REAL(wp) :: zsurf_neg, zsurf_pos, zsurf_tospread, zcoef ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_neg, ztmsk_pos, z_wgt ! 2D workspaces + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_tospread, zerp_cor ! - - REAL(wp) ,DIMENSION(1) :: z_fwfprv COMPLEX(dp),DIMENSION(1) :: y_fwfnow ! @@ -145,7 +145,7 @@ CONTAINS a_fwb_b = 0._wp ! used only the first year then it is replaced by a_fwb_ini ! a_fwb_ini = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) ) & - & * rho0 / ( area * rday * REAL(nyear_len(1),dp) ) + & * rho0 / ( area * rday * REAL(nyear_len(1), wp) ) END IF ! IF(lwp) WRITE(numout,*) @@ -161,7 +161,7 @@ CONTAINS a_fwb_b = a_fwb_ini ! mean sea level taking into account ice+snow a_fwb = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) ) - a_fwb = a_fwb * rho0 / ( area * rday * REAL(nyear_len(1),dp) ) ! convert in kg/m2/s + a_fwb = a_fwb * rho0 / ( area * rday * REAL(nyear_len(1), wp) ) ! convert in kg/m2/s ENDIF ! ENDIF @@ -219,7 +219,7 @@ CONTAINS zerp_cor(:,:) = -1. * z_fwf_nsrf * zsurf_tospread * z_wgt(:,:) ! !!gm ===>>>> lbc_lnk should be useless as all the computation is done over the whole domain ! - CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1.0_dp ) + CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1.0_wp ) ! emp(:,:) = emp(:,:) + zerp_cor(:,:) qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(:,:) ! account for change to the heat budget due to fw correction @@ -253,4 +253,4 @@ CONTAINS END SUBROUTINE sbc_fwb !!====================================================================== -END MODULE sbcfwb +END MODULE sbcfwb \ No newline at end of file diff --git a/src/OCE/SBC/sbcice_if.F90 b/src/OCE/SBC/sbcice_if.F90 index e0553f1b10e3a920eb90b5a7dc01ef24dbd00425..ef66e893c6f8f18ee54b46c8d4a85bec9bd1fca5 100644 --- a/src/OCE/SBC/sbcice_if.F90 +++ b/src/OCE/SBC/sbcice_if.F90 @@ -65,8 +65,8 @@ CONTAINS INTEGER :: ji, jj ! dummy loop indices INTEGER :: ierror ! return error code INTEGER :: ios ! Local integer output status for namelist read - REAL(dp) :: ztrp, zsice, zt_fzp, zfr_obs - REAL(dp) :: zqri, zqrj, zqrp, zqi + REAL(wp) :: ztrp, zsice, zt_fzp, zfr_obs + REAL(wp) :: zqri, zqrj, zqrp, zqi !! CHARACTER(len=100) :: cn_dir ! Root directory for location of ice-if files TYPE(FLD_N) :: sn_ice ! informations about the fields to be read diff --git a/src/OCE/SBC/sbcmod.F90 b/src/OCE/SBC/sbcmod.F90 index fd4b417f1304c66a5009d1db47f549a8648c1add..bc0bf3bba8d331295cb3f793285a10a8fce76353 100644 --- a/src/OCE/SBC/sbcmod.F90 +++ b/src/OCE/SBC/sbcmod.F90 @@ -300,7 +300,7 @@ CONTAINS ENDIF ENDIF ! - IF( MOD( rday, REAL(nn_fsbc,dp) * rn_Dt ) /= 0 ) & + IF( MOD( rday, REAL(nn_fsbc, wp) * rn_Dt ) /= 0 ) & & CALL ctl_warn( 'sbc_init : nn_fsbc is NOT a multiple of the number of time steps in a day' ) ! IF( ln_dm2dc .AND. NINT(rday) / ( nn_fsbc * NINT(rn_Dt) ) < 8 ) & @@ -377,9 +377,9 @@ CONTAINS ! LOGICAL :: ll_sas, ll_opa ! local logical ! - REAL(dp) :: zthscl ! wd tanh scale - REAL(dp), DIMENSION(jpi,jpj) :: zwdht, zwght ! wd dep over wd limit, wgt - REAL(dp), DIMENSION(jpi,jpj) :: z2d ! temporary array used for iom_put + REAL(wp) :: zthscl ! wd tanh scale + REAL(wp), DIMENSION(jpi,jpj) :: zwdht, zwght ! wd dep over wd limit, wgt + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! temporary array used for iom_put !!--------------------------------------------------------------------- ! @@ -441,8 +441,8 @@ CONTAINS vtau(ji,jj) = vtau(ji,jj) * ( tauoc_wave(ji,jj) + tauoc_wave(ji,jj-1) ) * 0.5_wp END_2D ! - CALL lbc_lnk( 'sbcwave', utau, 'U', -1. ) - CALL lbc_lnk( 'sbcwave', vtau, 'V', -1. ) + CALL lbc_lnk( 'sbcwave', utau, 'U', -1._wp ) + CALL lbc_lnk( 'sbcwave', vtau, 'V', -1._wp ) ! taum(:,:) = taum(:,:)*tauoc_wave(:,:) ! @@ -452,8 +452,8 @@ CONTAINS ELSEIF( ln_wave .AND. ln_taw ) THEN ! Wave stress reduction utau(:,:) = utau(:,:) - tawx(:,:) + twox(:,:) vtau(:,:) = vtau(:,:) - tawy(:,:) + twoy(:,:) - CALL lbc_lnk( 'sbcwave', utau, 'U', -1. ) - CALL lbc_lnk( 'sbcwave', vtau, 'V', -1. ) + CALL lbc_lnk( 'sbcwave', utau, 'U', -1._wp ) + CALL lbc_lnk( 'sbcwave', vtau, 'V', -1._wp ) ! DO_2D( 0, 0, 0, 0) taum(ji,jj) = sqrt((.5*(utau(ji-1,jj)+utau(ji,jj)))**2 + (.5*(vtau(ji,jj-1)+vtau(ji,jj)))**2) @@ -463,7 +463,7 @@ CONTAINS & 'If not requested select ln_taw=.false.' ) ! ENDIF - CALL lbc_lnk( 'sbcmod', taum(:,:), 'T', 1. ) + CALL lbc_lnk( 'sbcmod', taum(:,:), 'T', 1._wp ) ! IF( ln_icebergs ) THEN ! save pure stresses (with no ice-ocean stress) for use by icebergs utau_icb(:,:) = utau(:,:) ; vtau_icb(:,:) = vtau(:,:) @@ -600,7 +600,7 @@ CONTAINS CALL iom_put( "erp" , erp ) ! freshwater flux damping ENDIF ! - !IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging) + ! IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging) !CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask ) !CALL prt_ctl(tab2d_1=(emp-rnf) , clinfo1=' emp-rnf - : ', mask1=tmask ) !CALL prt_ctl(tab2d_1=(sfx-rnf) , clinfo1=' sfx-rnf - : ', mask1=tmask ) @@ -611,7 +611,7 @@ CONTAINS !CALL prt_ctl(tab3d_1=ts(:,:,:,jp_sal,Kmm), clinfo1=' sss - : ', mask1=tmask, kdim=1 ) !CALL prt_ctl(tab2d_1=utau , clinfo1=' utau - : ', mask1=umask, & ! & tab2d_2=vtau , clinfo2=' vtau - : ', mask2=vmask ) - !ENDIF + ! ENDIF IF( kt == nitend ) CALL sbc_final ! Close down surface module if necessary ! diff --git a/src/OCE/SBC/sbcrnf.F90 b/src/OCE/SBC/sbcrnf.F90 index aa3950ffa83a1c55df9de4aa824cab93d82410ac..a1bc747972706d1a82bb180deb9513f9bb9349f2 100644 --- a/src/OCE/SBC/sbcrnf.F90 +++ b/src/OCE/SBC/sbcrnf.F90 @@ -38,8 +38,8 @@ MODULE sbcrnf CHARACTER(len=100) :: cn_dir !: Root directory for location of rnf files LOGICAL , PUBLIC :: ln_rnf_depth !: depth river runoffs attribute specified in a file LOGICAL :: ln_rnf_depth_ini !: depth river runoffs computed at the initialisation - REAL(dp) :: rn_rnf_max !: maximum value of the runoff climatologie (ln_rnf_depth_ini =T) - REAL(dp) :: rn_dep_max !: depth over which runoffs is spread (ln_rnf_depth_ini =T) + REAL(wp) :: rn_rnf_max !: maximum value of the runoff climatologie (ln_rnf_depth_ini =T) + REAL(wp) :: rn_dep_max !: depth over which runoffs is spread (ln_rnf_depth_ini =T) INTEGER :: nn_rnf_depth_file !: create (=1) a runoff depth file or not (=0) LOGICAL , PUBLIC :: ln_rnf_icb !: iceberg flux is specified in a file LOGICAL :: ln_rnf_tem !: temperature river runoffs attribute specified in a file @@ -51,18 +51,18 @@ MODULE sbcrnf TYPE(FLD_N) :: sn_t_rnf !: information about the temperatures of runoff file to be read TYPE(FLD_N) :: sn_dep_rnf !: information about the depth which river inflow affects LOGICAL , PUBLIC :: ln_rnf_mouth !: specific treatment in mouths vicinity - REAL(dp) :: rn_hrnf !: runoffs, depth over which enhanced vertical mixing is used - REAL(dp) , PUBLIC :: rn_avt_rnf !: runoffs, value of the additional vertical mixing coef. [m2/s] - REAL(dp) , PUBLIC :: rn_rfact !: multiplicative factor for runoff + REAL(wp) :: rn_hrnf !: runoffs, depth over which enhanced vertical mixing is used + REAL(wp) , PUBLIC :: rn_avt_rnf !: runoffs, value of the additional vertical mixing coef. [m2/s] + REAL(wp) , PUBLIC :: rn_rfact !: multiplicative factor for runoff LOGICAL , PUBLIC :: l_rnfcpl = .false. !: runoffs recieved from oasis INTEGER , PUBLIC :: nkrnf = 0 !: nb of levels over which Kz is increased at river mouths - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnfmsk !: river mouth mask (hori.) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rnfmsk_z !: river mouth mask (vert.) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_rnf !: depth of runoff in m + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnfmsk !: river mouth mask (hori.) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rnfmsk_z !: river mouth mask (vert.) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_rnf !: depth of runoff in m INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nk_rnf !: depth of runoff in model levels - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rnf_tsc_b, rnf_tsc !: before and now T & S runoff contents [K.m/s & PSU.m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rnf_tsc_b, rnf_tsc !: before and now T & S runoff contents [K.m/s & PSU.m/s] TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rnf ! structure: river runoff (file information, fields read) TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_i_rnf ! structure: iceberg flux (file information, fields read) @@ -109,7 +109,7 @@ CONTAINS INTEGER :: ji, jj ! dummy loop indices INTEGER :: z_err = 0 ! dummy integer for error handling !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point used for temperature correction + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point used for temperature correction ! ! ! !-------------------! @@ -200,10 +200,10 @@ CONTAINS !! ** Action : phdivn decreased by the runoff inflow !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: Kmm ! ocean time level index - REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence !! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zfact ! local scalar + REAL(wp) :: zfact ! local scalar !!---------------------------------------------------------------------- ! zfact = 0.5_wp @@ -256,8 +256,8 @@ CONTAINS INTEGER :: ierror, inum ! temporary integer INTEGER :: ios ! Local integer output status for namelist read INTEGER :: nbrec ! temporary integer - REAL(dp) :: zacoef - REAL(dp), DIMENSION(jpi,jpj,2) :: zrnfcl + REAL(wp) :: zacoef + REAL(wp), DIMENSION(jpi,jpj,2) :: zrnfcl !! NAMELIST/namsbc_rnf/ cn_dir , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal, ln_rnf_icb, & & sn_rnf, sn_cnf , sn_i_rnf, sn_s_rnf , sn_t_rnf , sn_dep_rnf, & diff --git a/src/OCE/SBC/sbcssm.F90 b/src/OCE/SBC/sbcssm.F90 index a63610858061a4874035037a5e5743c3419292c2..fa54d2faf33ec02f9015f089f518cb90918a612e 100644 --- a/src/OCE/SBC/sbcssm.F90 +++ b/src/OCE/SBC/sbcssm.F90 @@ -31,6 +31,7 @@ MODULE sbcssm LOGICAL, SAVE :: l_ssm_mean = .FALSE. ! keep track of whether means have been read from restart file +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -56,8 +57,8 @@ CONTAINS INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices ! INTEGER :: ji, jj ! loop index - REAL(dp) :: zcoef, zf_sbc ! local scalar - REAL(dp), DIMENSION(jpi,jpj,jpts) :: zts + REAL(wp) :: zcoef, zf_sbc ! local scalar + REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts !!--------------------------------------------------------------------- ! ! !* surface T-, U-, V- ocean level variables (T, S, depth, velocity) @@ -89,7 +90,7 @@ CONTAINS IF(lwp) WRITE(numout,*) IF(lwp) WRITE(numout,*) 'sbc_ssm : mean fields initialised to instantaneous values' IF(lwp) WRITE(numout,*) '~~~~~~~ ' - zcoef = REAL( nn_fsbc - 1,dp ) + zcoef = REAL( nn_fsbc - 1, wp ) ssu_m(:,:) = zcoef * uu(:,:,1,Kbb) ssv_m(:,:) = zcoef * vv(:,:,1,Kbb) IF( l_useCT ) THEN ; sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) @@ -136,7 +137,7 @@ CONTAINS ! ! ---------------------------------------- ! IF( MOD( kt - 1 , nn_fsbc ) == 0 ) THEN ! Mean value at each nn_fsbc time-step ! ! ! ---------------------------------------- ! - zcoef = 1. / REAL( nn_fsbc,dp ) + zcoef = 1. / REAL( nn_fsbc, wp ) sst_m(:,:) = sst_m(:,:) * zcoef ! mean SST [Celsius] sss_m(:,:) = sss_m(:,:) * zcoef ! mean SSS [psu] ssu_m(:,:) = ssu_m(:,:) * zcoef ! mean suface current [m/s] @@ -153,7 +154,7 @@ CONTAINS IF(lwp) WRITE(numout,*) 'sbc_ssm : sea surface mean fields written in ocean restart file ', & & 'at it= ', kt,' date= ', ndastp IF(lwp) WRITE(numout,*) '~~~~~~~' - zf_sbc = REAL( nn_fsbc,dp ) + zf_sbc = REAL( nn_fsbc, wp ) CALL iom_rstput( kt, nitrst, numrow, 'nn_fsbc', zf_sbc ) ! sbc frequency CALL iom_rstput( kt, nitrst, numrow, 'ssu_m' , ssu_m ) ! sea surface mean fields CALL iom_rstput( kt, nitrst, numrow, 'ssv_m' , ssv_m ) @@ -189,7 +190,7 @@ CONTAINS !! ** Action : - read parameters !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices - REAL(dp) :: zcoef, zf_sbc ! local scalar + REAL(wp) :: zcoef, zf_sbc ! local scalar !!---------------------------------------------------------------------- ! IF( nn_fsbc == 1 ) THEN @@ -220,9 +221,9 @@ CONTAINS frq_m(:,:) = 1._wp ! default definition ENDIF ! - IF( zf_sbc /= REAL( nn_fsbc,dp ) ) THEN ! nn_fsbc has changed between 2 runs + IF( zf_sbc /= REAL( nn_fsbc, wp ) ) THEN ! nn_fsbc has changed between 2 runs IF(lwp) WRITE(numout,*) ' restart with a change in the frequency of mean from ', zf_sbc, ' to ', nn_fsbc - zcoef = REAL( nn_fsbc - 1,dp ) / zf_sbc + zcoef = REAL( nn_fsbc - 1, wp ) / zf_sbc ssu_m(:,:) = zcoef * ssu_m(:,:) ssv_m(:,:) = zcoef * ssv_m(:,:) sst_m(:,:) = zcoef * sst_m(:,:) @@ -241,7 +242,7 @@ CONTAINS IF(lwp) WRITE(numout,*) ' default initialisation of ss._m arrays' ssu_m(:,:) = uu(:,:,1,Kbb) ssv_m(:,:) = vv(:,:,1,Kbb) - IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( ts(:,:,1,jp_tem,Kmm), ts(:,:,1,jp_sal,Kmm) ) + IF( l_useCT ) THEN ; sst_m(:,:) =eos_pt_from_ct( CASTSP(ts(:,:,1,jp_tem,Kmm)), CASTSP(ts(:,:,1,jp_sal,Kmm)) ) ELSE ; sst_m(:,:) = ts(:,:,1,jp_tem,Kmm) ENDIF sss_m(:,:) = ts (:,:,1,jp_sal,Kmm) diff --git a/src/OCE/SBC/sbcssr.F90 b/src/OCE/SBC/sbcssr.F90 index 33437ee3208d6dcb2cb8716c920d4a70941cf6b4..3984cbfe22a36e4b69495d1773aa4c069e68acd5 100644 --- a/src/OCE/SBC/sbcssr.F90 +++ b/src/OCE/SBC/sbcssr.F90 @@ -31,20 +31,20 @@ MODULE sbcssr PUBLIC sbc_ssr_init ! routine called in sbcmod PUBLIC sbc_ssr_alloc ! routine called in sbcmod - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: erp !: evaporation damping [kg/m2/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qrp !: heat flux damping [w/m2] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: coefice !: under ice relaxation coefficient + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: erp !: evaporation damping [kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qrp !: heat flux damping [w/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: coefice !: under ice relaxation coefficient ! !!* Namelist namsbc_ssr * INTEGER, PUBLIC :: nn_sstr ! SST/SSS restoring indicator INTEGER, PUBLIC :: nn_sssr ! SST/SSS restoring indicator - REAL(dp) :: rn_dqdt ! restoring factor on SST and SSS - REAL(dp) :: rn_deds ! restoring factor on SST and SSS + REAL(wp) :: rn_dqdt ! restoring factor on SST and SSS + REAL(wp) :: rn_deds ! restoring factor on SST and SSS LOGICAL :: ln_sssr_bnd ! flag to bound erp term - REAL(dp) :: rn_sssr_bnd ! ABS(Max./Min.) value of erp term [mm/day] + REAL(wp) :: rn_sssr_bnd ! ABS(Max./Min.) value of erp term [mm/day] INTEGER :: nn_sssr_ice ! Control of restoring under ice - REAL(dp) , ALLOCATABLE, DIMENSION(:) :: buffer ! Temporary buffer for exchange + REAL(wp) , ALLOCATABLE, DIMENSION(:) :: buffer ! Temporary buffer for exchange TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sst ! structure of input SST (file informations, fields read) TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sss ! structure of input SSS (file informations, fields read) @@ -74,10 +74,10 @@ CONTAINS INTEGER, INTENT(in ) :: kt ! ocean time step !! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zerp ! local scalar for evaporation damping - REAL(dp) :: zqrp ! local scalar for heat flux damping - REAL(dp) :: zsrp ! local scalar for unit conversion of rn_deds factor - REAL(dp) :: zerp_bnd ! local scalar for unit conversion of rn_epr_max factor + REAL(wp) :: zerp ! local scalar for evaporation damping + REAL(wp) :: zqrp ! local scalar for heat flux damping + REAL(wp) :: zsrp ! local scalar for unit conversion of rn_deds factor + REAL(wp) :: zerp_bnd ! local scalar for unit conversion of rn_epr_max factor INTEGER :: ierror ! return error code !! CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files @@ -162,10 +162,10 @@ CONTAINS !! - Read observed SST and/or SSS if required !!--------------------------------------------------------------------- INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zerp ! local scalar for evaporation damping - REAL(dp) :: zqrp ! local scalar for heat flux damping - REAL(dp) :: zsrp ! local scalar for unit conversion of rn_deds factor - REAL(dp) :: zerp_bnd ! local scalar for unit conversion of rn_epr_max factor + REAL(wp) :: zerp ! local scalar for evaporation damping + REAL(wp) :: zqrp ! local scalar for heat flux damping + REAL(wp) :: zsrp ! local scalar for unit conversion of rn_deds factor + REAL(wp) :: zerp_bnd ! local scalar for unit conversion of rn_epr_max factor INTEGER :: ierror ! return error code !! CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files diff --git a/src/OCE/SBC/sbcwave.F90 b/src/OCE/SBC/sbcwave.F90 index b0c930fd2990ba5582b57e407e5ec7db73ad3618..a9435f96251a143a86725800e3fa6f72d65c0c9e 100644 --- a/src/OCE/SBC/sbcwave.F90 +++ b/src/OCE/SBC/sbcwave.F90 @@ -63,28 +63,29 @@ MODULE sbcwave TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_wn ! structure of input fields (file informations, fields read) wave number for Qiao TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tauoc ! structure of input fields (file informations, fields read) normalized wave stress into the ocean - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: cdn_wave !: Neutral drag coefficient at t-point - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hsw !: Significant Wave Height at t-point - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wmp !: Wave Mean Period at t-point - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wnum !: Wave Number at t-point - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wave !: stress reduction factor at t-point - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tsd2d !: Surface Stokes Drift module at t-point - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: div_sd !: barotropic stokes drift divergence - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ut0sd, vt0sd !: surface Stokes drift velocities at t-point - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: usd, vsd, wsd !: Stokes drift velocities at u-, v- & w-points, resp.u + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: cdn_wave !: Neutral drag coefficient at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hsw !: Significant Wave Height at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wmp !: Wave Mean Period at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wnum !: Wave Number at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wave !: stress reduction factor at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tsd2d !: Surface Stokes Drift module at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: div_sd !: barotropic stokes drift divergence + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ut0sd, vt0sd !: surface Stokes drift velocities at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: wsd!: Stokes drift velocities at u-, v- & w-points, resp.u + REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: usd, vsd!: Stokes drift velocities at u-, v- & w-points, resp.u ! - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: charn !: charnock coefficient at t-point - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tawx !: Net wave-supported stress, u - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tawy !: Net wave-supported stress, v - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: twox !: wave-ocean momentum flux, u - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: twoy !: wave-ocean momentum flux, v - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wavex !: stress reduction factor at, u component - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wavey !: stress reduction factor at, v component - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: phioc !: tke flux from wave model - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: KZN2 !: Kz*N2 - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: bhd_wave !: Bernoulli head. wave induce pression - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tusd, tvsd !: Stokes drift transport - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: ZMX !: Kz*N2 + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: charn !: charnock coefficient at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tawx !: Net wave-supported stress, u + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tawy !: Net wave-supported stress, v + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: twox !: wave-ocean momentum flux, u + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: twoy !: wave-ocean momentum flux, v + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wavex !: stress reduction factor at, u component + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wavey !: stress reduction factor at, v component + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: phioc !: tke flux from wave model + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: KZN2 !: Kz*N2 + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: bhd_wave !: Bernoulli head. wave induce pression + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tusd, tvsd !: Stokes drift transport + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: ZMX !: Kz*N2 !! * Substitutions # include "do_loop_substitute.h90" # include "domzgr_substitute.h90" @@ -114,10 +115,10 @@ CONTAINS INTEGER, INTENT(in) :: Kmm ! ocean time level index INTEGER :: jj, ji, jk ! dummy loop argument INTEGER :: ik ! local integer - REAL(dp) :: ztransp, zfac, ztemp, zsp0, zsqrt, zbreiv16_w - REAL(dp) :: zdep_u, zdep_v, zkh_u, zkh_v, zda_u, zda_v, sdtrp - REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: zk_t, zk_u, zk_v, zu0_sd, zv0_sd ! 2D workspace - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ze3divh, zInt_w ! 3D workspace + REAL(wp) :: ztransp, zfac, ztemp, zsp0, zsqrt, zbreiv16_w + REAL(wp) :: zdep_u, zdep_v, zkh_u, zkh_v, zda_u, zda_v, sdtrp + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zk_t, zk_u, zk_v, zu0_sd, zv0_sd ! 2D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3divh, zInt_w ! 3D workspace !!--------------------------------------------------------------------- ! ALLOCATE( ze3divh(jpi,jpj,jpkm1) ) ! jpkm1 -> avoid lbc_lnk on jpk that is not defined @@ -224,7 +225,7 @@ CONTAINS & * r1_e1e2t(ji,jj) END_3D ! - CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1.0_dp ) + CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1.0_wp ) ! IF( ln_linssh ) THEN ; ik = 1 ! none zero velocity through the sea surface ELSE ; ik = 2 ! w=0 at the surface (set one for all in sbc_wave_init) diff --git a/src/OCE/STO/stopar.F90 b/src/OCE/STO/stopar.F90 index fed7b1202c1ad61109d1cb3e4a57ac79eab9b146..8ce9b2c6b17fe22a86a2a40a47e64647b73dfd18 100644 --- a/src/OCE/STO/stopar.F90 +++ b/src/OCE/STO/stopar.F90 @@ -39,63 +39,63 @@ MODULE stopar INTEGER :: jpsto2d = 0 ! number of 2D stochastic parameters INTEGER :: jpsto3d = 0 ! number of 3D stochastic parameters - REAL(dp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: sto2d ! 2D stochastic parameters - REAL(dp), PUBLIC, DIMENSION(:,:,:,:), ALLOCATABLE :: sto3d ! 3D stochastic parameters - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: sto_tmp ! temporary workspace - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: sto2d_abc ! a, b, c parameters (for 2D arrays) - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: sto3d_abc ! a, b, c parameters (for 3D arrays) - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto2d_ave ! mean value (for 2D arrays) - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto3d_ave ! mean value (for 3D arrays) - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto2d_std ! standard deviation (for 2D arrays) - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto3d_std ! standard deviation (for 3D arrays) - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto2d_lim ! limitation factor (for 2D arrays) - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto3d_lim ! limitation factor (for 3D arrays) - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto2d_tcor ! time correlation (for 2D arrays) - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto3d_tcor ! time correlation (for 3D arrays) + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: sto2d ! 2D stochastic parameters + REAL(wp), PUBLIC, DIMENSION(:,:,:,:), ALLOCATABLE :: sto3d ! 3D stochastic parameters + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sto_tmp ! temporary workspace + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sto2d_abc ! a, b, c parameters (for 2D arrays) + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sto3d_abc ! a, b, c parameters (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_ave ! mean value (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_ave ! mean value (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_std ! standard deviation (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_std ! standard deviation (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_lim ! limitation factor (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_lim ! limitation factor (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_tcor ! time correlation (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_tcor ! time correlation (for 3D arrays) INTEGER, DIMENSION(:), ALLOCATABLE :: sto2d_ord ! order of autoregressive process INTEGER, DIMENSION(:), ALLOCATABLE :: sto3d_ord ! order of autoregressive process CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: sto2d_typ ! nature of grid point (T, U, V, W, F, I) CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: sto3d_typ ! nature of grid point (T, U, V, W, F, I) - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto2d_sgn ! control of the sign accross the north fold - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto3d_sgn ! control of the sign accross the north fold + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_sgn ! control of the sign accross the north fold + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_sgn ! control of the sign accross the north fold INTEGER, DIMENSION(:), ALLOCATABLE :: sto2d_flt ! number of passes of Laplacian filter INTEGER, DIMENSION(:), ALLOCATABLE :: sto3d_flt ! number of passes of Laplacian filter - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto2d_fac ! factor to restore std after filtering - REAL(dp), DIMENSION(:), ALLOCATABLE :: sto3d_fac ! factor to restore std after filtering + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_fac ! factor to restore std after filtering + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_fac ! factor to restore std after filtering LOGICAL, PUBLIC :: ln_sto_ldf = .FALSE. ! stochastic lateral diffusion INTEGER, PUBLIC :: jsto_ldf ! index of lateral diffusion stochastic parameter - REAL(dp) :: rn_ldf_std ! lateral diffusion standard deviation (in percent) - REAL(dp) :: rn_ldf_tcor ! lateral diffusion correlation timescale (in timesteps) + REAL(wp) :: rn_ldf_std ! lateral diffusion standard deviation (in percent) + REAL(wp) :: rn_ldf_tcor ! lateral diffusion correlation timescale (in timesteps) LOGICAL, PUBLIC :: ln_sto_hpg = .FALSE. ! stochastic horizontal pressure gradient INTEGER, PUBLIC :: jsto_hpgi ! index of stochastic hpg parameter (i direction) INTEGER, PUBLIC :: jsto_hpgj ! index of stochastic hpg parameter (j direction) - REAL(dp) :: rn_hpg_std ! density gradient standard deviation (in percent) - REAL(dp) :: rn_hpg_tcor ! density gradient correlation timescale (in timesteps) + REAL(wp) :: rn_hpg_std ! density gradient standard deviation (in percent) + REAL(wp) :: rn_hpg_tcor ! density gradient correlation timescale (in timesteps) LOGICAL, PUBLIC :: ln_sto_pstar = .FALSE. ! stochastic ice strength INTEGER, PUBLIC :: jsto_pstar ! index of stochastic ice strength - REAL(dp), PUBLIC:: rn_pstar_std ! ice strength standard deviation (in percent) - REAL(dp) :: rn_pstar_tcor ! ice strength correlation timescale (in timesteps) + REAL(wp), PUBLIC:: rn_pstar_std ! ice strength standard deviation (in percent) + REAL(wp) :: rn_pstar_tcor ! ice strength correlation timescale (in timesteps) INTEGER :: nn_pstar_flt = 0 ! number of passes of Laplacian filter INTEGER :: nn_pstar_ord = 1 ! order of autoregressive processes LOGICAL, PUBLIC :: ln_sto_trd = .FALSE. ! stochastic model trend INTEGER, PUBLIC :: jsto_trd ! index of stochastic trend parameter - REAL(dp) :: rn_trd_std ! trend standard deviation (in percent) - REAL(dp) :: rn_trd_tcor ! trend correlation timescale (in timesteps) + REAL(wp) :: rn_trd_std ! trend standard deviation (in percent) + REAL(wp) :: rn_trd_tcor ! trend correlation timescale (in timesteps) LOGICAL, PUBLIC :: ln_sto_eos = .FALSE. ! stochastic equation of state INTEGER, PUBLIC :: nn_sto_eos = 1 ! number of degrees of freedom in stochastic equation of state INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosi ! index of stochastic eos parameter (i direction) INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosj ! index of stochastic eos parameter (j direction) INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosk ! index of stochastic eos parameter (k direction) - REAL(dp) :: rn_eos_stdxy ! random walk horz. standard deviation (in grid points) - REAL(dp) :: rn_eos_stdz ! random walk vert. standard deviation (in grid points) - REAL(dp) :: rn_eos_tcor ! random walk correlation timescale (in timesteps) - REAL(dp) :: rn_eos_lim = 3.0_wp ! limitation factor + REAL(wp) :: rn_eos_stdxy ! random walk horz. standard deviation (in grid points) + REAL(wp) :: rn_eos_stdz ! random walk vert. standard deviation (in grid points) + REAL(wp) :: rn_eos_tcor ! random walk correlation timescale (in timesteps) + REAL(wp) :: rn_eos_lim = 3.0_wp ! limitation factor INTEGER :: nn_eos_flt = 0 ! number of passes of Laplacian filter INTEGER :: nn_eos_ord = 1 ! order of autoregressive processes @@ -104,10 +104,10 @@ MODULE stopar INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trci ! index of stochastic trc parameter (i direction) INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trcj ! index of stochastic trc parameter (j direction) INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trck ! index of stochastic trc parameter (k direction) - REAL(dp) :: rn_trc_stdxy ! random walk horz. standard deviation (in grid points) - REAL(dp) :: rn_trc_stdz ! random walk vert. standard deviation (in grid points) - REAL(dp) :: rn_trc_tcor ! random walk correlation timescale (in timesteps) - REAL(dp) :: rn_trc_lim = 3.0_wp ! limitation factor + REAL(wp) :: rn_trc_stdxy ! random walk horz. standard deviation (in grid points) + REAL(wp) :: rn_trc_stdz ! random walk vert. standard deviation (in grid points) + REAL(wp) :: rn_trc_tcor ! random walk correlation timescale (in timesteps) + REAL(wp) :: rn_trc_lim = 3.0_wp ! limitation factor INTEGER :: nn_trc_flt = 0 ! number of passes of Laplacian filter INTEGER :: nn_trc_ord = 1 ! order of autoregressive processes @@ -159,7 +159,7 @@ CONTAINS INTEGER, INTENT( in ) :: kt ! ocean time-step index !! INTEGER :: ji, jj, jk, jsto, jflt - REAL(dp) :: stomax + REAL(wp) :: stomax !!---------------------------------------------------------------------- ! ! Update 2D stochastic arrays @@ -258,7 +258,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: jsto, jmem, jarea, jdof, jord, jordm1, jk, jflt INTEGER(KIND=8) :: zseed1, zseed2, zseed3, zseed4 - REAL(dp) :: rinflate + REAL(wp) :: rinflate INTEGER :: ios ! Local integer output status for namelist read ! Read namsto namelist : stochastic parameterization @@ -597,7 +597,7 @@ CONTAINS ELSE ! Approximate formula, valid for tcor >> 1 jordm1 = sto2d_ord(jsto) - 1 - rinflate = SQRT ( REAL( jordm1 ,dp ) / REAL( 2*(2*jordm1-1) ,dp ) ) + rinflate = SQRT ( REAL( jordm1 , wp ) / REAL( 2*(2*jordm1-1) , wp ) ) ENDIF sto2d_abc(jsto,2) = rinflate * SQRT ( 1._wp - sto2d_abc(jsto,1) & * sto2d_abc(jsto,1) ) @@ -615,7 +615,7 @@ CONTAINS ELSE ! Approximate formula, valid for tcor >> 1 jordm1 = sto3d_ord(jsto) - 1 - rinflate = SQRT ( REAL( jordm1 ,dp ) / REAL( 2*(2*jordm1-1) ,dp ) ) + rinflate = SQRT ( REAL( jordm1 , wp ) / REAL( 2*(2*jordm1-1) , wp ) ) ENDIF sto3d_abc(jsto,2) = rinflate * SQRT ( 1._wp - sto3d_abc(jsto,1) & * sto3d_abc(jsto,1) ) @@ -718,7 +718,7 @@ CONTAINS IF (ln_rstseed) THEN ! Get saved state of the random number generator - idg = MAX( INT(LOG10(REAL(jpnij,dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 WRITE(clfmt, "('(i', i1, '.', i1, ')')") idg, idg ! "(ix.x)" DO jseed = 1 , 4 WRITE(clseed(5:5) ,'(i1.1)') jseed @@ -776,7 +776,7 @@ CONTAINS ! get and save current state of the random number generator CALL kiss_state( ziseed(1) , ziseed(2) , ziseed(3) , ziseed(4) ) zrseed = TRANSFER( ziseed , zrseed) - idg = MAX( INT(LOG10(REAL(jpnij,dp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 WRITE(clfmt, "('(i', i1, '.', i1, ')')") idg, idg ! "(ix.x)" DO jseed = 1 , 4 WRITE(clseed(5:5) ,'(i1.1)') jseed @@ -831,10 +831,10 @@ CONTAINS !! !! ** Purpose : fill input array with white Gaussian noise !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(out) :: psto + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: psto !! INTEGER :: ji, jj - REAL(dp) :: gran ! Gaussian random number (forced KIND=8 as in kiss_gaussian) + REAL(wp) :: gran ! Gaussian random number (forced KIND=8 as in kiss_gaussian) DO_2D( 1, 1, 1, 1 ) CALL kiss_gaussian( gran ) @@ -850,7 +850,7 @@ CONTAINS !! !! ** Purpose : apply horizontal Laplacian filter to input array !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(out) :: psto + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: psto !! INTEGER :: ji, jj @@ -872,13 +872,13 @@ CONTAINS !! of the Laplacian filter !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: kpasses - REAL(dp) :: sto_par_flt_fac + REAL(wp) :: sto_par_flt_fac !! INTEGER :: jpasses, ji, jj, jflti, jfltj INTEGER, DIMENSION(-1:1,-1:1) :: pflt0 - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: pfltb - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: pflta - REAL(dp) :: ratio + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pfltb + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pflta + REAL(wp) :: ratio pflt0(-1,-1) = 0 ; pflt0(-1,0) = 1 ; pflt0(-1,1) = 0 pflt0( 0,-1) = 1 ; pflt0( 0,0) = 4 ; pflt0( 0,1) = 1 diff --git a/src/OCE/STO/stopts.F90 b/src/OCE/STO/stopts.F90 index 4d8fffb1070c3deeeb74dd2b64ac7be12a8b8459..aeb80e519862432718b901ee54c3bbd01b7aae87 100644 --- a/src/OCE/STO/stopts.F90 +++ b/src/OCE/STO/stopts.F90 @@ -22,7 +22,7 @@ MODULE stopts PUBLIC sto_pts_init ! called by nemogcm.F90 ! Public array with random tracer fluctuations - REAL(dp), PUBLIC, DIMENSION(:,:,:,:,:), ALLOCATABLE :: pts_ran + REAL(wp), PUBLIC, DIMENSION(:,:,:,:,:), ALLOCATABLE :: pts_ran !! * Substitutions # include "do_loop_substitute.h90" @@ -48,8 +48,8 @@ CONTAINS INTEGER :: ji, jj, jk, jts, jdof ! dummy loop indices INTEGER :: jim1, jjm1, jkm1 ! incremented indices INTEGER :: jip1, jjp1, jkp1 ! - - - REAL(dp) :: zdtsim, zdtsjm, zdtskm ! temporary scalars - REAL(dp) :: zdtsip, zdtsjp, zdtskp, zdts ! - - + REAL(wp) :: zdtsim, zdtsjm, zdtskm ! temporary scalars + REAL(wp) :: zdtsip, zdtsjp, zdtskp, zdts ! - - !!---------------------------------------------------------------------- DO jts = 1, jpts @@ -118,7 +118,7 @@ CONTAINS ! Lateral boundary conditions on pts_ran DO jdof = 1, nn_sto_eos DO jts = 1, jpts - CALL lbc_lnk( 'stopts', pts_ran(:,:,:,jts,jdof), 'T' , 1._dp ) + CALL lbc_lnk( 'stopts', pts_ran(:,:,:,jts,jdof), 'T' , 1._wp ) END DO END DO diff --git a/src/OCE/STO/storng.F90 b/src/OCE/STO/storng.F90 index 45a76c4ce796dfa4c7174e190c8077e0a973fb29..57eef3779884c1bcfe9b72f473f8ce55f2bda734 100644 --- a/src/OCE/STO/storng.F90 +++ b/src/OCE/STO/storng.F90 @@ -53,7 +53,7 @@ MODULE storng ! Variables to store 2 Gaussian random numbers with current index (ig) INTEGER(KIND=i8), SAVE :: ig=1 - REAL(KIND=dp), SAVE :: gran1, gran2 + REAL(KIND=wp), SAVE :: gran1, gran2 !! * Substitutions # include "do_loop_substitute.h90" @@ -271,9 +271,9 @@ CONTAINS !! !! -------------------------------------------------------------------- IMPLICIT NONE - REAL(KIND=dp) :: uran + REAL(KIND=wp) :: uran - uran = half * ( one + REAL(kiss(),dp) / HUGE(1._wp) ) + uran = half * ( one + REAL(kiss(),wp) / HUGE(1._wp) ) END SUBROUTINE kiss_uniform @@ -291,13 +291,13 @@ CONTAINS !! !! -------------------------------------------------------------------- IMPLICIT NONE - REAL(KIND=dp) :: gran, u1, u2, rsq, fac + REAL(KIND=wp) :: gran, u1, u2, rsq, fac IF (ig.EQ.1) THEN rsq = two DO WHILE ( (rsq.GE.one).OR. (rsq.EQ.zero) ) - u1 = REAL(kiss(),dp) / HUGE(1._wp) - u2 = REAL(kiss(),dp) / HUGE(1._wp) + u1 = REAL(kiss(),wp) / HUGE(1._wp) + u2 = REAL(kiss(),wp) / HUGE(1._wp) rsq = u1*u1 + u2*u2 ENDDO fac = SQRT(-two*LOG(rsq)/rsq) @@ -326,7 +326,7 @@ CONTAINS REAL(KIND=wp), PARAMETER :: p1 = 4.5_8 REAL(KIND=wp), PARAMETER :: p2 = 2.50407739677627_8 ! 1+LOG(9/2) REAL(KIND=wp), PARAMETER :: p3 = 1.38629436111989_8 ! LOG(4) - REAL(KIND=dp) :: gamr, k, u1, u2, b, c, d, xx, yy, zz, rr, ee + REAL(KIND=wp) :: gamr, k, u1, u2, b, c, d, xx, yy, zz, rr, ee LOGICAL :: accepted IF (k.GT.one) THEN @@ -391,7 +391,7 @@ CONTAINS IMPLICIT NONE INTEGER(KIND=i8), DIMENSION(:) :: a INTEGER(KIND=i8) :: n, k, i, j, atmp - REAL(KIND=dp) :: uran + REAL(KIND=wp) :: uran ! Select the sample using the swapping method ! (see Devroye, Non-Uniform Random Variate Generation, p. 612) diff --git a/src/OCE/TDE/tide_mod.F90 b/src/OCE/TDE/tide_mod.F90 index 4e857ec80bfd730a440e2c1b68f1862571bc3ee8..7d13bf43141b43146d75e84e9ebef17f83e48214 100644 --- a/src/OCE/TDE/tide_mod.F90 +++ b/src/OCE/TDE/tide_mod.F90 @@ -62,49 +62,49 @@ MODULE tide_mod LOGICAL , PUBLIC :: ln_scal_load !: LOGICAL , PUBLIC :: ln_tide_ramp !: INTEGER , PUBLIC :: nb_harmo !: Number of active tidal components - REAL(dp), PUBLIC :: rn_tide_ramp_dt !: - REAL(dp), PUBLIC :: rn_scal_load !: + REAL(wp), PUBLIC :: rn_tide_ramp_dt !: + REAL(wp), PUBLIC :: rn_scal_load !: CHARACTER(lc), PUBLIC :: cn_tide_load !: - REAL(dp) :: rn_tide_gamma ! Tidal tilt factor + REAL(wp) :: rn_tide_gamma ! Tidal tilt factor - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pot_astro !: tidal potential - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: pot_astro_comp ! tidal-potential component - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_pot, phi_pot - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_load, phi_load + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pot_astro !: tidal potential + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: pot_astro_comp ! tidal-potential component + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_pot, phi_pot + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_load, phi_load - REAL(dp) :: rn_tide_ramp_t ! Elapsed time in seconds + REAL(wp) :: rn_tide_ramp_t ! Elapsed time in seconds - REAL(dp) :: sh_T, sh_s, sh_h, sh_p, sh_p1 ! astronomic angles - REAL(dp) :: sh_xi, sh_nu, sh_nuprim, sh_nusec, sh_R ! - REAL(dp) :: sh_I, sh_x1ra, sh_N ! + REAL(wp) :: sh_T, sh_s, sh_h, sh_p, sh_p1 ! astronomic angles + REAL(wp) :: sh_xi, sh_nu, sh_nuprim, sh_nusec, sh_R ! + REAL(wp) :: sh_I, sh_x1ra, sh_N ! ! Longitudes on 1 Jan 1900, 00h and angular velocities (units of deg and ! deg/h, respectively. The values of these module variables have been copied ! from subroutine astronomic_angle of the version of this module used in ! release version 4.0 of NEMO. - REAL(dp) :: rlon00_N = 259.1560564_wp ! Longitude of ascending lunar node - REAL(dp) :: romega_N = -.0022064139_wp - REAL(dp) :: rlon00_T = 180.0_wp ! Mean solar angle (GMT) - REAL(dp) :: romega_T = 15.0_wp - REAL(dp) :: rlon00_h = 280.1895014_wp ! Mean solar Longitude - REAL(dp) :: romega_h = .0410686387_wp - REAL(dp) :: rlon00_s = 277.0256206_wp ! Mean lunar Longitude - REAL(dp) :: romega_s = .549016532_wp - REAL(dp) :: rlon00_p1 = 281.2208569_wp ! Longitude of solar perigee - REAL(dp) :: romega_p1 = .000001961_wp - REAL(dp) :: rlon00_p = 334.3837214_wp ! Longitude of lunar perigee - REAL(dp) :: romega_p = .004641834_wp + REAL(wp) :: rlon00_N = 259.1560564_wp ! Longitude of ascending lunar node + REAL(wp) :: romega_N = -.0022064139_wp + REAL(wp) :: rlon00_T = 180.0_wp ! Mean solar angle (GMT) + REAL(wp) :: romega_T = 15.0_wp + REAL(wp) :: rlon00_h = 280.1895014_wp ! Mean solar Longitude + REAL(wp) :: romega_h = .0410686387_wp + REAL(wp) :: rlon00_s = 277.0256206_wp ! Mean lunar Longitude + REAL(wp) :: romega_s = .549016532_wp + REAL(wp) :: rlon00_p1 = 281.2208569_wp ! Longitude of solar perigee + REAL(wp) :: romega_p1 = .000001961_wp + REAL(wp) :: rlon00_p = 334.3837214_wp ! Longitude of lunar perigee + REAL(wp) :: romega_p = .004641834_wp ! Values of cos(i)*cos(epsilon), rcice, and sin(incl)*sin(epsilon), rsise, ! where i is the inclination of the orbit of the Moon w.r.t. the ecliptic and ! epsilon the obliquity of the ecliptic on 1 January 1900, 00h. The values of ! these module variables have been copied from subroutine astronomic_angle ! (computation of the cosine of inclination of orbit of Moon to the celestial ! equator) of the version of this module used in release version 4.0 of NEMO. - REAL(dp) :: rcice = 0.913694997_wp - REAL(dp) :: rsise = 0.035692561_wp + REAL(wp) :: rcice = 0.913694997_wp + REAL(wp) :: rsise = 0.035692561_wp ! Coefficients used to compute sh_xi and sh_nu in subroutine astronomic_angle ! according to two equations given in the explanation of Table 6 of S58 - REAL(dp) :: rxinu1, rxinu2 + REAL(wp) :: rxinu1, rxinu2 !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -334,7 +334,7 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zcons, ztmp1, ztmp2, zlat, zlon, ztmp, zamp, zcs ! local scalar + REAL(wp) :: zcons, ztmp1, ztmp2, zlat, zlon, ztmp, zamp, zcs ! local scalar !!---------------------------------------------------------------------- IF( ln_read_load ) THEN @@ -388,7 +388,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: inum ! Logical unit of input file INTEGER :: ji, jj, itide ! dummy loop indices - REAL(dp), DIMENSION(jpi,jpj) :: ztr, zti !: workspace to read in tidal harmonics data + REAL(wp), DIMENSION(jpi,jpj) :: ztr, zti !: workspace to read in tidal harmonics data !!---------------------------------------------------------------------- IF(lwp) THEN WRITE(numout,*) @@ -470,8 +470,8 @@ CONTAINS !! ** Purpose : Compute astronomic angles !!---------------------------------------------------------------------- INTEGER :: psec_day ! Number of seconds from midnight - REAL(dp) :: zp, zq, zt2, zs2, ztgI2, zP1, ztgn2, zat1, zat2 - REAL(dp) :: zqy , zsy, zday, zdj, zhfrac, zt + REAL(wp) :: zp, zq, zt2, zs2, ztgI2, zP1, ztgn2, zat1, zat2 + REAL(wp) :: zqy , zsy, zday, zdj, zhfrac, zt !!---------------------------------------------------------------------- ! ! Computation of the time from 1 Jan 1900, 00h in years @@ -551,7 +551,7 @@ CONTAINS TYPE(tide_harmonic), DIMENSION(:), POINTER :: ptide_harmo ! Oscillation parameters of selected tidal components ! INTEGER :: jh - REAL(dp) :: zscale + REAL(wp) :: zscale !!---------------------------------------------------------------------- ! zscale = rad / 3600.0_wp @@ -615,8 +615,8 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: kformula ! - REAL(dp) :: zf - REAL(dp) :: zs, zf1, zf2 + REAL(wp) :: zf + REAL(wp) :: zs, zf1, zf2 CHARACTER(LEN=3) :: clformula !!---------------------------------------------------------------------- ! @@ -696,7 +696,7 @@ CONTAINS INTEGER,DIMENSION(12) :: idayt = (/ 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 /) INTEGER,DIMENSION(12) :: idays INTEGER :: inc, ji, zyq - REAL(dp) :: dayjul + REAL(wp) :: dayjul !!---------------------------------------------------------------------- ! idays(1) = 0 @@ -722,11 +722,11 @@ CONTAINS !! !! ** Action : pot_astro actronomical potential !!---------------------------------------------------------------------- - REAL(dp), INTENT(in) :: pdelta ! Temporal offset in seconds + REAL(wp), INTENT(in) :: pdelta ! Temporal offset in seconds INTEGER, INTENT(IN) :: Kmm ! Time level index INTEGER :: jk ! Dummy loop index - REAL(dp) :: zt, zramp ! Local scalars - REAL(dp), DIMENSION(nb_harmo) :: zwt ! Temporary array + REAL(wp) :: zt, zramp ! Local scalars + REAL(wp), DIMENSION(nb_harmo) :: zwt ! Temporary array !!---------------------------------------------------------------------- ! zwt(:) = tide_harmonics(:)%omega * pdelta diff --git a/src/OCE/TRA/eosbn2.F90 b/src/OCE/TRA/eosbn2.F90 index 5793305d6785e2073edfa48a8975848f221c0f4d..9e50c3e4bbee01f6516f7ffa9cf7812d24e6dc57 100644 --- a/src/OCE/TRA/eosbn2.F90 +++ b/src/OCE/TRA/eosbn2.F90 @@ -88,95 +88,95 @@ MODULE eosbn2 INTEGER , PARAMETER :: np_seos = 1 ! parameter for using Simplified Equation of state ! !!! simplified eos coefficients (default value: Vallis 2006) - REAL(dp), PUBLIC :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff. - REAL(dp), PUBLIC :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff. - REAL(dp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 - REAL(dp) :: rn_lambda2 = 5.4914e-4_wp ! cabbeling coeff. in S^2 - REAL(dp) :: rn_mu1 = 1.4970e-4_wp ! thermobaric coeff. in T - REAL(dp) :: rn_mu2 = 1.1090e-5_wp ! thermobaric coeff. in S - REAL(dp) :: rn_nu = 2.4341e-3_wp ! cabbeling coeff. in theta*salt + REAL(wp), PUBLIC :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff. + REAL(wp), PUBLIC :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff. + REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 + REAL(wp) :: rn_lambda2 = 5.4914e-4_wp ! cabbeling coeff. in S^2 + REAL(wp) :: rn_mu1 = 1.4970e-4_wp ! thermobaric coeff. in T + REAL(wp) :: rn_mu2 = 1.1090e-5_wp ! thermobaric coeff. in S + REAL(wp) :: rn_nu = 2.4341e-3_wp ! cabbeling coeff. in theta*salt ! TEOS10/EOS80 parameters - REAL(dp) :: r1_S0, r1_T0, r1_Z0, rdeltaS + REAL(wp) :: r1_S0, r1_T0, r1_Z0, rdeltaS ! EOS parameters - REAL(dp) :: EOS000 , EOS100 , EOS200 , EOS300 , EOS400 , EOS500 , EOS600 - REAL(dp) :: EOS010 , EOS110 , EOS210 , EOS310 , EOS410 , EOS510 - REAL(dp) :: EOS020 , EOS120 , EOS220 , EOS320 , EOS420 - REAL(dp) :: EOS030 , EOS130 , EOS230 , EOS330 - REAL(dp) :: EOS040 , EOS140 , EOS240 - REAL(dp) :: EOS050 , EOS150 - REAL(dp) :: EOS060 - REAL(dp) :: EOS001 , EOS101 , EOS201 , EOS301 , EOS401 - REAL(dp) :: EOS011 , EOS111 , EOS211 , EOS311 - REAL(dp) :: EOS021 , EOS121 , EOS221 - REAL(dp) :: EOS031 , EOS131 - REAL(dp) :: EOS041 - REAL(dp) :: EOS002 , EOS102 , EOS202 - REAL(dp) :: EOS012 , EOS112 - REAL(dp) :: EOS022 - REAL(dp) :: EOS003 , EOS103 - REAL(dp) :: EOS013 + REAL(wp) :: EOS000 , EOS100 , EOS200 , EOS300 , EOS400 , EOS500 , EOS600 + REAL(wp) :: EOS010 , EOS110 , EOS210 , EOS310 , EOS410 , EOS510 + REAL(wp) :: EOS020 , EOS120 , EOS220 , EOS320 , EOS420 + REAL(wp) :: EOS030 , EOS130 , EOS230 , EOS330 + REAL(wp) :: EOS040 , EOS140 , EOS240 + REAL(wp) :: EOS050 , EOS150 + REAL(wp) :: EOS060 + REAL(wp) :: EOS001 , EOS101 , EOS201 , EOS301 , EOS401 + REAL(wp) :: EOS011 , EOS111 , EOS211 , EOS311 + REAL(wp) :: EOS021 , EOS121 , EOS221 + REAL(wp) :: EOS031 , EOS131 + REAL(wp) :: EOS041 + REAL(wp) :: EOS002 , EOS102 , EOS202 + REAL(wp) :: EOS012 , EOS112 + REAL(wp) :: EOS022 + REAL(wp) :: EOS003 , EOS103 + REAL(wp) :: EOS013 ! ALPHA parameters - REAL(dp) :: ALP000 , ALP100 , ALP200 , ALP300 , ALP400 , ALP500 - REAL(dp) :: ALP010 , ALP110 , ALP210 , ALP310 , ALP410 - REAL(dp) :: ALP020 , ALP120 , ALP220 , ALP320 - REAL(dp) :: ALP030 , ALP130 , ALP230 - REAL(dp) :: ALP040 , ALP140 - REAL(dp) :: ALP050 - REAL(dp) :: ALP001 , ALP101 , ALP201 , ALP301 - REAL(dp) :: ALP011 , ALP111 , ALP211 - REAL(dp) :: ALP021 , ALP121 - REAL(dp) :: ALP031 - REAL(dp) :: ALP002 , ALP102 - REAL(dp) :: ALP012 - REAL(dp) :: ALP003 + REAL(wp) :: ALP000 , ALP100 , ALP200 , ALP300 , ALP400 , ALP500 + REAL(wp) :: ALP010 , ALP110 , ALP210 , ALP310 , ALP410 + REAL(wp) :: ALP020 , ALP120 , ALP220 , ALP320 + REAL(wp) :: ALP030 , ALP130 , ALP230 + REAL(wp) :: ALP040 , ALP140 + REAL(wp) :: ALP050 + REAL(wp) :: ALP001 , ALP101 , ALP201 , ALP301 + REAL(wp) :: ALP011 , ALP111 , ALP211 + REAL(wp) :: ALP021 , ALP121 + REAL(wp) :: ALP031 + REAL(wp) :: ALP002 , ALP102 + REAL(wp) :: ALP012 + REAL(wp) :: ALP003 ! BETA parameters - REAL(dp) :: BET000 , BET100 , BET200 , BET300 , BET400 , BET500 - REAL(dp) :: BET010 , BET110 , BET210 , BET310 , BET410 - REAL(dp) :: BET020 , BET120 , BET220 , BET320 - REAL(dp) :: BET030 , BET130 , BET230 - REAL(dp) :: BET040 , BET140 - REAL(dp) :: BET050 - REAL(dp) :: BET001 , BET101 , BET201 , BET301 - REAL(dp) :: BET011 , BET111 , BET211 - REAL(dp) :: BET021 , BET121 - REAL(dp) :: BET031 - REAL(dp) :: BET002 , BET102 - REAL(dp) :: BET012 - REAL(dp) :: BET003 + REAL(wp) :: BET000 , BET100 , BET200 , BET300 , BET400 , BET500 + REAL(wp) :: BET010 , BET110 , BET210 , BET310 , BET410 + REAL(wp) :: BET020 , BET120 , BET220 , BET320 + REAL(wp) :: BET030 , BET130 , BET230 + REAL(wp) :: BET040 , BET140 + REAL(wp) :: BET050 + REAL(wp) :: BET001 , BET101 , BET201 , BET301 + REAL(wp) :: BET011 , BET111 , BET211 + REAL(wp) :: BET021 , BET121 + REAL(wp) :: BET031 + REAL(wp) :: BET002 , BET102 + REAL(wp) :: BET012 + REAL(wp) :: BET003 ! PEN parameters - REAL(dp) :: PEN000 , PEN100 , PEN200 , PEN300 , PEN400 - REAL(dp) :: PEN010 , PEN110 , PEN210 , PEN310 - REAL(dp) :: PEN020 , PEN120 , PEN220 - REAL(dp) :: PEN030 , PEN130 - REAL(dp) :: PEN040 - REAL(dp) :: PEN001 , PEN101 , PEN201 - REAL(dp) :: PEN011 , PEN111 - REAL(dp) :: PEN021 - REAL(dp) :: PEN002 , PEN102 - REAL(dp) :: PEN012 + REAL(wp) :: PEN000 , PEN100 , PEN200 , PEN300 , PEN400 + REAL(wp) :: PEN010 , PEN110 , PEN210 , PEN310 + REAL(wp) :: PEN020 , PEN120 , PEN220 + REAL(wp) :: PEN030 , PEN130 + REAL(wp) :: PEN040 + REAL(wp) :: PEN001 , PEN101 , PEN201 + REAL(wp) :: PEN011 , PEN111 + REAL(wp) :: PEN021 + REAL(wp) :: PEN002 , PEN102 + REAL(wp) :: PEN012 ! ALPHA_PEN parameters - REAL(dp) :: APE000 , APE100 , APE200 , APE300 - REAL(dp) :: APE010 , APE110 , APE210 - REAL(dp) :: APE020 , APE120 - REAL(dp) :: APE030 - REAL(dp) :: APE001 , APE101 - REAL(dp) :: APE011 - REAL(dp) :: APE002 + REAL(wp) :: APE000 , APE100 , APE200 , APE300 + REAL(wp) :: APE010 , APE110 , APE210 + REAL(wp) :: APE020 , APE120 + REAL(wp) :: APE030 + REAL(wp) :: APE001 , APE101 + REAL(wp) :: APE011 + REAL(wp) :: APE002 ! BETA_PEN parameters - REAL(dp) :: BPE000 , BPE100 , BPE200 , BPE300 - REAL(dp) :: BPE010 , BPE110 , BPE210 - REAL(dp) :: BPE020 , BPE120 - REAL(dp) :: BPE030 - REAL(dp) :: BPE001 , BPE101 - REAL(dp) :: BPE011 - REAL(dp) :: BPE002 + REAL(wp) :: BPE000 , BPE100 , BPE200 , BPE300 + REAL(wp) :: BPE010 , BPE110 , BPE210 + REAL(wp) :: BPE020 , BPE120 + REAL(wp) :: BPE030 + REAL(wp) :: BPE001 , BPE101 + REAL(wp) :: BPE011 + REAL(wp) :: BPE002 !! * Substitutions # include "do_loop_substitute.h90" @@ -192,8 +192,8 @@ CONTAINS !! REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] ! ! 2 : salinity [psu] - REAL(dp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] !! CALL eos_insitu_t( pts, is_tile(pts), prd, is_tile(prd), pdep, is_tile(pdep) ) END SUBROUTINE eos_insitu @@ -235,12 +235,14 @@ CONTAINS INTEGER , INTENT(in ) :: ktts, ktrd, ktdep REAL(dp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] ! ! 2 : salinity [psu] - REAL(dp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] - REAL(dp), DIMENSION(A2D_T(ktdep),JPK ), INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] + REAL(wp), DIMENSION(A2D_T(ktdep),JPK ), INTENT(in ) :: pdep ! depth [m] ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zt , zh , zs , ztm ! local scalars - REAL(dp) :: zn , zn0, zn1, zn2, zn3 ! - - + REAL(wp) :: zt, zh, ztm! local scalars + REAL(dp) :: zs! local scalars + REAL(wp) :: zn1, zn2! - - + REAL(dp) :: zn, zn0, zn3! - - !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('eos-insitu') @@ -300,7 +302,7 @@ CONTAINS ! END SELECT ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ' ) ! IF( ln_timing ) CALL timing_stop('eos-insitu') ! @@ -311,9 +313,9 @@ CONTAINS !! REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] ! ! 2 : salinity [psu] - REAL(dp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] REAL(dp), DIMENSION(:,:,:) , INTENT( out) :: prhop ! potential density (surface referenced) - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] !! CALL eos_insitu_pot_t( pts, is_tile(pts), prd, is_tile(prd), prhop, is_tile(prhop), pdep, is_tile(pdep) ) END SUBROUTINE eos_insitu_pot @@ -335,15 +337,17 @@ CONTAINS INTEGER , INTENT(in ) :: ktts, ktrd, ktrhop, ktdep REAL(dp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] ! ! 2 : salinity [psu] - REAL(dp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] + REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] REAL(dp), DIMENSION(A2D_T(ktrhop),JPK ), INTENT( out) :: prhop ! potential density (surface referenced) - REAL(dp), DIMENSION(A2D_T(ktdep) ,JPK ), INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(A2D_T(ktdep) ,JPK ), INTENT(in ) :: pdep ! depth [m] ! INTEGER :: ji, jj, jk, jsmp ! dummy loop indices INTEGER :: jdof - REAL(dp) :: zt , zh , zstemp, zs , ztm ! local scalars - REAL(dp) :: zn , zn0, zn1, zn2, zn3 ! - - - REAL(dp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors + REAL(wp) :: zt, zh, zstemp, ztm! local scalars + REAL(dp) :: zs! local scalars + REAL(wp) :: zn1, zn2, zn3! - - + REAL(dp) :: zn, zn0! - - + REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('eos-pot') @@ -468,7 +472,7 @@ CONTAINS ! END SELECT ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ' ) ! IF( ln_timing ) CALL timing_stop('eos-pot') ! @@ -477,10 +481,10 @@ CONTAINS SUBROUTINE eos_insitu_2d( pts, pdep, prd ) !! - REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] ! ! 2 : salinity [psu] - REAL(dp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] - REAL(dp), DIMENSION(:,:) , INTENT( out) :: prd ! in situ density + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:) , INTENT( out) :: prd ! in situ density !! CALL eos_insitu_2d_t( pts, is_tile(pts), pdep, is_tile(pdep), prd, is_tile(prd) ) END SUBROUTINE eos_insitu_2d @@ -498,14 +502,14 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: ktts, ktdep, ktrd - REAL(dp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] ! ! 2 : salinity [psu] - REAL(dp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] - REAL(dp), DIMENSION(A2D_T(ktrd) ), INTENT( out) :: prd ! in situ density + REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(A2D_T(ktrd) ), INTENT( out) :: prd ! in situ density ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zt , zh , zs ! local scalars - REAL(dp) :: zn , zn0, zn1, zn2, zn3 ! - - + REAL(wp) :: zt , zh , zs ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('eos2d') @@ -567,7 +571,7 @@ CONTAINS ! END SELECT ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) ! IF( ln_timing ) CALL timing_stop('eos2d') ! @@ -576,9 +580,9 @@ CONTAINS SUBROUTINE eos_insitu_pot_2d( pts, prhop ) !! - REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] ! ! 2 : salinity [psu] - REAL(dp), DIMENSION(:,:) , INTENT( out) :: prhop ! potential density (surface referenced) + REAL(wp), DIMENSION(:,:) , INTENT( out) :: prhop ! potential density (surface referenced) !! CALL eos_insitu_pot_2d_t( pts, is_tile(pts), prhop, is_tile(prhop) ) END SUBROUTINE eos_insitu_pot_2d @@ -598,15 +602,15 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: ktts, ktrhop - REAL(dp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] ! ! 2 : salinity [psu] - REAL(dp), DIMENSION(A2D_T(ktrhop) ), INTENT( out) :: prhop ! potential density (surface referenced) + REAL(wp), DIMENSION(A2D_T(ktrhop) ), INTENT( out) :: prhop ! potential density (surface referenced) ! INTEGER :: ji, jj, jk, jsmp ! dummy loop indices INTEGER :: jdof - REAL(dp) :: zt , zh , zstemp, zs , ztm ! local scalars - REAL(dp) :: zn , zn0, zn1, zn2, zn3 ! - - - REAL(dp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors + REAL(wp) :: zt , zh , zstemp, zs , ztm ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - + REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('eos-pot') @@ -649,9 +653,9 @@ CONTAINS END_2D ! END SELECT - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' pot: ', kdim=1 ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' pot: ', kdim=1 ) ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' eos-pot: ' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' eos-pot: ' ) ! IF( ln_timing ) CALL timing_stop('eos-pot') ! @@ -662,7 +666,7 @@ CONTAINS !! INTEGER , INTENT(in ) :: Kmm ! time level index REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity - REAL(dp), DIMENSION(:,:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio + REAL(wp), DIMENSION(:,:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio !! CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) END SUBROUTINE rab_3d @@ -681,11 +685,11 @@ CONTAINS INTEGER , INTENT(in ) :: Kmm ! time level index INTEGER , INTENT(in ) :: ktts, ktab REAL(dp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in ) :: pts ! pot. temperature & salinity - REAL(dp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio + REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zt , zh , zs , ztm ! local scalars - REAL(dp) :: zn , zn0, zn1, zn2, zn3 ! - - + REAL(wp) :: zt , zh , zs , ztm ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('rab_3d') @@ -767,8 +771,8 @@ CONTAINS ! END SELECT ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=(pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', & - ! & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', & + ! & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ' ) ! IF( ln_timing ) CALL timing_stop('rab_3d') ! @@ -778,9 +782,9 @@ CONTAINS SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) !! INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity - REAL(dp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio !! CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) END SUBROUTINE rab_2d @@ -796,13 +800,13 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: Kmm ! time level index INTEGER , INTENT(in ) :: ktts, ktdep, ktab - REAL(dp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! pot. temperature & salinity - REAL(dp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] - REAL(dp), DIMENSION(A2D_T(ktab),JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio + REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zt , zh , zs ! local scalars - REAL(dp) :: zn , zn0, zn1, zn2, zn3 ! - - + REAL(wp) :: zt , zh , zs ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('rab_2d') @@ -886,8 +890,8 @@ CONTAINS ! END SELECT ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', & - ! & tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', & + ! & tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) ! IF( ln_timing ) CALL timing_stop('rab_2d') ! @@ -903,12 +907,12 @@ CONTAINS !! ** Action : - pab : thermal/haline expansion ratio at T-points !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(dp), DIMENSION(jpts) , INTENT(in ) :: pts ! pot. temperature & salinity - REAL(dp), INTENT(in ) :: pdep ! depth [m] - REAL(dp), DIMENSION(jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio + REAL(wp), DIMENSION(jpts) , INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio ! - REAL(dp) :: zt , zh , zs ! local scalars - REAL(dp) :: zn , zn0, zn1, zn2, zn3 ! - - + REAL(wp) :: zt , zh , zs ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('rab_0d') @@ -995,8 +999,8 @@ CONTAINS !! INTEGER , INTENT(in ) :: Kmm ! time level index REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] - REAL(dp), DIMENSION(:,:,:,:) , INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] - REAL(dp), DIMENSION(:,:,:) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] + REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] !! CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) END SUBROUTINE bn2 @@ -1019,11 +1023,11 @@ CONTAINS INTEGER , INTENT(in ) :: Kmm ! time level index INTEGER , INTENT(in ) :: ktab, ktn2 REAL(dp), DIMENSION(jpi,jpj, jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] - REAL(dp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] - REAL(dp), DIMENSION(A2D_T(ktn2),JPK ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] + REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] + REAL(wp), DIMENSION(A2D_T(ktn2),JPK ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zaw, zbw, zrw ! local scalars + REAL(wp) :: zaw, zbw, zrw ! local scalars !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('bn2') @@ -1040,7 +1044,7 @@ CONTAINS & / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) END_3D ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ' ) ! IF( ln_timing ) CALL timing_stop('bn2') ! @@ -1059,15 +1063,15 @@ CONTAINS !! Reference : TEOS-10, UNESCO !! Rational approximation to TEOS10 algorithm (rms error on WOA13 values: 4.0e-5 degC) !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: ctmp ! Cons. Temp [Celsius] - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ctmp ! Cons. Temp [Celsius] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] ! Leave result array automatic rather than making explicitly allocated - REAL(dp), DIMENSION(jpi,jpj) :: ptmp ! potential temperature [Celsius] + REAL(wp), DIMENSION(jpi,jpj) :: ptmp ! potential temperature [Celsius] ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zt , zs , ztm ! local scalars - REAL(dp) :: zn , zd ! local scalars - REAL(dp) :: zdeltaS , z1_S0 , z1_T0 + REAL(wp) :: zt , zs , ztm ! local scalars + REAL(wp) :: zn , zd ! local scalars + REAL(wp) :: zdeltaS , z1_S0 , z1_T0 !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('eos_pt_from_ct') @@ -1106,9 +1110,9 @@ CONTAINS SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) !! - REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] REAL(dp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] - REAL(dp), DIMENSION(:,:) , INTENT(out ) :: ptf ! freezing temperature [Celsius] + REAL(wp), DIMENSION(:,:) , INTENT(out ) :: ptf ! freezing temperature [Celsius] !! CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) END SUBROUTINE eos_fzp_2d @@ -1127,12 +1131,12 @@ CONTAINS !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kttf - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: psal ! salinity [psu] + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: psal ! salinity [psu] REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ), OPTIONAL :: pdep ! depth [m] - REAL(dp), DIMENSION(A2D_T(kttf)), INTENT(out ) :: ptf ! freezing temperature [Celsius] + REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out ) :: ptf ! freezing temperature [Celsius] ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zt, zs, z1_S0 ! local scalars + REAL(wp) :: zt, zs, z1_S0 ! local scalars !!---------------------------------------------------------------------- ! SELECT CASE ( neos ) @@ -1177,11 +1181,11 @@ CONTAINS !! !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 !!---------------------------------------------------------------------- - REAL(dp), INTENT(in ) :: psal ! salinity [psu] + REAL(wp), INTENT(in ) :: psal ! salinity [psu] REAL(wp), INTENT(in ), OPTIONAL :: pdep ! depth [m] - REAL(dp), INTENT(out) :: ptf ! freezing temperature [Celsius] + REAL(wp), INTENT(out) :: ptf ! freezing temperature [Celsius] ! - REAL(dp) :: zs ! local scalars + REAL(wp) :: zs ! local scalars !!---------------------------------------------------------------------- ! SELECT CASE ( neos ) @@ -1233,12 +1237,12 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: Kmm ! time level index REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity - REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab_pe ! alpha_pe and beta_pe - REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: ppen ! potential energy anomaly + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab_pe ! alpha_pe and beta_pe + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: ppen ! potential energy anomaly ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zt , zh , zs , ztm ! local scalars - REAL(dp) :: zn , zn0, zn1, zn2 ! - - + REAL(wp) :: zt , zh , zs , ztm ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2 ! - - !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('eos_pen') @@ -1811,4 +1815,4 @@ CONTAINS END SUBROUTINE eos_init !!====================================================================== -END MODULE eosbn2 +END MODULE eosbn2 \ No newline at end of file diff --git a/src/OCE/TRA/traadv.F90 b/src/OCE/TRA/traadv.F90 index 456408a96195be967e18f66f651b87d9f5df38ca..a1c03d929f5d5833bd0957275a76761a38fa437a 100644 --- a/src/OCE/TRA/traadv.F90 +++ b/src/OCE/TRA/traadv.F90 @@ -91,8 +91,8 @@ CONTAINS ! INTEGER :: ji, jj, jk ! dummy loop index ! TEMP: [tiling] This change not necessary and can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zvv, zww ! 3D workspace - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zvv, zww ! 3D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct LOGICAL :: lskip !!---------------------------------------------------------------------- @@ -200,8 +200,8 @@ CONTAINS IF( ln_tile .AND. .NOT. l_istiled ) CALL dom_tile_start( ldhold=.TRUE. ) ENDIF ! ! print mean trends (used for debugging) - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, & - ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only for the full domain @@ -311,4 +311,4 @@ CONTAINS END SUBROUTINE tra_adv_init !!====================================================================== -END MODULE traadv +END MODULE traadv \ No newline at end of file diff --git a/src/OCE/TRA/traadv_cen.F90 b/src/OCE/TRA/traadv_cen.F90 index 028eca80483b6e000d2c357a984978789b13a645..c17aeffccff9f2129873181d8b4826ec22abc86c 100644 --- a/src/OCE/TRA/traadv_cen.F90 +++ b/src/OCE/TRA/traadv_cen.F90 @@ -31,7 +31,7 @@ MODULE traadv_cen PUBLIC tra_adv_cen ! called by traadv.F90 - REAL(dp) :: r1_6 = 1._wp / 6._wp ! =1/6 + REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 LOGICAL :: l_trd ! flag to compute trends LOGICAL :: l_ptr ! flag to compute poleward transport @@ -74,14 +74,14 @@ CONTAINS INTEGER , INTENT(in ) :: kn_cen_h ! =2/4 (2nd or 4th order scheme) INTEGER , INTENT(in ) :: kn_cen_v ! =2/4 (2nd or 4th order scheme) ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct - REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk, jn ! dummy loop indices INTEGER :: ierr ! local integer - REAL(dp) :: zC2t_u, zC4t_u ! local scalars - REAL(dp) :: zC2t_v, zC4t_v ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy, zwz, ztu, ztv, ztw + REAL(wp) :: zC2t_u, zC4t_u ! local scalars + REAL(wp) :: zC2t_v, zC4t_v ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy, zwz, ztu, ztv, ztw !!---------------------------------------------------------------------- ! #if defined key_loop_fusion @@ -124,7 +124,7 @@ CONTAINS ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) END_3D - IF (nn_hls==1) CALL lbc_lnk( 'traadv_cen', ztu, 'U', -1.0_dp , ztv, 'V', -1.0_dp, ld4only= .TRUE. ) ! Lateral boundary cond. + IF (nn_hls==1) CALL lbc_lnk( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. ! DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 ) ! Horizontal advective fluxes zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! C2 interpolation of T at u- & v-points (x2) @@ -136,7 +136,7 @@ CONTAINS zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * zC4t_u zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v END_3D - IF (nn_hls==1) CALL lbc_lnk( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) + IF (nn_hls==1) CALL lbc_lnk( 'traadv_cen', zwx, 'U', -1._wp , zwy, 'V', -1._wp ) ! CASE DEFAULT CALL ctl_stop( 'traadv_cen: wrong value for nn_cen' ) diff --git a/src/OCE/TRA/traadv_cen_lf.F90 b/src/OCE/TRA/traadv_cen_lf.F90 index 33f6b7bd5840b1ad56322bb5953596923eb945e3..1ca56d6a4402365ae8b966429b71915a66bfd54a 100644 --- a/src/OCE/TRA/traadv_cen_lf.F90 +++ b/src/OCE/TRA/traadv_cen_lf.F90 @@ -28,7 +28,7 @@ MODULE traadv_cen_lf PUBLIC tra_adv_cen_lf ! called by traadv.F90 - REAL(dp) :: r1_6 = 1._wp / 6._wp ! =1/6 + REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 LOGICAL :: l_trd ! flag to compute trends LOGICAL :: l_ptr ! flag to compute poleward transport @@ -73,15 +73,15 @@ CONTAINS INTEGER , INTENT(in ) :: kn_cen_v ! =2/4 (2nd or 4th order scheme) ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components - REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk, jn ! dummy loop indices INTEGER :: ierr ! local integer - REAL(dp) :: zC2t_u, zC4t_u ! local scalars - REAL(dp) :: zC2t_v, zC4t_v ! - - - REAL(dp) :: ztu_im1, ztu_ip1 ! - - - REAL(dp) :: ztv_jm1, ztv_jp1 ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy, zwz, ztw + REAL(wp) :: zC2t_u, zC4t_u ! local scalars + REAL(wp) :: zC2t_v, zC4t_v ! - - + REAL(wp) :: ztu_im1, ztu_ip1 ! - - + REAL(wp) :: ztv_jm1, ztv_jp1 ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy, zwz, ztw !!---------------------------------------------------------------------- ! IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -143,7 +143,7 @@ CONTAINS END_3D ! CASE( 4 ) !* 4th order compact - CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! ztw = interpolated value of T at w-point + CALL interp_4th_cpt( CASTDP(pt(:,:,:,jn,Kmm)) , ztw ) ! ztw = interpolated value of T at w-point DO_3D( 0, 0, 0, 0, 2, jpkm1 ) zwz(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) END_3D @@ -171,9 +171,9 @@ CONTAINS END_3D ! ! trend diagnostics IF( l_trd ) THEN - CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, CASTDP(pU), pt(:,:,:,jn,Kmm) ) - CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, CASTDP(pV), pt(:,:,:,jn,Kmm) ) - CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, CASTDP(pW), pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, CASTDP(pt(:,:,:,jn,Kmm)) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, CASTDP(pt(:,:,:,jn,Kmm)) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, CASTDP(pt(:,:,:,jn,Kmm)) ) ENDIF ! ! "Poleward" heat and salt transports IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) diff --git a/src/OCE/TRA/traadv_fct.F90 b/src/OCE/TRA/traadv_fct.F90 index 21a2c2d2a449d2126af7144ff293cbe2c8c175b7..d7168df14a5eb5ddd92e79b4ae8a9ecbcc97bf7f 100644 --- a/src/OCE/TRA/traadv_fct.F90 +++ b/src/OCE/TRA/traadv_fct.F90 @@ -37,7 +37,7 @@ MODULE traadv_fct LOGICAL :: l_trd ! flag to compute trends LOGICAL :: l_ptr ! flag to compute poleward transport LOGICAL :: l_hst ! flag to compute heat/salt transport - REAL(dp) :: r1_6 = 1._wp / 6._wp ! =1/6 + REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 ! ! tridiag solver associated indices: INTEGER, PARAMETER :: np_NH = 0 ! Neumann homogeneous boundary condition @@ -77,18 +77,19 @@ CONTAINS INTEGER , INTENT(in ) :: kjpt ! number of tracers INTEGER , INTENT(in ) :: kn_fct_h ! order of the FCT scheme (=2 or 4) INTEGER , INTENT(in ) :: kn_fct_v ! order of the FCT scheme (=2 or 4) - REAL(dp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case - REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: ztra ! local scalar - REAL(dp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u ! - - - REAL(dp) :: zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup + REAL(wp) :: ztra ! local scalar + REAL(wp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u ! - - + REAL(wp) :: zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwz, ztu, ztv, zltu, zltv, ztw + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup LOGICAL :: ll_zAimp ! flag to apply adaptive implicit vertical advection !!---------------------------------------------------------------------- ! @@ -239,7 +240,7 @@ CONTAINS END_2D END DO ! NOTE [ comm_cleanup ] : need to change sign to ensure halo 1 - halo 2 compatibility - CALL lbc_lnk( 'traadv_fct', zltu, 'T', -1.0_dp , zltv, 'T', -1.0_dp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) + CALL lbc_lnk( 'traadv_fct', zltu, 'T', -1.0_wp , zltv, 'T', -1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) ! DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points @@ -262,7 +263,7 @@ CONTAINS ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) END_3D - IF (nn_hls==1) CALL lbc_lnk( 'traadv_fct', ztu, 'U', -1.0_dp , ztv, 'V', -1.0_dp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) + IF (nn_hls==1) CALL lbc_lnk( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) ! DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points (x2) @@ -298,9 +299,10 @@ CONTAINS ENDIF ! IF (nn_hls==1) THEN - CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_dp, zwx, 'U', -1.0_dp , zwy, 'V', -1.0_dp, zwz, 'T', 1.0_dp ) + CALL lbc_lnk( 'traadv_fct', zwx, 'U', -1.0_dp , zwy, 'V', -1.0_dp) + CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp , zwz, 'T', 1.0_wp ) ELSE - CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_dp) + CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) END IF ! IF ( ll_zAimp ) THEN @@ -398,10 +400,11 @@ CONTAINS !! in-space based differencing for fluid !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(dp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pbef ! before field - REAL(dp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(in ) :: paft ! after field - REAL(dp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(inout) :: paa, pbb, pcc ! monotonic fluxes in the 3 directions + REAL(wp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(in ) :: paft ! after field + REAL(wp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(inout) :: pcc! monotonic fluxes in the 3 directions + REAL(dp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(inout) :: paa, pbb! monotonic fluxes in the 3 directions ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ikm1 ! local integer @@ -491,10 +494,10 @@ CONTAINS !! ** Method : 4th order compact interpolation !!---------------------------------------------------------------------- REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt_in ! now tracer fields - REAL(dp),DIMENSION(jpi,jpj,jpk), INTENT( out) :: pt_out ! now tracer field interpolated at w-pts + REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT( out) :: pt_out ! now tracer field interpolated at w-pts ! INTEGER :: ji, jj, jk ! dummy loop integers - REAL(dp),DIMENSION(jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt + REAL(wp),DIMENSION(jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt !!---------------------------------------------------------------------- DO_3D( 1, 1, 1, 1, 3, jpkm1 ) !== build the three diagonal matrix ==! @@ -553,11 +556,11 @@ CONTAINS !! ** Method : 4th order compact interpolation !!---------------------------------------------------------------------- REAL(dp),DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt_in ! field at t-point - REAL(dp),DIMENSION(A2D(nn_hls) ,jpk), INTENT( out) :: pt_out ! field interpolated at w-point + REAL(wp),DIMENSION(A2D(nn_hls) ,jpk), INTENT( out) :: pt_out ! field interpolated at w-point ! INTEGER :: ji, jj, jk ! dummy loop integers INTEGER :: ikt, ikb ! local integers - REAL(dp),DIMENSION(A2D(nn_hls),jpk) :: zwd, zwi, zws, zwrm, zwt + REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwd, zwi, zws, zwrm, zwt !!---------------------------------------------------------------------- ! ! !== build the three diagonal matrix & the RHS ==! @@ -642,14 +645,14 @@ CONTAINS !! The solution is pta. !! The 3d array zwt is used as a work space array. !!---------------------------------------------------------------------- - REAL(dp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pD, pU, pL ! 3-diagonal matrix - REAL(dp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pRHS ! Right-Hand-Side - REAL(dp),DIMENSION(A2D(nn_hls),jpk), INTENT( out) :: pt_out !!gm field at level=F(klev) + REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pD, pU, pL ! 3-diagonal matrix + REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pRHS ! Right-Hand-Side + REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT( out) :: pt_out !!gm field at level=F(klev) INTEGER , INTENT(in ) :: klev ! =1 pt_out at w-level ! ! =0 pt at t-level INTEGER :: ji, jj, jk ! dummy loop integers INTEGER :: kstart ! local indices - REAL(dp),DIMENSION(A2D(nn_hls),jpk) :: zwt ! 3D work array + REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwt ! 3D work array !!---------------------------------------------------------------------- ! kstart = 1 + klev diff --git a/src/OCE/TRA/traadv_mus.F90 b/src/OCE/TRA/traadv_mus.F90 index fc3d019f14f5d01d54b10b6042e8f57d90504a41..51c28b648e97e9af04593e19e1fec10a6c053232 100644 --- a/src/OCE/TRA/traadv_mus.F90 +++ b/src/OCE/TRA/traadv_mus.F90 @@ -36,9 +36,9 @@ MODULE traadv_mus PUBLIC tra_adv_mus ! routine called by traadv.F90 - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits ! ! and in closed seas (orca 2 and 1 configurations) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xind !: mixed upstream/centered index + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xind !: mixed upstream/centered index LOGICAL :: l_trd ! flag to compute trends LOGICAL :: l_ptr ! flag to compute poleward transport @@ -79,17 +79,17 @@ CONTAINS CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) INTEGER , INTENT(in ) :: kjpt ! number of tracers LOGICAL , INTENT(in ) :: ld_msc_ups ! use upstream scheme within muscl - REAL(dp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct - REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk, jn ! dummy loop indices INTEGER :: ierr ! local integer - REAL(dp) :: zu, z0u, zzwx, zw , zalpha ! local scalars - REAL(dp) :: zv, z0v, zzwy, z0w ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zslpx ! 3D workspace - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zslpy ! - - + REAL(wp) :: zu, z0u, zzwx, zw , zalpha ! local scalars + REAL(wp) :: zv, z0v, zzwy, z0w ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zslpx ! 3D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zslpy ! - - !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -157,7 +157,7 @@ CONTAINS & 2.*ABS( zwy (ji,jj ,jk) ) ) END_3D ! NOTE [ comm_cleanup ] : need to change sign to ensure halo 1 - halo 2 compatibility - IF ( nn_hls==1 ) CALL lbc_lnk( 'traadv_mus', zslpx, 'T', -1.0_dp , zslpy, 'T', -1.0_dp ) ! lateral boundary conditions (changed sign) + IF ( nn_hls==1 ) CALL lbc_lnk( 'traadv_mus', zslpx, 'T', -1.0_wp , zslpy, 'T', -1.0_wp ) ! lateral boundary conditions (changed sign) ! DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !-- MUSCL horizontal advective fluxes ! MUSCL fluxes @@ -242,4 +242,4 @@ CONTAINS END SUBROUTINE tra_adv_mus !!====================================================================== -END MODULE traadv_mus +END MODULE traadv_mus \ No newline at end of file diff --git a/src/OCE/TRA/traadv_qck.F90 b/src/OCE/TRA/traadv_qck.F90 index e6a95ab4df49f715552795d98da5f5e7a8c72ccc..b1e5783e2b318701f9bfc2249f7b10ee8845de61 100644 --- a/src/OCE/TRA/traadv_qck.F90 +++ b/src/OCE/TRA/traadv_qck.F90 @@ -35,7 +35,7 @@ MODULE traadv_qck PUBLIC tra_adv_qck ! routine called by step.F90 - REAL(dp) :: r1_6 = 1./ 6. ! 1/6 ratio + REAL(wp) :: r1_6 = 1./ 6. ! 1/6 ratio LOGICAL :: l_trd ! flag to compute trends LOGICAL :: l_ptr ! flag to compute poleward transport @@ -92,9 +92,9 @@ CONTAINS INTEGER , INTENT(in ) :: kit000 ! first time step index CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) INTEGER , INTENT(in ) :: kjpt ! number of tracers - REAL(dp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct - REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation !!---------------------------------------------------------------------- ! @@ -134,14 +134,14 @@ CONTAINS INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) INTEGER , INTENT(in ) :: kjpt ! number of tracers - REAL(dp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct - REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU ! i-velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU ! i-velocity components REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation !! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd !---------------------------------------------------------------------- ! ! ! =========== @@ -155,7 +155,7 @@ CONTAINS zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb) ! Upstream in the x-direction for the tracer zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer END_3D - IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_dp , zfd(:,:,:), 'T', 1.0_dp, ld4only= .TRUE. ) ! Lateral boundary conditions + IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, ld4only= .TRUE. ) ! Lateral boundary conditions ! ! Horizontal advective fluxes @@ -173,7 +173,7 @@ CONTAINS zfd(ji,jj,jk) = zdir * pt(ji+1,jj,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji ,jj,jk,jn,Kbb) ! FD in the x-direction for T END_3D !--- Lateral boundary conditions - IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_dp , zfd(:,:,:), 'T', 1.0_dp, zfc(:,:,:), 'T', 1.0_dp, zwx(:,:,:), 'T', 1.0_dp ) + IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwx(:,:,:), 'T', 1.0_wp ) !--- QUICKEST scheme CALL quickest( zfu, zfd, zfc, zwx ) @@ -182,7 +182,7 @@ CONTAINS DO_3D( nn_hls-1, nn_hls-1, 0, 0, 1, jpkm1 ) zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. END_3D - IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_dp, ld4only= .TRUE. ) ! Lateral boundary conditions + IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp, ld4only= .TRUE. ) ! Lateral boundary conditions ! ! Tracer flux on the x-direction @@ -219,14 +219,14 @@ CONTAINS INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) INTEGER , INTENT(in ) :: kjpt ! number of tracers - REAL(dp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct - REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pV ! j-velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pV ! j-velocity components REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation !! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace !---------------------------------------------------------------------- ! ! ! =========== @@ -243,7 +243,7 @@ CONTAINS zfd(ji,jj,jk) = pt(ji,jj+1,jk,jn,Kbb) END_3D - IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_dp , zfd(:,:,:), 'T', 1.0_dp, ld4only= .TRUE. ) ! Lateral boundary conditions + IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, ld4only= .TRUE. ) ! Lateral boundary conditions ! Correct zfd on northfold after lbc_lnk; see #2640 IF( nn_hls == 1 .AND. l_IdoNFold .AND. ntej == Nje0 ) THEN @@ -269,7 +269,7 @@ CONTAINS END_3D !--- Lateral boundary conditions - IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_dp , zfd(:,:,:), 'T', 1.0_dp, zfc(:,:,:), 'T', 1.0_dp, zwy(:,:,:), 'T', 1.0_dp ) + IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp ) !--- QUICKEST scheme CALL quickest( zfu, zfd, zfc, zwy ) @@ -278,7 +278,7 @@ CONTAINS DO_3D( 0, 0, nn_hls-1, nn_hls-1, 1, jpkm1 ) zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. END_3D - IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_dp, ld4only= .TRUE. ) !--- Lateral boundary conditions + IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp, ld4only= .TRUE. ) !--- Lateral boundary conditions ! ! Tracer flux on the x-direction DO_3D( 0, 0, 1, 0, 1, jpkm1 ) @@ -317,11 +317,11 @@ CONTAINS CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) INTEGER , INTENT(in ) :: kjpt ! number of tracers ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct - REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwz ! 3D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwz ! 3D workspace !!---------------------------------------------------------------------- ! zwz(:,:, 1 ) = 0._wp ! surface & bottom values set to zero for all tracers @@ -365,14 +365,14 @@ CONTAINS !! !! ** Method : !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point) - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point) + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux !! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zcoef1, zcoef2, zcoef3 ! local scalars - REAL(dp) :: zc, zcurv, zfho ! - - + REAL(wp) :: zcoef1, zcoef2, zcoef3 ! local scalars + REAL(wp) :: zc, zcurv, zfho ! - - !---------------------------------------------------------------------- ! DO_3D( 1, 0, 1, 0, 1, jpkm1 ) @@ -404,4 +404,4 @@ CONTAINS END SUBROUTINE quickest !!====================================================================== -END MODULE traadv_qck +END MODULE traadv_qck \ No newline at end of file diff --git a/src/OCE/TRA/traadv_qck_lf.F90 b/src/OCE/TRA/traadv_qck_lf.F90 index 0a7d243031b80314ec3e1ca41456542bf3adb4b0..b0f10a9c36f6165b010489c13bb8b0a32b84fd77 100644 --- a/src/OCE/TRA/traadv_qck_lf.F90 +++ b/src/OCE/TRA/traadv_qck_lf.F90 @@ -32,7 +32,7 @@ MODULE traadv_qck_lf PUBLIC tra_adv_qck_lf ! routine called by step.F90 - REAL(dp) :: r1_6 = 1./ 6. ! 1/6 ratio + REAL(wp) :: r1_6 = 1./ 6. ! 1/6 ratio LOGICAL :: l_trd ! flag to compute trends LOGICAL :: l_ptr ! flag to compute poleward transport @@ -93,7 +93,7 @@ CONTAINS REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components - REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation !!---------------------------------------------------------------------- ! IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -131,12 +131,12 @@ CONTAINS REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU ! i-velocity components - REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation !! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars - REAL(dp) :: zzfc, zzfd, zzfu, zzfu_ip1 ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp) :: zzfc, zzfd, zzfu, zzfu_ip1 ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd !---------------------------------------------------------------------- ! ! ! =========== @@ -189,7 +189,7 @@ CONTAINS pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra END_3D ! ! trend diagnostics - IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, CASTDP(pU), pt(:,:,:,jn,Kmm) ) + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, CASTDP(pt(:,:,:,jn,Kmm)) ) ! END DO ! @@ -207,12 +207,12 @@ CONTAINS REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pV ! j-velocity components - REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation !! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars - REAL(dp) :: zzfc, zzfd, zzfu, zzfu_jp1 ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp) :: zzfc, zzfd, zzfu, zzfu_jp1 ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace !---------------------------------------------------------------------- ! ! ! =========== @@ -267,7 +267,7 @@ CONTAINS pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra END_3D ! ! trend diagnostics - IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, CASTDP(pV), pt(:,:,:,jn,Kmm) ) + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, CASTDP(pt(:,:,:,jn,Kmm)) ) ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) ! @@ -286,10 +286,10 @@ CONTAINS INTEGER , INTENT(in ) :: kjpt ! number of tracers ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity - REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwz ! 3D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwz ! 3D workspace !!---------------------------------------------------------------------- ! zwz(:,:, 1 ) = 0._wp ! surface & bottom values set to zero for all tracers @@ -319,7 +319,7 @@ CONTAINS & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) END_3D ! ! Send trends for diagnostic - IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, CASTDP(pW), pt(:,:,:,jn,Kmm) ) + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, CASTDP(pt(:,:,:,jn,Kmm)) ) ! END DO ! @@ -333,14 +333,14 @@ CONTAINS !! !! ** Method : !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point) - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point) + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux !! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zcoef1, zcoef2, zcoef3 ! local scalars - REAL(dp) :: zc, zcurv, zfho ! - - + REAL(wp) :: zcoef1, zcoef2, zcoef3 ! local scalars + REAL(wp) :: zc, zcurv, zfho ! - - !---------------------------------------------------------------------- ! DO_3D( 2, 2, 2, 2, 1, jpkm1 ) diff --git a/src/OCE/TRA/traadv_ubs.F90 b/src/OCE/TRA/traadv_ubs.F90 index 3273bc43dff600bd6d569fd4e7918847b5a82d1a..fbab7c3bf2c8f0d7aad7709ef3d03dcdb71732d0 100644 --- a/src/OCE/TRA/traadv_ubs.F90 +++ b/src/OCE/TRA/traadv_ubs.F90 @@ -93,16 +93,16 @@ CONTAINS CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) INTEGER , INTENT(in ) :: kjpt ! number of tracers INTEGER , INTENT(in ) :: kn_ubs_v ! number of tracers - REAL(dp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct - REAL(dp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: ztra, zbtr, zcoef ! local scalars - REAL(dp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - - REAL(dp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace + REAL(wp) :: ztra, zbtr, zcoef ! local scalars + REAL(wp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - + REAL(wp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace !!---------------------------------------------------------------------- ! #if defined key_loop_fusion @@ -145,7 +145,7 @@ CONTAINS END_2D ! END DO - IF (nn_hls==1) CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_dp, zltv, 'T', 1.0_dp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) + IF (nn_hls==1) CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp, zltv, 'T', 1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) ! DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== Horizontal advective fluxes ==! (UBS) zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2) @@ -283,18 +283,18 @@ CONTAINS !! in-space based differencing for fluid !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(dp), INTENT(in ) :: p2dt ! tracer time-step + REAL(wp), INTENT(in ) :: p2dt ! tracer time-step REAL(dp), DIMENSION(jpi,jpj,jpk) :: pbef ! before field - REAL(dp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: paft ! after field - REAL(dp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction + REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: paft ! after field + REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ikm1 ! local integer - REAL(dp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace + REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace !!---------------------------------------------------------------------- ! - zbig = 1.e+38_wp + zbig = 1.e+20_wp zrtrn = 1.e-15_wp zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp ! diff --git a/src/OCE/TRA/traadv_ubs_lf.F90 b/src/OCE/TRA/traadv_ubs_lf.F90 index ef684a643ffe683c5560fd8db0f502da9b3f1928..9bc7700fe5855a2b6215b472732f908c58db8b06 100644 --- a/src/OCE/TRA/traadv_ubs_lf.F90 +++ b/src/OCE/TRA/traadv_ubs_lf.F90 @@ -94,17 +94,17 @@ CONTAINS REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components - REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: ztra, zbtr, zcoef, zcoef_ip1, zcoef_jp1 ! local scalars - REAL(dp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - - REAL(dp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - - REAL(dp) :: zeeu_im1, zeeu_ip1, zeev_jm1, zeev_jp1 - REAL(dp) :: zztu, zztu_im1, zztu_ip1 - REAL(dp) :: zztv, zztv_jm1, zztv_jp1 - REAL(dp) :: zzltu, zzltu_ip1, zzltv, zzltv_jp1 - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace + REAL(wp) :: ztra, zbtr, zcoef, zcoef_ip1, zcoef_jp1 ! local scalars + REAL(wp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - + REAL(wp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - + REAL(wp) :: zeeu_im1, zeeu_ip1, zeev_jm1, zeev_jp1 + REAL(wp) :: zztu, zztu_im1, zztu_ip1 + REAL(wp) :: zztv, zztv_jm1, zztv_jp1 + REAL(wp) :: zzltu, zzltu_ip1, zzltv, zzltv_jp1 + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace !!---------------------------------------------------------------------- ! IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -186,8 +186,8 @@ CONTAINS END_3D ! and/or in trend diagnostic (l_trd=T) ! IF( l_trd ) THEN ! trend diagnostics - CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, CASTDP(pU), pt(:,:,:,jn,Kmm) ) - CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztv, CASTDP(pV), pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, CASTDP(pt(:,:,:,jn,Kmm)) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztv, pV, CASTDP(pt(:,:,:,jn,Kmm)) ) END IF ! ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) @@ -244,7 +244,7 @@ CONTAINS CALL nonosc_z( Kmm, pt(:,:,:,jn,Kbb), ztw, zti, p2dt ) ! monotonicity algorithm ! CASE( 4 ) ! 4th order COMPACT - CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! 4th order compact interpolation of T at w-point + CALL interp_4th_cpt( CASTDP(pt(:,:,:,jn,Kmm)) , ztw ) ! 4th order compact interpolation of T at w-point DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) END_3D @@ -290,17 +290,17 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: Kmm ! time level index REAL(wp), INTENT(in ) :: p2dt ! tracer time-step - REAL(dp), DIMENSION(jpi,jpj,jpk) :: pbef ! before field - REAL(dp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: paft ! after field - REAL(dp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction + REAL(wp), DIMENSION(jpi,jpj,jpk) :: pbef ! before field + REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: paft ! after field + REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ikm1 ! local integer - REAL(dp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace + REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace !!---------------------------------------------------------------------- ! - zbig = 1.e+38_wp + zbig = 1.e+20_wp zrtrn = 1.e-15_wp zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp ! @@ -364,4 +364,4 @@ CONTAINS END SUBROUTINE nonosc_z !!====================================================================== -END MODULE traadv_ubs_lf \ No newline at end of file +END MODULE traadv_ubs_lf diff --git a/src/OCE/TRA/traatf.F90 b/src/OCE/TRA/traatf.F90 index d81740d85ba747a420a775d75695014abf4e9129..8f417dc8f6a6f6d740c58c0adc3020422a8f65a0 100644 --- a/src/OCE/TRA/traatf.F90 +++ b/src/OCE/TRA/traatf.F90 @@ -91,8 +91,8 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers !! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: zfact ! local scalars - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + REAL(wp) :: zfact ! local scalars + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start( 'tra_atf') @@ -170,7 +170,7 @@ CONTAINS IF( l_trdtra ) DEALLOCATE( ztrdt , ztrds ) ! ! ! control print - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kmm), clinfo1=' nxt - Tn: ', mask1=tmask, & + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kmm), clinfo1=' nxt - Tn: ', mask1=tmask, & ! & tab3d_2=pts(:,:,:,jp_sal,Kmm), clinfo2= ' Sn: ', mask2=tmask ) ! IF( ln_timing ) CALL timing_stop('tra_atf') @@ -196,7 +196,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields ! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: ztn, ztd ! local scalars + REAL(wp) :: ztn, ztd ! local scalars !!---------------------------------------------------------------------- ! IF( kt == kit000 ) THEN @@ -234,18 +234,18 @@ CONTAINS INTEGER , INTENT(in ) :: kt ! ocean time-step index INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices INTEGER , INTENT(in ) :: kit000 ! first time step index - REAL(dp) , INTENT(in ) :: p2dt ! time-step + REAL(wp) , INTENT(in ) :: p2dt ! time-step CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) INTEGER , INTENT(in ) :: kjpt ! number of tracers REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields - REAL(dp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content - REAL(dp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content ! LOGICAL :: ll_traqsr, ll_rnf, ll_isf ! local logical INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: zfact, zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar - REAL(dp) :: zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d, zscale ! - - - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf + REAL(wp) :: zfact, zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar + REAL(wp) :: zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d, zscale ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf !!---------------------------------------------------------------------- ! IF( kt == kit000 ) THEN diff --git a/src/OCE/TRA/traatf_qco.F90 b/src/OCE/TRA/traatf_qco.F90 index 4d2f42f5c67060625514204734f86b53b97f9fa9..5ea6994ad90effbe74285f2ca821b3cc89219c42 100644 --- a/src/OCE/TRA/traatf_qco.F90 +++ b/src/OCE/TRA/traatf_qco.F90 @@ -89,7 +89,7 @@ CONTAINS !! INTEGER :: ji, jj, jk, jn ! dummy loop indices REAL(dp) :: zfact ! local scalars - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start( 'tra_atf_qco') @@ -160,7 +160,7 @@ CONTAINS IF( l_trdtra ) DEALLOCATE( ztrdt , ztrds ) ! ! ! control print - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kmm), clinfo1=' nxt - Tn: ', mask1=tmask, & + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kmm), clinfo1=' nxt - Tn: ', mask1=tmask, & ! & tab3d_2=pts(:,:,:,jp_sal,Kmm), clinfo2= ' Sn: ', mask2=tmask ) ! IF( ln_timing ) CALL timing_stop('tra_atf_qco') @@ -186,7 +186,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields ! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: ztn, ztd ! local scalars + REAL(wp) :: ztn, ztd ! local scalars !!---------------------------------------------------------------------- ! IF( kt == kit000 ) THEN @@ -224,18 +224,18 @@ CONTAINS INTEGER , INTENT(in ) :: kt ! ocean time-step index INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices INTEGER , INTENT(in ) :: kit000 ! first time step index - REAL(dp) , INTENT(in ) :: p2dt ! time-step + REAL(wp) , INTENT(in ) :: p2dt ! time-step CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) INTEGER , INTENT(in ) :: kjpt ! number of tracers REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields - REAL(dp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content - REAL(dp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content ! LOGICAL :: ll_traqsr, ll_rnf, ll_isf ! local logical INTEGER :: ji, jj, jk, jn ! dummy loop indices REAL(dp) :: zfact, zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar REAL(dp) :: zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f ! - - - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf !!---------------------------------------------------------------------- ! IF( kt == kit000 ) THEN diff --git a/src/OCE/TRA/trabbc.F90 b/src/OCE/TRA/trabbc.F90 index 2af7a0b92c62ebf6892050118a7b5bb046a93134..b3e841ba89ed655dde66a86fa964e199818a038b 100644 --- a/src/OCE/TRA/trabbc.F90 +++ b/src/OCE/TRA/trabbc.F90 @@ -37,9 +37,9 @@ MODULE trabbc ! !!* Namelist nambbc: bottom boundary condition * LOGICAL, PUBLIC :: ln_trabbc !: Geothermal heat flux flag INTEGER :: nn_geoflx ! Geothermal flux (=1:constant flux, =2:read in file ) - REAL(dp) :: rn_geoflx_cst ! Constant value of geothermal heat flux + REAL(wp) :: rn_geoflx_cst ! Constant value of geothermal heat flux - REAL(dp), PUBLIC , ALLOCATABLE, DIMENSION(:,:) :: qgh_trd0 ! geothermal heating trend + REAL(wp), PUBLIC , ALLOCATABLE, DIMENSION(:,:) :: qgh_trd0 ! geothermal heating trend TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_qgh ! structure of input qgh (file informations, fields read) @@ -80,7 +80,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt ! 3D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt ! 3D workspace !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('tra_bbc') @@ -103,7 +103,7 @@ CONTAINS ! CALL iom_put ( "hfgeou" , rho0_rcp * qgh_trd0(:,:) ) - !IF(sn_cfctl%l_prtctl) !CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbc - Ta: ', mask1=tmask, clinfo3='tra-ta' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbc - Ta: ', mask1=tmask, clinfo3='tra-ta' ) ! IF( ln_timing ) CALL timing_stop('tra_bbc') ! @@ -193,4 +193,4 @@ CONTAINS END SUBROUTINE tra_bbc_init !!====================================================================== -END MODULE trabbc +END MODULE trabbc \ No newline at end of file diff --git a/src/OCE/TRA/trabbl.F90 b/src/OCE/TRA/trabbl.F90 index c0cd9b3f39df0e7285d0d93c99baea9a214acd3a..62f185e19a8834d024b277ee06da7214cd6e7ab0 100644 --- a/src/OCE/TRA/trabbl.F90 +++ b/src/OCE/TRA/trabbl.F90 @@ -52,18 +52,18 @@ MODULE trabbl INTEGER , PUBLIC :: nn_bbl_adv !: =1/2 : advective bbl or not (=0) ! ! =1 : advective bbl using the bottom ocean velocity ! ! =2 : - - using utr_bbl proportional to grad(rho) - REAL(dp), PUBLIC :: rn_ahtbbl !: along slope bbl diffusive coefficient [m2/s] - REAL(dp), PUBLIC :: rn_gambbl !: lateral coeff. for bottom boundary layer scheme [s] + REAL(wp), PUBLIC :: rn_ahtbbl !: along slope bbl diffusive coefficient [m2/s] + REAL(wp), PUBLIC :: rn_gambbl !: lateral coeff. for bottom boundary layer scheme [s] LOGICAL , PUBLIC :: l_bbl !: flag to compute bbl diffu. flux coef and transport - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: utr_bbl , vtr_bbl ! u- (v-) transport in the bottom boundary layer - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: ahu_bbl , ahv_bbl ! masked diffusive bbl coeff. at u & v-pts + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: utr_bbl , vtr_bbl ! u- (v-) transport in the bottom boundary layer + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: ahu_bbl , ahv_bbl ! masked diffusive bbl coeff. at u & v-pts INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: mbku_d , mbkv_d ! vertical index of the "lower" bottom ocean U/V-level (PUBLIC for TAM) INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: mgrhu , mgrhv ! = +/-1, sign of grad(H) in u-(v-)direction (PUBLIC for TAM) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahu_bbl_0, ahv_bbl_0 ! diffusive bbl flux coefficients at u and v-points - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: e3u_bbl_0, e3v_bbl_0 ! thichness of the bbl (e3) at u and v-points (PUBLIC for TAM) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahu_bbl_0, ahv_bbl_0 ! diffusive bbl flux coefficients at u and v-points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: e3u_bbl_0, e3v_bbl_0 ! thichness of the bbl (e3) at u and v-points (PUBLIC for TAM) !! * Substitutions # include "do_loop_substitute.h90" @@ -106,7 +106,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk ! Dummy loop indices - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start( 'tra_bbl') @@ -122,9 +122,9 @@ CONTAINS IF( nn_bbl_ldf == 1 ) THEN !* Diffusive bbl ! CALL tra_bbl_dif( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) - IF( sn_cfctl%l_prtctl ) & + !IF( sn_cfctl%l_prtctl ) & !CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_ldf - Ta: ', mask1=tmask, & - ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef ! @@ -133,7 +133,7 @@ CONTAINS IF( nn_bbl_adv /= 0 ) THEN !* Advective bbl ! CALL tra_bbl_adv( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) - IF(sn_cfctl%l_prtctl) & + ! IF(sn_cfctl%l_prtctl) & !CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv - Ta: ', mask1=tmask, & ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport @@ -182,8 +182,8 @@ CONTAINS ! INTEGER :: ji, jj, jn ! dummy loop indices INTEGER :: ik ! local integers - REAL(dp) :: zbtr ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls)) :: zptb ! workspace + REAL(wp) :: zbtr ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zptb ! workspace !!---------------------------------------------------------------------- ! DO jn = 1, kjpt ! tracer loop @@ -232,8 +232,8 @@ CONTAINS INTEGER :: ji, jj, jk, jn ! dummy loop indices INTEGER :: iis , iid , ijs , ijd ! local integers INTEGER :: ikus, ikud, ikvs, ikvd ! - - - REAL(dp) :: zbtr, ztra ! local scalars - REAL(dp) :: zu_bbl, zv_bbl ! - - + REAL(wp) :: zbtr, ztra ! local scalars + REAL(wp) :: zu_bbl, zv_bbl ! - - !!---------------------------------------------------------------------- ! ! =========== DO jn = 1, kjpt ! tracer loop @@ -324,10 +324,10 @@ CONTAINS INTEGER :: ik ! local integers INTEGER :: iis, iid, ikus, ikud ! - - INTEGER :: ijs, ijd, ikvs, ikvd ! - - - REAL(dp) :: za, zb, zgdrho ! local scalars - REAL(dp) :: zsign, zsigna, zgbbl ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpts) :: zts, zab ! 3D workspace - REAL(dp), DIMENSION(A2D(nn_hls)) :: zub, zvb, zdep ! 2D workspace + REAL(wp) :: za, zb, zgdrho ! local scalars + REAL(wp) :: zsign, zsigna, zgbbl ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zts, zab ! 3D workspace + REAL(wp), DIMENSION(A2D(nn_hls)) :: zub, zvb, zdep ! 2D workspace !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -467,7 +467,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: ji, jj ! dummy loop indices INTEGER :: ii0, ii1, ij0, ij1, ios ! local integer - REAL(dp), DIMENSION(jpi,jpj) :: zmbku, zmbkv ! workspace + REAL(wp), DIMENSION(jpi,jpj) :: zmbku, zmbkv ! workspace !! NAMELIST/nambbl/ ln_trabbl, nn_bbl_ldf, nn_bbl_adv, rn_ahtbbl, rn_gambbl !!---------------------------------------------------------------------- @@ -511,8 +511,8 @@ CONTAINS mbkv_d(ji,jj) = MAX( mbkt(ji ,jj+1) , mbkt(ji,jj) ) END_2D ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk - zmbku(:,:) = REAL( mbku_d(:,:),dp ) ; zmbkv(:,:) = REAL( mbkv_d(:,:),dp ) - CALL lbc_lnk( 'trabbl', zmbku,'U',1.0_dp, zmbkv,'V',1.0_dp) + zmbku(:,:) = REAL( mbku_d(:,:), wp ) ; zmbkv(:,:) = REAL( mbkv_d(:,:), wp ) + CALL lbc_lnk( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp) mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ; mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 ) ! ! !* sign of grad(H) at u- and v-points; zero if grad(H) = 0 @@ -531,7 +531,7 @@ CONTAINS e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj )), e3u_0(ji,jj,mbkt(ji,jj)) ) e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) END_2D - CALL lbc_lnk( 'trabbl', e3u_bbl_0, 'U', 1.0_dp , e3v_bbl_0, 'V', 1.0_dp ) ! lateral boundary conditions + CALL lbc_lnk( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp ) ! lateral boundary conditions ! ! !* masked diffusive flux coefficients ahu_bbl_0(:,:) = rn_ahtbbl * e2_e1u(:,:) * e3u_bbl_0(:,:) * umask(:,:,1) @@ -540,4 +540,4 @@ CONTAINS END SUBROUTINE tra_bbl_init !!====================================================================== -END MODULE trabbl +END MODULE trabbl \ No newline at end of file diff --git a/src/OCE/TRA/tradmp.F90 b/src/OCE/TRA/tradmp.F90 index 934794752c6347a2de48ced492efad1a2bb2ae72..cc18261de0d9f7cb8af178202f0b3c03d36a9bf4 100644 --- a/src/OCE/TRA/tradmp.F90 +++ b/src/OCE/TRA/tradmp.F90 @@ -47,7 +47,7 @@ MODULE tradmp INTEGER , PUBLIC :: nn_zdmp !: = 0/1/2 flag for damping in the mixed layer CHARACTER(LEN=200) , PUBLIC :: cn_resto !: name of netcdf file containing restoration coefficient field ! - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto !: restoring coeff. on T and S (s-1) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto !: restoring coeff. on T and S (s-1) !! * Substitutions # include "do_loop_substitute.h90" @@ -95,8 +95,8 @@ CONTAINS ! INTEGER :: ji, jj, jk, jn ! dummy loop indices REAL(dp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zts_dta - REAL(dp), DIMENSION(:,:,:) , ALLOCATABLE :: zwrk - REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: zwrk + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('tra_dmp') @@ -172,7 +172,7 @@ CONTAINS DEALLOCATE( ztrdts ) ENDIF ! ! Control print - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' dmp - Ta: ', mask1=tmask, & + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' dmp - Ta: ', mask1=tmask, & ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) ! IF( ln_timing ) CALL timing_stop('tra_dmp') @@ -240,4 +240,4 @@ CONTAINS END SUBROUTINE tra_dmp_init !!====================================================================== -END MODULE tradmp +END MODULE tradmp \ No newline at end of file diff --git a/src/OCE/TRA/traisf.F90 b/src/OCE/TRA/traisf.F90 index fd70e1d167ff10b8cb06f387415905899b1c1db9..03e504e085604c832a5375cd30583bbd39744109 100644 --- a/src/OCE/TRA/traisf.F90 +++ b/src/OCE/TRA/traisf.F90 @@ -100,12 +100,12 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: pts !!---------------------------------------------------------------------- INTEGER , DIMENSION(jpi,jpj) , INTENT(in ) :: ktop , kbot - REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl, pfrac - REAL(dp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc , ptsc_b + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl, pfrac + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc , ptsc_b !!---------------------------------------------------------------------- INTEGER :: ji,jj,jk ! loop index INTEGER :: ikt, ikb ! top and bottom level of the tbl - REAL(dp), DIMENSION(A2D(nn_hls)) :: ztc ! total ice shelf tracer trend + REAL(wp), DIMENSION(A2D(nn_hls)) :: ztc ! total ice shelf tracer trend !!---------------------------------------------------------------------- ! ! compute 2d total trend due to isf @@ -141,7 +141,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: ptsa !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: Kmm ! ocean time level index - REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: ptsc + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: ptsc !!---------------------------------------------------------------------- INTEGER :: ji, jj, jk !!---------------------------------------------------------------------- diff --git a/src/OCE/TRA/traldf.F90 b/src/OCE/TRA/traldf.F90 index ea61a5ba4c51765213ecfeeab54a55f824195b2b..0c3e96737454e44129a013cfb3448b0642898c0d 100644 --- a/src/OCE/TRA/traldf.F90 +++ b/src/OCE/TRA/traldf.F90 @@ -54,7 +54,7 @@ CONTAINS INTEGER, INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation !! - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('tra_ldf') @@ -84,8 +84,8 @@ CONTAINS DEALLOCATE( ztrdt, ztrds ) ENDIF ! !* print mean trends (used for debugging) - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf - Ta: ', mask1=tmask, & - ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) ! IF( ln_timing ) CALL timing_stop('tra_ldf') ! @@ -125,4 +125,4 @@ CONTAINS END SUBROUTINE tra_ldf_init !!====================================================================== -END MODULE traldf +END MODULE traldf \ No newline at end of file diff --git a/src/OCE/TRA/traldf_iso.F90 b/src/OCE/TRA/traldf_iso.F90 index efe927a3262976508002d2f59f20e9ae30251656..cd2d3e561227e666848ce8fdbe998355522bccfd 100644 --- a/src/OCE/TRA/traldf_iso.F90 +++ b/src/OCE/TRA/traldf_iso.F90 @@ -59,9 +59,9 @@ CONTAINS INTEGER , INTENT(in ) :: kjpt ! number of tracers INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage INTEGER , INTENT(in ) :: Kmm ! ocean time level index - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend @@ -122,9 +122,9 @@ CONTAINS INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage INTEGER , INTENT(in ) :: Kmm ! ocean time level index INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs - REAL(dp), DIMENSION(A2D_T(ktah) ,JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] - REAL(dp), DIMENSION(A2D_T(ktg) ,KJPT), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels - REAL(dp), DIMENSION(A2D_T(ktgi) ,KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(wp), DIMENSION(A2D_T(ktah) ,JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(A2D_T(ktg) ,KJPT), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(A2D_T(ktgi) ,KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels REAL(dp), DIMENSION(A2D_T(ktt) ,JPK,KJPT), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) REAL(dp), DIMENSION(A2D_T(ktt2) ,JPK,KJPT), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) REAL(dp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend @@ -132,11 +132,11 @@ CONTAINS INTEGER :: ji, jj, jk, jn ! dummy loop indices INTEGER :: ikt INTEGER :: ierr, iij ! local integer - REAL(dp) :: zmsku, zahu_w, zabe1, zcof1, zcoef3 ! local scalars - REAL(dp) :: zmskv, zahv_w, zabe2, zcof2, zcoef4 ! - - - REAL(dp) :: zcoef0, ze3w_2, zsign ! - - - REAL(dp), DIMENSION(A2D(nn_hls)) :: zdkt, zdk1t, z2d - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw + REAL(wp) :: zmsku, zahu_w, zabe1, zcof1, zcoef3 ! local scalars + REAL(wp) :: zmskv, zahv_w, zabe2, zcof2, zcoef4 ! - - + REAL(wp) :: zcoef0, ze3w_2, zsign ! - - + REAL(wp), DIMENSION(A2D(nn_hls)) :: zdkt, zdk1t, z2d + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw !!---------------------------------------------------------------------- ! IF( kpass == 1 .AND. kt == kit000 ) THEN diff --git a/src/OCE/TRA/traldf_lap_blp.F90 b/src/OCE/TRA/traldf_lap_blp.F90 index 3f01d72f2e2eea9193ad19f9a97220d762ff25ae..3e11190292dfc79245fccd30bc498843cf378651 100644 --- a/src/OCE/TRA/traldf_lap_blp.F90 +++ b/src/OCE/TRA/traldf_lap_blp.F90 @@ -56,9 +56,9 @@ CONTAINS INTEGER , INTENT(in ) :: kjpt ! number of tracers INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage INTEGER , INTENT(in ) :: Kmm ! ocean time level index - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! before tracer fields REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend !! @@ -95,16 +95,16 @@ CONTAINS INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage INTEGER , INTENT(in ) :: Kmm ! ocean time level index INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt_rhs - REAL(dp), DIMENSION(A2D_T(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] - REAL(dp), DIMENSION(A2D_T(ktg), KJPT), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels - REAL(dp), DIMENSION(A2D_T(ktgi), KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(wp), DIMENSION(A2D_T(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(A2D_T(ktg), KJPT), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(A2D_T(ktgi), KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels REAL(dp), DIMENSION(A2D_T(ktt), JPK,KJPT), INTENT(in ) :: pt ! before tracer fields REAL(dp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend ! INTEGER :: ji, jj, jk, jn ! dummy loop indices INTEGER :: iij - REAL(dp) :: zsign ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zaheeu, zaheev + REAL(wp) :: zsign ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zaheeu, zaheev !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -202,16 +202,16 @@ CONTAINS INTEGER , INTENT(in ) :: kjpt ! number of tracers INTEGER , INTENT(in ) :: kldf ! type of operator used INTEGER , INTENT(in ) :: Kmm ! ocean time level indices - REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] - REAL(dp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels - REAL(dp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before and now tracer fields REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend ! INTEGER :: ji, jj, jk, jn ! dummy loop indices REAL(dp), DIMENSION(A2D(nn_hls),jpk,kjpt) :: zlap ! laplacian at t-point - REAL(dp), DIMENSION(A2D(nn_hls), kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points) - REAL(dp), DIMENSION(A2D(nn_hls), kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points) + REAL(wp), DIMENSION(A2D(nn_hls), kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points) + REAL(wp), DIMENSION(A2D(nn_hls), kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points) !!--------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile diff --git a/src/OCE/TRA/traldf_triad.F90 b/src/OCE/TRA/traldf_triad.F90 index 43e6e9ff53e25757479a3a2c5db427c417486713..667ab49dd7be44a9d7934617494c26cacdce13f6 100644 --- a/src/OCE/TRA/traldf_triad.F90 +++ b/src/OCE/TRA/traldf_triad.F90 @@ -57,9 +57,9 @@ CONTAINS INTEGER , INTENT(in ) :: kjpt ! number of tracers INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage INTEGER , INTENT(in ) :: Kmm ! ocean time level indices - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend @@ -99,22 +99,22 @@ CONTAINS INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage INTEGER , INTENT(in) :: Kmm ! ocean time level indices INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs - REAL(dp), DIMENSION(A2D_T(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] - REAL(dp), DIMENSION(A2D_T(ktg), KJPT), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels - REAL(dp), DIMENSION(A2D_T(ktgi), KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(wp), DIMENSION(A2D_T(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(A2D_T(ktg), KJPT), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(A2D_T(ktgi), KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels REAL(dp), DIMENSION(A2D_T(ktt), JPK,KJPT), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) REAL(dp), DIMENSION(A2D_T(ktt2), JPK,KJPT), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) REAL(dp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend ! INTEGER :: ji, jj, jk, jn, kp, iij ! dummy loop indices - REAL(dp) :: zcoef0, ze3w_2, zsign ! - - + REAL(wp) :: zcoef0, ze3w_2, zsign ! - - ! - REAL(dp) :: zslope2, zbu, zbv, zbu1, zbv1, zslope21, zah, zah1, zah_ip1, zah_jp1, zbu_ip1, zbv_jp1 - REAL(dp) :: ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt, zdyt_jp1, ze3wr_jp1, zdzt_jp1, zah_slp1, zah_slp_jp1, zaei_slp_jp1 - REAL(dp) :: zah_slp, zaei_slp, zdxt_ip1, ze3wr_ip1, zdzt_ip1, zah_slp_ip1, zaei_slp_ip1, zaei_slp1 - REAL(dp), DIMENSION(A2D(nn_hls),0:1) :: zdkt3d ! vertical tracer gradient at 2 levels - REAL(dp), DIMENSION(A2D(nn_hls) ) :: z2d ! 2D workspace - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D - + REAL(wp) :: zslope2, zbu, zbv, zbu1, zbv1, zslope21, zah, zah1, zah_ip1, zah_jp1, zbu_ip1, zbv_jp1 + REAL(wp) :: ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt, zdyt_jp1, ze3wr_jp1, zdzt_jp1, zah_slp1, zah_slp_jp1, zaei_slp_jp1 + REAL(wp) :: zah_slp, zaei_slp, zdxt_ip1, ze3wr_ip1, zdzt_ip1, zah_slp_ip1, zaei_slp_ip1, zaei_slp1 + REAL(wp), DIMENSION(A2D(nn_hls),0:1) :: zdkt3d ! vertical tracer gradient at 2 levels + REAL(wp), DIMENSION(A2D(nn_hls) ) :: z2d ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D - !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile diff --git a/src/OCE/TRA/tramle.F90 b/src/OCE/TRA/tramle.F90 index 5fe990adfa2dde1a3eff0d911cfb04643290392f..318dc0ff2d8dc2a009984a20eca6be5774695fc2 100644 --- a/src/OCE/TRA/tramle.F90 +++ b/src/OCE/TRA/tramle.F90 @@ -35,20 +35,20 @@ MODULE tramle INTEGER :: nn_mle ! MLE type: =0 standard Fox-Kemper ; =1 new formulation INTEGER :: nn_mld_uv ! space interpolation of MLD at u- & v-pts (0=min,1=averaged,2=max) INTEGER :: nn_conv ! =1 no MLE in case of convection ; =0 always MLE - REAL(dp) :: rn_ce ! MLE coefficient + REAL(wp) :: rn_ce ! MLE coefficient ! ! parameters used in nn_mle = 0 case - REAL(dp) :: rn_lf ! typical scale of mixed layer front - REAL(dp) :: rn_time ! time scale for mixing momentum across the mixed layer + REAL(wp) :: rn_lf ! typical scale of mixed layer front + REAL(wp) :: rn_time ! time scale for mixing momentum across the mixed layer ! ! parameters used in nn_mle = 1 case - REAL(dp) :: rn_lat ! reference latitude for a 5 km scale of ML front - REAL(dp) :: rn_rho_c_mle ! Density criterion for definition of MLD used by FK + REAL(wp) :: rn_lat ! reference latitude for a 5 km scale of ML front + REAL(wp) :: rn_rho_c_mle ! Density criterion for definition of MLD used by FK - REAL(dp) :: r5_21 = 5.e0 / 21.e0 ! factor used in mle streamfunction computation - REAL(dp) :: rb_c ! ML buoyancy criteria = g rho_c /rho0 where rho_c is defined in zdfmld - REAL(dp) :: rc_f ! MLE coefficient (= rn_ce / (5 km * fo) ) in nn_mle=1 case + REAL(wp) :: r5_21 = 5.e0 / 21.e0 ! factor used in mle streamfunction computation + REAL(wp) :: rb_c ! ML buoyancy criteria = g rho_c /rho0 where rho_c is defined in zdfmld + REAL(wp) :: rc_f ! MLE coefficient (= rn_ce / (5 km * fo) ) in nn_mle=1 case - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: rfu, rfv ! modified Coriolis parameter (f+tau) at u- & v-pts - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_ft ! inverse of the modified Coriolis parameter at t-pts + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: rfu, rfv ! modified Coriolis parameter (f+tau) at u- & v-pts + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_ft ! inverse of the modified Coriolis parameter at t-pts !! * Substitutions # include "do_loop_substitute.h90" @@ -87,17 +87,17 @@ CONTAINS INTEGER , INTENT(in ) :: Kmm ! ocean time level index 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(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: same 3 transport components - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the MLE induced transport + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: same 3 transport components + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the MLE induced transport ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ii, ij, ik, ikmax ! local integers - REAL(dp) :: zcuw, zmuw, zc ! local scalar - REAL(dp) :: zcvw, zmvw ! - - + REAL(wp) :: zcuw, zmuw, zc ! local scalar + REAL(wp) :: zcvw, zmvw ! - - INTEGER , DIMENSION(A2D(nn_hls)) :: inml_mle - REAL(dp), DIMENSION(A2D(nn_hls)) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw + REAL(wp), DIMENSION(A2D(nn_hls)) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw !!---------------------------------------------------------------------- ! ! @@ -295,7 +295,7 @@ CONTAINS INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ierr INTEGER :: ios ! Local integer output status for namelist read - REAL(dp) :: z1_t2, zfu, zfv ! - - + REAL(wp) :: z1_t2, zfu, zfv ! - - ! NAMELIST/namtra_mle/ ln_mle , nn_mle, rn_ce, rn_lf, rn_time, rn_lat, nn_mld_uv, nn_conv, rn_rho_c_mle !!---------------------------------------------------------------------- @@ -351,7 +351,7 @@ CONTAINS rfu(ji,jj) = SQRT( zfu * zfu + z1_t2 ) rfv(ji,jj) = SQRT( zfv * zfv + z1_t2 ) END_2D - CALL lbc_lnk( 'tramle', rfu, 'U', 1.0_dp , rfv, 'V', 1.0_dp ) + CALL lbc_lnk( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) ! ELSEIF( nn_mle == 1 ) THEN ! MLE array allocation & initialisation rc_f = rn_ce / ( 5.e3_wp * 2._wp * omega * SIN( rad * rn_lat ) ) @@ -370,4 +370,4 @@ CONTAINS END SUBROUTINE tra_mle_init !!============================================================================== -END MODULE tramle +END MODULE tramle \ No newline at end of file diff --git a/src/OCE/TRA/tranpc.F90 b/src/OCE/TRA/tranpc.F90 index debb7372733da76d1f4a6992d63ef4ed50e27138..b2708fc257109c90cf984d46130035982a056f2b 100644 --- a/src/OCE/TRA/tranpc.F90 +++ b/src/OCE/TRA/tranpc.F90 @@ -67,14 +67,14 @@ CONTAINS INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low ! local integers LOGICAL :: l_bottom_reached, l_column_treated - REAL(dp) :: zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z - REAL(dp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_rDt + REAL(wp) :: zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z + REAL(wp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_rDt REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp ! acceptance criteria for neutrality (N2==0) - REAL(dp), DIMENSION( jpk ) :: zvn2 ! vertical profile of N2 at 1 given point... - REAL(dp), DIMENSION( jpk,jpts) :: zvts, zvab ! vertical profile of T & S , and alpha & betaat 1 given point - REAL(dp), DIMENSION(A2D(nn_hls),jpk ) :: zn2 ! N^2 - REAL(dp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zab ! alpha and beta - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace + REAL(wp), DIMENSION( jpk ) :: zvn2 ! vertical profile of N2 at 1 given point... + REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab ! vertical profile of T & S , and alpha & betaat 1 given point + REAL(wp), DIMENSION(A2D(nn_hls),jpk ) :: zn2 ! N^2 + REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zab ! alpha and beta + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace ! LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is INTEGER :: ilc1, jlc1, klc1, nncpu ! actually happening in a water column at point "ilc1, jlc1" diff --git a/src/OCE/TRA/traqsr.F90 b/src/OCE/TRA/traqsr.F90 index b722786ce39bc28e1d12cc22e3f4da76279979da..7447b530e9791b6831b4e86576112a0817453450 100644 --- a/src/OCE/TRA/traqsr.F90 +++ b/src/OCE/TRA/traqsr.F90 @@ -48,9 +48,9 @@ MODULE traqsr LOGICAL , PUBLIC :: ln_qsr_2bd !: 2 band light absorption flag LOGICAL , PUBLIC :: ln_qsr_bio !: bio-model light absorption flag INTEGER , PUBLIC :: nn_chldta !: use Chlorophyll data (=1) or not (=0) - REAL(dp), PUBLIC :: rn_abs !: fraction absorbed in the very near surface (RGB & 2 bands) - REAL(dp), PUBLIC :: rn_si0 !: very near surface depth of extinction (RGB & 2 bands) - REAL(dp), PUBLIC :: rn_si1 !: deepest depth of extinction (water type I) (2 bands) + REAL(wp), PUBLIC :: rn_abs !: fraction absorbed in the very near surface (RGB & 2 bands) + REAL(wp), PUBLIC :: rn_si0 !: very near surface depth of extinction (RGB & 2 bands) + REAL(wp), PUBLIC :: rn_si1 !: deepest depth of extinction (water type I) (2 bands) ! INTEGER , PUBLIC :: nksr !: levels below which the light cannot penetrate (depth larger than 391 m) @@ -60,10 +60,10 @@ MODULE traqsr INTEGER, PARAMETER :: np_BIO = 4 ! bio-model light penetration ! INTEGER :: nqsr ! user choice of the type of light penetration - REAL(dp) :: xsi0r ! inverse of rn_si0 - REAL(dp) :: xsi1r ! inverse of rn_si1 + REAL(wp) :: xsi0r ! inverse of rn_si0 + REAL(wp) :: xsi1r ! inverse of rn_si1 ! - REAL(dp) , PUBLIC, DIMENSION(3,61) :: rkrgb ! tabulated attenuation coefficients for RGB absorption + REAL(wp) , PUBLIC, DIMENSION(3,61) :: rkrgb ! tabulated attenuation coefficients for RGB absorption TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_chl ! structure of input Chl (file informations, fields read) !! * Substitutions @@ -108,14 +108,14 @@ CONTAINS ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: irgb ! local integers - REAL(dp) :: zchl, zcoef, z1_2 ! local scalars - REAL(dp) :: zc0 , zc1 , zc2 , zc3 ! - - - REAL(dp) :: zzc0, zzc1, zzc2, zzc3 ! - - - REAL(dp) :: zz0 , zz1 , ze3t, zlui ! - - - REAL(dp) :: zCb, zCmax, zpsi, zpsimax, zrdpsi, zCze - REAL(dp) :: zlogc, zlogze, zlogCtot, zlogCze - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: ze0, ze1, ze2, ze3 - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, zetot, ztmp3d + REAL(wp) :: zchl, zcoef, z1_2 ! local scalars + REAL(wp) :: zc0 , zc1 , zc2 , zc3 ! - - + REAL(wp) :: zzc0, zzc1, zzc2, zzc3 ! - - + REAL(wp) :: zz0 , zz1 , ze3t, zlui ! - - + REAL(wp) :: zCb, zCmax, zpsi, zpsimax, zrdpsi, zCze + REAL(wp) :: zlogc, zlogze, zlogCtot, zlogCze + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ze0, ze1, ze2, ze3 + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, zetot, ztmp3d !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('tra_qsr') @@ -315,7 +315,7 @@ CONTAINS DEALLOCATE( ztrdt ) ENDIF ! ! print mean trends (used for debugging) - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' qsr - Ta: ', mask1=tmask, clinfo3='tra-ta' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' qsr - Ta: ', mask1=tmask, clinfo3='tra-ta' ) ! IF( ln_timing ) CALL timing_stop('tra_qsr') ! @@ -341,8 +341,8 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ios, irgb, ierror, ioptio ! local integer - REAL(dp) :: zz0, zc0 , zc1, zcoef ! local scalars - REAL(dp) :: zz1, zc2 , zc3, zchl ! - - + REAL(wp) :: zz0, zc0 , zc1, zcoef ! local scalars + REAL(wp) :: zz1, zc2 , zc3, zchl ! - - ! CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files TYPE(FLD_N) :: sn_chl ! informations about the chlorofyl field to be read @@ -450,4 +450,4 @@ CONTAINS END SUBROUTINE tra_qsr_init !!====================================================================== -END MODULE traqsr +END MODULE traqsr \ No newline at end of file diff --git a/src/OCE/TRA/trasbc.F90 b/src/OCE/TRA/trasbc.F90 index a544406a75617b2ddd0b06f8c9e2daae6cef7045..a828ba8f3d2c822facb74c024407a422d570269f 100644 --- a/src/OCE/TRA/trasbc.F90 +++ b/src/OCE/TRA/trasbc.F90 @@ -77,8 +77,8 @@ CONTAINS ! INTEGER :: ji, jj, jk, jn ! dummy loop indices INTEGER :: ikt, ikb ! local integers - REAL(dp) :: zfact, z1_e3t, zdep, ztim ! local scalar - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + REAL(wp) :: zfact, z1_e3t, zdep, ztim ! local scalar + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('tra_sbc') @@ -215,12 +215,12 @@ CONTAINS DEALLOCATE( ztrdt , ztrds ) ENDIF ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' sbc - Ta: ', mask1=tmask, & - ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' sbc - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) ! IF( ln_timing ) CALL timing_stop('tra_sbc') ! END SUBROUTINE tra_sbc !!====================================================================== -END MODULE trasbc +END MODULE trasbc \ No newline at end of file diff --git a/src/OCE/TRA/trazdf.F90 b/src/OCE/TRA/trazdf.F90 index 30abfe17983fd7442c381292498d389b930a955c..2e45a35482629c5f21db1d9a8c1bd3e8e41c1928 100644 --- a/src/OCE/TRA/trazdf.F90 +++ b/src/OCE/TRA/trazdf.F90 @@ -57,7 +57,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk ! Dummy loop indices - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace !!--------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('tra_zdf') @@ -101,15 +101,15 @@ CONTAINS & - ztrds(:,:,jk) END DO !!gm this should be moved in trdtra.F90 and done on all trends - CALL lbc_lnk( 'trazdf', ztrdt, 'T', 1.0_dp , ztrds, 'T', 1.0_dp ) + CALL lbc_lnk( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) !!gm CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_zdf, ztrdt ) CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_zdf, ztrds ) DEALLOCATE( ztrdt , ztrds ) ENDIF ! ! print mean trends (used for debugging) - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kaa), clinfo1=' zdf - Ta: ', mask1=tmask, & - ! & tab3d_2=pts(:,:,:,jp_sal,Kaa), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kaa), clinfo1=' zdf - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Kaa), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) ! IF( ln_timing ) CALL timing_stop('tra_zdf') ! @@ -141,12 +141,14 @@ CONTAINS INTEGER , INTENT(in ) :: kit000 ! first time step index CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) INTEGER , INTENT(in ) :: kjpt ! number of tracers - REAL(dp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk, jn ! dummy loop indices - REAL(dp) :: zrhs, zzwi, zzws ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwt, zwd, zws + REAL(wp) :: zzwi, zzws! local scalars + REAL(dp) :: zrhs! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zws + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwt, zwd !!--------------------------------------------------------------------- ! ! ! ============= ! @@ -262,4 +264,4 @@ CONTAINS END SUBROUTINE tra_zdf_imp !!============================================================================== -END MODULE trazdf +END MODULE trazdf \ No newline at end of file diff --git a/src/OCE/TRA/zpshde.F90 b/src/OCE/TRA/zpshde.F90 index 653e215b1daea9ebe7c6ff0196cc8eae725cec5e..1f56bf7437e5b6091d266af11bb5e6ffe1b77e44 100644 --- a/src/OCE/TRA/zpshde.F90 +++ b/src/OCE/TRA/zpshde.F90 @@ -47,9 +47,9 @@ CONTAINS INTEGER , INTENT(in ) :: Kmm ! ocean time level index INTEGER , INTENT(in ) :: kjpt ! number of tracers REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pta ! 4D tracers fields - REAL(dp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts - REAL(dp), DIMENSION(:,:,:) , INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields - REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(:,:,:) , INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) ! INTEGER :: itrd, itgr !! @@ -111,15 +111,15 @@ CONTAINS INTEGER , INTENT(in ) :: kjpt ! number of tracers INTEGER , INTENT(in ) :: ktta, ktgt, ktrd, ktgr REAL(dp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(in ) :: pta ! 4D tracers fields - REAL(dp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts - REAL(dp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields - REAL(dp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + REAL(wp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) ! INTEGER :: ji, jj, jn ! Dummy loop indices INTEGER :: iku, ikv, ikum1, ikvm1 ! partial step level (ocean bottom level) at u- and v-points - REAL(dp) :: ze3wu, ze3wv, zmaxu, zmaxv ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos - REAL(dp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj ! + REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos + REAL(wp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj ! !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start( 'zps_hde') @@ -168,7 +168,7 @@ CONTAINS END_2D END DO ! - IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_dp , pgtv(:,:,:), 'V', -1.0_dp ) ! Lateral boundary cond. + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. ! IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) pgru(:,:) = 0._wp @@ -201,7 +201,7 @@ CONTAINS ELSE ; pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj ) ) ! j: 2 ENDIF END_2D - IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_dp , pgrv , 'V', -1.0_dp ) ! Lateral boundary conditions + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions ! END IF ! @@ -217,11 +217,11 @@ CONTAINS INTEGER , INTENT(in ) :: Kmm ! ocean time level index INTEGER , INTENT(in ) :: kjpt ! number of tracers REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pta ! 4D tracers fields - REAL(dp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts - REAL(dp), DIMENSION(:,:,:) , INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) - REAL(dp), DIMENSION(:,:,:) , INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields - REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) - REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) + REAL(wp), DIMENSION(:,:,:) , INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) ! INTEGER :: itrd, itgr, itgri !! @@ -287,17 +287,17 @@ CONTAINS INTEGER , INTENT(in ) :: kjpt ! number of tracers INTEGER , INTENT(in ) :: ktta, ktgt, ktgti, ktrd, ktgr, ktgri REAL(dp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(in ) :: pta ! 4D tracers fields - REAL(dp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts - REAL(dp), DIMENSION(A2D_T(ktgti) ,KJPT), INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) - REAL(dp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields - REAL(dp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) - REAL(dp), DIMENSION(A2D_T(ktgri) ), INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) + REAL(wp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(A2D_T(ktgti) ,KJPT), INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) + REAL(wp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + REAL(wp), DIMENSION(A2D_T(ktgri) ), INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) ! INTEGER :: ji, jj, jn ! Dummy loop indices INTEGER :: iku, ikv, ikum1, ikvm1,ikup1, ikvp1 ! partial step level (ocean bottom level) at u- and v-points - REAL(dp) :: ze3wu, ze3wv, zmaxu, zmaxv ! temporary scalars - REAL(dp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos - REAL(dp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj ! + REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! temporary scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos + REAL(wp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj ! !!---------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start( 'zps_hde_isf') @@ -349,7 +349,7 @@ CONTAINS END_2D END DO ! - IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_dp , pgtv(:,:,:), 'V', -1.0_dp ) ! Lateral boundary cond. + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. ! horizontal derivative of density anomalies (rd) IF( PRESENT( prd ) ) THEN ! depth of the partial step level @@ -391,7 +391,7 @@ CONTAINS END_2D - IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_dp , pgrv , 'V', -1.0_dp ) ! Lateral boundary conditions + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions ! END IF ! @@ -442,7 +442,7 @@ CONTAINS END_2D ! END DO - IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtui(:,:,:), 'U', -1.0_dp , pgtvi(:,:,:), 'V', -1.0_dp ) ! Lateral boundary cond. + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) ! @@ -481,7 +481,7 @@ CONTAINS ENDIF END_2D - IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgrui, 'U', -1.0_dp , pgrvi, 'V', -1.0_dp ) ! Lateral boundary conditions + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions ! END IF ! @@ -490,4 +490,4 @@ CONTAINS END SUBROUTINE zps_hde_isf_t !!====================================================================== -END MODULE zpshde +END MODULE zpshde \ No newline at end of file diff --git a/src/OCE/TRD/trddyn.F90 b/src/OCE/TRD/trddyn.F90 index 2835c0f522ec7a8ffe5d32304c057f247c574c16..1f4976b1529c2658277136a7b46a49a2cda5fa8c 100644 --- a/src/OCE/TRD/trddyn.F90 +++ b/src/OCE/TRD/trddyn.F90 @@ -105,8 +105,8 @@ CONTAINS ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ikbu, ikbv ! local integers - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: z2dx, z2dy ! 2D workspace - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: z3dx, z3dy ! 3D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2dx, z2dy ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3dx, z3dy ! 3D workspace !!---------------------------------------------------------------------- ! SELECT CASE( ktrd ) @@ -127,7 +127,7 @@ CONTAINS z3dx(ji,jj,jk) = uu(ji,jj,jk,Kmm) * ( uu(ji+1,jj,jk,Kmm) - uu(ji-1,jj,jk,Kmm) ) / ( 2._wp * e1u(ji,jj) ) z3dy(ji,jj,jk) = vv(ji,jj,jk,Kmm) * ( vv(ji,jj+1,jk,Kmm) - vv(ji,jj-1,jk,Kmm) ) / ( 2._wp * e2v(ji,jj) ) END_3D - CALL lbc_lnk( 'trddyn', z3dx, 'U', -1.0_dp, z3dy, 'V', -1.0_dp ) + CALL lbc_lnk( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) CALL iom_put( "utrd_udx", z3dx ) CALL iom_put( "vtrd_vdy", z3dy ) DEALLOCATE( z3dx , z3dy ) @@ -179,4 +179,4 @@ CONTAINS END SUBROUTINE trd_dyn_iom !!====================================================================== -END MODULE trddyn +END MODULE trddyn \ No newline at end of file diff --git a/src/OCE/TRD/trdglo.F90 b/src/OCE/TRD/trdglo.F90 index 5f1c616957a8ddb2a1a4a8c978d0d9f2bfb5a6e1..08116dc587b0761abdd51223334049dd0876e7c8 100644 --- a/src/OCE/TRD/trdglo.F90 +++ b/src/OCE/TRD/trdglo.F90 @@ -37,20 +37,21 @@ MODULE trdglo PUBLIC trd_glo_init ! called by trdini module ! !!! Variables used for diagnostics - REAL(dp) :: tvolt ! volume of the whole ocean computed at t-points - REAL(dp) :: tvolu ! volume of the whole ocean computed at u-points - REAL(dp) :: tvolv ! volume of the whole ocean computed at v-points - REAL(dp) :: rpktrd ! potential to kinetic energy conversion - REAL(dp) :: peke ! conversion potential energy - kinetic energy trend + REAL(wp) :: tvolt ! volume of the whole ocean computed at t-points + REAL(wp) :: tvolu ! volume of the whole ocean computed at u-points + REAL(wp) :: tvolv ! volume of the whole ocean computed at v-points + REAL(wp) :: rpktrd ! potential to kinetic energy conversion + REAL(wp) :: peke ! conversion potential energy - kinetic energy trend ! !!! domain averaged trends - REAL(dp), DIMENSION(jptot_tra) :: tmo, smo ! temperature and salinity trends - REAL(dp), DIMENSION(jptot_tra) :: t2 , s2 ! T^2 and S^2 trends - REAL(dp), DIMENSION(jptot_dyn) :: umo, vmo ! momentum trends - REAL(dp), DIMENSION(jptot_dyn) :: hke ! kinetic energy trends (u^2+v^2) + REAL(wp), DIMENSION(jptot_tra) :: tmo, smo ! temperature and salinity trends + REAL(wp), DIMENSION(jptot_tra) :: t2 , s2 ! T^2 and S^2 trends + REAL(wp), DIMENSION(jptot_dyn) :: umo, vmo ! momentum trends + REAL(wp), DIMENSION(jptot_dyn) :: hke ! kinetic energy trends (u^2+v^2) !! * Substitutions # include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) @@ -76,8 +77,8 @@ CONTAINS !! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ikbu, ikbv ! local integers - REAL(dp):: zvm, zvt, zvs, z1_2rho0 ! local scalars - REAL(dp), DIMENSION(jpi,jpj) :: ztswu, ztswv, z2dx, z2dy ! 2D workspace + REAL(wp):: zvm, zvt, zvs, z1_2rho0 ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: ztswu, ztswv, z2dx, z2dy ! 2D workspace !!---------------------------------------------------------------------- ! IF( MOD(kt,nn_trd) == 0 .OR. kt == nit000 .OR. kt == nitend ) THEN @@ -184,8 +185,8 @@ CONTAINS INTEGER, INTENT(in) :: Kmm ! time level index ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zcof ! local scalar - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zkx, zky, zkz, zkepe + REAL(wp) :: zcof ! local scalar + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zkx, zky, zkz, zkepe !!---------------------------------------------------------------------- ! I. Momentum trends @@ -201,7 +202,7 @@ CONTAINS zkz (:,:,:) = 0._wp zkepe(:,:,:) = 0._wp - CALL eos( ts(:,:,:,:,Kmm), rhd, rhop ) ! now potential density + CALL eos( ts(:,:,:,:,Kmm), rhd, CASTSP(rhop) ) ! now potential density zcof = 0.5_wp / rho0 ! Density flux at w-point zkz(:,:,1) = 0._wp diff --git a/src/OCE/TRD/trdken.F90 b/src/OCE/TRD/trdken.F90 index 351487a78e41e0a2d2f51ccc164059301a955fd6..b23a4d68901e78a23b93ad8de63b6e0f1ad18c19 100644 --- a/src/OCE/TRD/trdken.F90 +++ b/src/OCE/TRD/trdken.F90 @@ -35,8 +35,8 @@ MODULE trdken INTEGER :: nkstp ! current time step - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: bu, bv ! volume of u- and v-boxes - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: r1_bt ! inverse of t-box volume + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: bu, bv ! volume of u- and v-boxes + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: r1_bt ! inverse of t-box volume !! * Substitutions # include "do_loop_substitute.h90" @@ -85,8 +85,8 @@ CONTAINS INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ikbu , ikbv ! local integers INTEGER :: ikbum1, ikbvm1 ! - - - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: z2dx, z2dy, zke2d ! 2D workspace - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zke ! 3D workspace + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: z2dx, z2dy, zke2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zke ! 3D workspace !!---------------------------------------------------------------------- ! CALL lbc_lnk( 'trdken', putrd, 'U', -1.0_dp , pvtrd, 'V', -1.0_dp ) ! lateral boundary conditions @@ -198,12 +198,12 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! ocean time-step index INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pconv ! + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pconv ! ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: iku, ikv ! local integers - REAL(dp) :: zcoef ! local scalars - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zconv ! 3D workspace + REAL(wp) :: zcoef ! local scalars + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zconv ! 3D workspace !!---------------------------------------------------------------------- ! ! Local constant initialization diff --git a/src/OCE/TRD/trdmxl.F90 b/src/OCE/TRD/trdmxl.F90 index 9852dc9f17fccf614d05099cff1f767522be875b..a598e5f8a326a507c9cd18303371ffbc412cdcdb 100644 --- a/src/OCE/TRD/trdmxl.F90 +++ b/src/OCE/TRD/trdmxl.F90 @@ -96,8 +96,8 @@ CONTAINS !! constraints, barotropic vorticity, kinetic enrgy, !! potential energy, and/or mixed layer budget. !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend - REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend INTEGER , INTENT(in ) :: ktrd ! tracer trend index INTEGER , INTENT(in ) :: kt ! time step index INTEGER , INTENT(in ) :: Kmm ! time level index @@ -212,7 +212,7 @@ CONTAINS !! ** Purpose : !!---------------------------------------------------------------------- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptrd ! trend at kt - REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdm ! cumulative trends at kt + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptrdm ! cumulative trends at kt INTEGER , INTENT(in ) :: kt ! time step index !!---------------------------------------------------------------------- ! @@ -253,7 +253,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pstrdmxl ! salinity trend ! INTEGER :: ji, jj, jk, isum - REAL(dp), DIMENSION(jpi,jpj) :: zvlmsk + REAL(wp), DIMENSION(jpi,jpj) :: zvlmsk !!---------------------------------------------------------------------- ! I. Definition of control surface and associated fields @@ -328,16 +328,16 @@ CONTAINS !! References : Vialard et al.,2001, JPO. !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! ocean time-step index - REAL(dp), INTENT(in ) :: p2dt ! time step [s] + REAL(wp), INTENT(in ) :: p2dt ! time step [s] ! INTEGER :: ji, jj, jk, jl, ik, it, itmod LOGICAL :: lldebug = .TRUE. - REAL(dp) :: zavt, zfn, zfn2 + REAL(wp) :: zavt, zfn, zfn2 ! ! z(ts)mltot : dT/dt over the anlysis window (including Asselin) ! ! z(ts)mlres : residual = dh/dt entrainment term - REAL(dp), DIMENSION(jpi,jpj ) :: ztmltot , zsmltot , ztmlres , zsmlres , ztmlatf , zsmlatf - REAL(dp), DIMENSION(jpi,jpj ) :: ztmltot2, zsmltot2, ztmlres2, zsmlres2, ztmlatf2, zsmlatf2, ztmltrdm2, zsmltrdm2 - REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztmltrd2, zsmltrd2 ! only needed for mean diagnostics + REAL(wp), DIMENSION(jpi,jpj ) :: ztmltot , zsmltot , ztmlres , zsmlres , ztmlatf , zsmlatf + REAL(wp), DIMENSION(jpi,jpj ) :: ztmltot2, zsmltot2, ztmlres2, zsmlres2, ztmlatf2, zsmlatf2, ztmltrdm2, zsmltrdm2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmltrd2, zsmltrd2 ! only needed for mean diagnostics !!---------------------------------------------------------------------- ! ====================================================================== @@ -452,7 +452,7 @@ CONTAINS ztmltot2(:,:) = 0.e0 ; zsmltot2(:,:) = 0.e0 ztmlres2(:,:) = 0.e0 ; zsmlres2(:,:) = 0.e0 - zfn = REAL( nmoymltrd,dp ) ; zfn2 = zfn * zfn + zfn = REAL( nmoymltrd, wp ) ; zfn2 = zfn * zfn ! III.1 Prepare fields for output ("instantaneous" diagnostics) ! ------------------------------------------------------------- @@ -471,9 +471,9 @@ CONTAINS !-- Lateral boundary conditions ! ... temperature ... ... salinity ... - CALL lbc_lnk( 'trdmxl', ztmltot , 'T', 1.0_dp, zsmltot , 'T', 1.0_dp, & - & ztmlres , 'T', 1.0_dp, zsmlres , 'T', 1.0_dp, & - & ztmlatf , 'T', 1.0_dp, zsmlatf , 'T', 1.0_dp ) + CALL lbc_lnk( 'trdmxl', ztmltot , 'T', 1.0_wp, zsmltot , 'T', 1.0_wp, & + & ztmlres , 'T', 1.0_wp, zsmlres , 'T', 1.0_wp, & + & ztmlatf , 'T', 1.0_wp, zsmlatf , 'T', 1.0_wp ) ! III.2 Prepare fields for output ("mean" diagnostics) @@ -522,10 +522,10 @@ CONTAINS !-- Lateral boundary conditions ! ... temperature ... ... salinity ... - CALL lbc_lnk( 'trdmxl', ztmltot2, 'T', 1.0_dp, zsmltot2, 'T', 1.0_dp, & - & ztmlres2, 'T', 1.0_dp, zsmlres2, 'T', 1.0_dp ) + CALL lbc_lnk( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, & + & ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp ) ! - CALL lbc_lnk( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_dp, zsmltrd2(:,:,:), 'T', 1.0_dp ) ! / in the NetCDF trends file + CALL lbc_lnk( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! / in the NetCDF trends file ! III.3 Time evolution array swap ! ------------------------------- @@ -549,19 +549,19 @@ CONTAINS ! ML depth hmxlbn (:,:) = hmxl (:,:) - IF( sn_cfctl%l_prtctl ) THEN - IF( ln_trdmxl_instant ) THEN + ! IF( sn_cfctl%l_prtctl ) THEN + ! IF( ln_trdmxl_instant ) THEN !CALL prt_ctl(tab2d_1=tmlbb , clinfo1=' tmlbb - : ', mask1=tmask) !CALL prt_ctl(tab2d_1=tmlbn , clinfo1=' tmlbn - : ', mask1=tmask) !CALL prt_ctl(tab2d_1=tmlatfb , clinfo1=' tmlatfb - : ', mask1=tmask) - ELSE + ! ELSE !CALL prt_ctl(tab2d_1=tmlbn , clinfo1=' tmlbn - : ', mask1=tmask) !CALL prt_ctl(tab2d_1=hmxlbn , clinfo1=' hmxlbn - : ', mask1=tmask) !CALL prt_ctl(tab2d_1=tml_sumb , clinfo1=' tml_sumb - : ', mask1=tmask) !CALL prt_ctl(tab2d_1=tmltrd_atf_sumb, clinfo1=' tmltrd_atf_sumb - : ', mask1=tmask) !CALL prt_ctl(tab3d_1=tmltrd_csum_ub , clinfo1=' tmltrd_csum_ub - : ', mask1=tmask, kdim=1) - END IF - END IF + ! END IF + ! END IF ! III.4 Convert to appropriate physical units ! ------------------------------------------- @@ -866,4 +866,4 @@ CONTAINS END SUBROUTINE trd_mxl_init !!====================================================================== -END MODULE trdmxl +END MODULE trdmxl \ No newline at end of file diff --git a/src/OCE/TRD/trdmxl_oce.F90 b/src/OCE/TRD/trdmxl_oce.F90 index bf9d5eb76bcf511b74dbd848fdbb4023426c322e..e19659eae902a0bad44be00eda6050793257d474 100644 --- a/src/OCE/TRD/trdmxl_oce.F90 +++ b/src/OCE/TRD/trdmxl_oce.F90 @@ -31,8 +31,8 @@ MODULE trdmxl_oce INTEGER, PUBLIC, PARAMETER :: jpmxl_atf = 12 !: asselin trend (**MUST BE THE LAST ONE**) ! !!* Namelist namtrd_mxl: trend diagnostics in the mixed layer * INTEGER , PUBLIC :: nn_ctls = 0 !: control surface type for trends vertical integration - REAL(dp) , PUBLIC :: rn_rho_c = 0.01 !: density criteria for MLD definition - REAL(dp) , PUBLIC :: rn_ucf = 1. !: unit conversion factor (for netCDF trends outputs) + REAL(wp) , PUBLIC :: rn_rho_c = 0.01 !: density criteria for MLD definition + REAL(wp) , PUBLIC :: rn_ucf = 1. !: unit conversion factor (for netCDF trends outputs) ! =1. (=86400.) for degC/s (degC/day) and psu/s (psu/day) CHARACTER(len=32), PUBLIC :: cn_trdrst_in = "restart_mxl" !: suffix of ocean restart name (input) CHARACTER(len=32), PUBLIC :: cn_trdrst_out = "restart_mxl" !: suffix of ocean restart name (output) @@ -47,41 +47,38 @@ MODULE trdmxl_oce INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmxl !: mixed layer depth indexes INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nbol !: mixed-layer depth indexes when read from file - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wkx !: - - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmxl , tml , sml , tmlb , smlb , tmlbb , smlbb, tmlbn , smlbn, tmltrdm, smltrdm, tml_sum, tml_sumb, tmltrd_atf_sumb, sml_sum, sml_sumb, smltrd_atf_sumb, hmxl_sum, hmxlbn - - - - - - - - - - - - - - - - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmlatfb, tmlatfn , smlatfb, smlatfn, tmlatfm, smlatfm - - - - - - - REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: tmltrd, smltrd, tmltrd_sum, tmltrd_csum_ln, tmltrd_csum_ub, smltrd_sum, smltrd_csum_ln, smltrd_csum_ub - - - - - - - - - + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wkx !: + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: & + hmxl , & !: mixed layer depth (m) corresponding to nmld + tml , sml , & !: \ "now" mixed layer temperature/salinity + tmlb , smlb , & !: / and associated "before" fields + tmlbb , smlbb, & !: \ idem, but valid at the 1rst time step of the + tmlbn , smlbn, & !: / current analysis window + tmltrdm, smltrdm, & !: total cumulative trends over the analysis window + tml_sum, & !: mixed layer T, summed over the current analysis period + tml_sumb, & !: idem, but from the previous analysis period + tmltrd_atf_sumb, & !: Asselin trends, summed over the previous analysis period + sml_sum, & !: + sml_sumb, & !: ( idem for salinity ) + smltrd_atf_sumb, & !: + hmxl_sum, hmxlbn !: needed to compute the leap-frog time mean of the ML depth + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: & + tmlatfb, tmlatfn , & !: "before" Asselin contribution at begining of the averaging + smlatfb, smlatfn, & !: period (i.e. last contrib. from previous such period) and + !: "now" Asselin contribution to the ML temp. & salinity trends + tmlatfm, smlatfm !: accumulator for Asselin trends (needed for storage only) + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: & + tmltrd, & !: \ physical contributions to the total trend (for T/S), + smltrd, & !: / cumulated over the current analysis window + tmltrd_sum, & !: sum of these trends over the analysis period + tmltrd_csum_ln, & !: now cumulated sum of the trends over the "lower triangle" + tmltrd_csum_ub, & !: before (prev. analysis period) cumulated sum over the upper triangle + smltrd_sum, & !: + smltrd_csum_ln, & !: ( idem for salinity ) + smltrd_csum_ub !: !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) diff --git a/src/OCE/TRD/trdpen.F90 b/src/OCE/TRD/trdpen.F90 index bf8a57d0208b8d34de65c2a92589e011a41bbe96..5ff1dd338ae01d338dc2a45248e5c046e94ddd88 100644 --- a/src/OCE/TRD/trdpen.F90 +++ b/src/OCE/TRD/trdpen.F90 @@ -32,7 +32,7 @@ MODULE trdpen INTEGER :: nkstp ! current time step - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_pe ! partial derivatives of PE anomaly with respect to T and S + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_pe ! partial derivatives of PE anomaly with respect to T and S !! * Substitutions # include "domzgr_substitute.h90" @@ -67,11 +67,11 @@ CONTAINS INTEGER , INTENT(in) :: ktrd ! tracer trend index INTEGER , INTENT(in) :: kt ! time step index INTEGER , INTENT(in) :: Kmm ! time level index - REAL(dp) , INTENT(in) :: pdt ! time step [s] + REAL(wp) , INTENT(in) :: pdt ! time step [s] ! INTEGER :: jk ! dummy loop indices - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D workspace - REAL(dp), DIMENSION(jpi,jpj,jpk) :: zpe ! 3D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpe ! 3D workspace !!---------------------------------------------------------------------- ! zpe(:,:,:) = 0._wp diff --git a/src/OCE/TRD/trdtra.F90 b/src/OCE/TRD/trdtra.F90 index 0eacddb1d9eae27a99a4fa870e109c2fbcd43ed9..155ba37e9da7a38d3fb0e397071bb2951c5ad1b3 100644 --- a/src/OCE/TRD/trdtra.F90 +++ b/src/OCE/TRD/trdtra.F90 @@ -37,7 +37,7 @@ MODULE trdtra PUBLIC trd_tra ! called by all tra_... modules REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: trdtx, trdty, trdt ! use to store the temperature trends - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_evd ! store avt_evd to calculate EVD trend + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_evd ! store avt_evd to calculate EVD trend !! * Substitutions # include "do_loop_substitute.h90" @@ -78,14 +78,15 @@ CONTAINS INTEGER , INTENT(in) :: ktra ! tracer index INTEGER , INTENT(in) :: ktrd ! tracer trend index INTEGER , INTENT(in) :: Kmm, Krhs ! time level indices - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptrd ! tracer trend or flux - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pu ! now velocity + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptrd ! tracer trend or flux + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pu ! now velocity REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: ptra ! now tracer variable ! INTEGER :: jk ! loop indices INTEGER :: i01 ! 0 or 1 REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztrds ! 3D workspace - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zwt, zws, ztrdt ! 3D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwt, zws! 3D workspace + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt! 3D workspace !!---------------------------------------------------------------------- ! IF( .NOT. ALLOCATED( trdtx ) ) THEN ! allocate trdtra arrays @@ -199,8 +200,8 @@ CONTAINS !! k-advective trends = -un. di+1[T] = -( dk+1[fi] - tn dk+1[un] ) !! where fi is the incoming advective flux. !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pf ! advective flux in one direction - REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu ! now velocity in one direction + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pf ! advective flux in one direction + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu ! now velocity in one direction REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt ! now or before tracer CHARACTER(len=1) , INTENT(in ) :: cdir ! X/Y/Z direction REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT( out) :: ptrd ! advective trend in one direction @@ -307,7 +308,7 @@ CONTAINS !! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ikbu, ikbv ! local integers - REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: z2dx, z2dy ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2dx, z2dy ! 2D workspace !!---------------------------------------------------------------------- ! !!gm Rq: mask the trends already masked in trd_tra, but lbc_lnk should probably be added diff --git a/src/OCE/TRD/trdtrc.F90 b/src/OCE/TRD/trdtrc.F90 index bd5717609e149fb31234c9e82de2e448a662385b..f4200feed859135894a873c13d7cc1c02aec7c72 100644 --- a/src/OCE/TRD/trdtrc.F90 +++ b/src/OCE/TRD/trdtrc.F90 @@ -12,7 +12,7 @@ CONTAINS SUBROUTINE trd_trc( ptrtrd, kjn, ktrd, kt, Kmm ) INTEGER :: kt, kjn, ktrd INTEGER :: Kmm ! time level index - REAL(dp), DIMENSION(:,:,:) :: ptrtrd + REAL(dp), DIMENSION(:,:,:) :: ptrtrd WRITE(*,*) 'trd_trc : You should not have seen this print! error?', ptrtrd(1,1,1) WRITE(*,*) ' " " : You should not have seen this print! error?', kjn, ktrd, kt END SUBROUTINE trd_trc diff --git a/src/OCE/TRD/trdvor.F90 b/src/OCE/TRD/trdvor.F90 index 1a92e00c575480cf36b672af0d0612bf8b11d3e6..c6fb760b9a4cf33e1f1d9f084e090d1f1c28a90d 100644 --- a/src/OCE/TRD/trdvor.F90 +++ b/src/OCE/TRD/trdvor.F90 @@ -43,13 +43,13 @@ MODULE trdvor INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndexvor1 ! needed for IOIPSL output INTEGER :: ndebug ! (0/1) set it to 1 in case of problem to have more print - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avr ! average - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrb ! before vorticity (kt-1) - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbb ! vorticity at begining of the nn_write-1 timestep averaging period - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbn ! after vorticity at time step after the - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: rotot ! begining of the NN_WRITE-1 timesteps - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrtot ! - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrres ! + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avr ! average + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrb ! before vorticity (kt-1) + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbb ! vorticity at begining of the nn_write-1 timestep averaging period + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbn ! after vorticity at time step after the + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: rotot ! begining of the NN_WRITE-1 timesteps + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrtot ! + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrres ! REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: vortrd ! curl of trends CHARACTER(len=12) :: cvort @@ -91,7 +91,7 @@ CONTAINS INTEGER , INTENT(in ) :: Kmm ! time level index ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp), DIMENSION(jpi,jpj) :: ztswu, ztswv ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: ztswu, ztswv ! 2D workspace !!---------------------------------------------------------------------- CALL lbc_lnk( 'trdvor', putrd, 'U', -1.0_dp , pvtrd, 'V', -1.0_dp ) ! lateral boundary condition @@ -150,12 +150,12 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: ktrd ! ocean trend index INTEGER , INTENT(in) :: Kmm ! time level index - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: putrdvor ! u vorticity trend - REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pvtrdvor ! v vorticity trend + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: putrdvor ! u vorticity trend + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pvtrdvor ! v vorticity trend ! INTEGER :: ji, jj ! dummy loop indices INTEGER :: ikbu, ikbv ! local integers - REAL(dp), DIMENSION(jpi,jpj) :: zudpvor, zvdpvor ! total cmulative trends + REAL(wp), DIMENSION(jpi,jpj) :: zudpvor, zvdpvor ! total cmulative trends !!---------------------------------------------------------------------- ! ===================================== @@ -231,7 +231,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pvtrdvor ! v vorticity trend ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp), DIMENSION(jpi,jpj) :: zudpvor, zvdpvor ! total cmulative trends + REAL(wp), DIMENSION(jpi,jpj) :: zudpvor, zvdpvor ! total cmulative trends !!---------------------------------------------------------------------- ! ===================================== @@ -284,8 +284,8 @@ CONTAINS ! INTEGER :: ji, jj, jk, jl ! dummy loop indices INTEGER :: it, itmod ! local integers - REAL(dp) :: zmean ! local scalars - REAL(dp), DIMENSION(jpi,jpj) :: zuu, zvv + REAL(wp) :: zmean ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zuu, zvv !!---------------------------------------------------------------------- ! ================= @@ -359,17 +359,17 @@ CONTAINS ! III.1 compute total trend ! ------------------------ - zmean = 1._wp / ( REAL( nmoydpvor,dp ) * 2._wp * rn_Dt ) + zmean = 1._wp / ( REAL( nmoydpvor, wp ) * 2._wp * rn_Dt ) vor_avrtot(:,:) = ( vor_avr(:,:) - vor_avrbn(:,:) + vor_avrb(:,:) - vor_avrbb(:,:) ) * zmean ! III.2 compute residual ! --------------------- - zmean = 1._wp / REAL( nmoydpvor,dp ) + zmean = 1._wp / REAL( nmoydpvor, wp ) vor_avrres(:,:) = vor_avrtot(:,:) - rotot(:,:) / zmean ! Boundary conditions - CALL lbc_lnk( 'trdvor', vor_avrtot, 'F', 1.0_dp , vor_avrres, 'F', 1.0_dp ) + CALL lbc_lnk( 'trdvor', vor_avrtot, 'F', 1.0_wp , vor_avrres, 'F', 1.0_wp ) ! III.3 time evolution array swap @@ -403,8 +403,8 @@ CONTAINS CALL histwrite( nidvor,"sovortbv",it,vortrd(:,:,jpvor_bev),ndimvor1,ndexvor1) ! beta.V CALL histwrite( nidvor,"sovowind",it,vortrd(:,:,jpvor_swf),ndimvor1,ndexvor1) ! wind stress CALL histwrite( nidvor,"sovobfri",it,vortrd(:,:,jpvor_bfr),ndimvor1,ndexvor1) ! bottom friction - CALL histwrite( nidvor,"1st_mbre",it,vor_avrtot ,ndimvor1,ndexvor1) ! First membre - CALL histwrite( nidvor,"sovorgap",it,vor_avrres ,ndimvor1,ndexvor1) ! gap between 1st and 2 nd mbre + CALL histwrite( nidvor,"1st_mbre",it,REAL(vor_avrtot,dp) ,ndimvor1,ndexvor1) ! First membre + CALL histwrite( nidvor,"sovorgap",it,REAL(vor_avrres,dp) ,ndimvor1,ndexvor1) ! gap between 1st and 2 nd mbre ! IF( ndebug /= 0 ) THEN WRITE(numout,*) ' debuging trd_vor: III.4 done' @@ -427,8 +427,7 @@ CONTAINS !! ** Purpose : computation of vertically integrated T and S budgets !! from ocean surface down to control surface (NetCDF output) !!---------------------------------------------------------------------- - REAL(dp) :: zsto, zout - REAL(dp) :: zjulian + REAL(dp) :: zjulian, zsto, zout CHARACTER (len=40) :: clhstnam CHARACTER (len=40) :: clop !!---------------------------------------------------------------------- @@ -491,7 +490,7 @@ CONTAINS ! II.2 Compute julian date from starting date of the run ! ------------------------ - CALL ymds2ju( nyear, nmonth, nday, rn_Dt, zjulian ) + CALL ymds2ju( nyear, nmonth, nday, REAL(rn_Dt,dp), 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, & @@ -502,8 +501,8 @@ CONTAINS ! --------------------------------- CALL dia_nam( clhstnam, nn_trd, 'vort' ) ! filename IF(lwp) WRITE(numout,*) ' Name of NETCDF file ', clhstnam - CALL histbeg( clhstnam, jpi, glamf, jpj, gphif,1, jpi, & ! Horizontal grid : glamt and gphit - & 1, jpj, nit000-1, zjulian, rn_Dt, nh_t, nidvor, domain_id=nidom, snc4chunks=snc4set ) + CALL histbeg( clhstnam, jpi, REAL(glamf,dp), jpj, REAL(gphif,dp),1, jpi, & ! Horizontal grid : glamt and gphit + & 1, jpj, nit000-1, zjulian, REAL(rn_Dt,dp), nh_t, nidvor, domain_id=nidom, snc4chunks=snc4set ) CALL wheneq( jpi*jpj, fmask, 1, 1., ndexvor1, ndimvor1 ) ! surface ! Declare output fields as netCDF variables diff --git a/src/OCE/USR/usrdef_hgr.F90 b/src/OCE/USR/usrdef_hgr.F90 index 6320ca2ad7484bb05cb1566bdcfd7aab664f4f8d..935917564a0c42954dea4d4cda7aecd8edb214b8 100644 --- a/src/OCE/USR/usrdef_hgr.F90 +++ b/src/OCE/USR/usrdef_hgr.F90 @@ -58,18 +58,20 @@ CONTAINS !! - define i- & j-scale factors at t-, u-, v- and f-points (in meters) !! - define u- & v-surfaces (if gridsize reduction is used in some straits) (in m2) !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:,:), INTENT(out) :: plamt, plamu, plamv, plamf ! longitude outputs [degrees] - REAL(dp), DIMENSION(:,:), INTENT(out) :: pphit, pphiu, pphiv, pphif ! latitude outputs [degrees] + REAL(wp), DIMENSION(:,:), INTENT(out) :: plamt, plamu, plamv, plamf ! longitude outputs [degrees] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pphit, pphiu, pphiv, pphif ! latitude outputs [degrees] INTEGER , INTENT(out) :: kff ! =1 Coriolis parameter computed here, =0 otherwise - REAL(dp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point [1/s] - REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1v, pe1f ! i-scale factors [m] - REAL(dp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2u, pe2v, pe2f ! j-scale factors [m] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point [1/s] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1v! i-scale factors [m] + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1f! i-scale factors [m] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2u! j-scale factors [m] + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2v, pe2f! j-scale factors [m] INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces computed here, =0 otherwise - REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] ! INTEGER :: ji, jj ! dummy loop indices - REAL(dp) :: zlam1, zlam0, zcos_alpha, zim1 , zjm1 , ze1 , ze1deg, zf0 ! local scalars - REAL(dp) :: zphi1, zphi0, zsin_alpha, zim05, zjm05, zbeta, znorme ! - - + REAL(wp) :: zlam1, zlam0, zcos_alpha, zim1 , zjm1 , ze1 , ze1deg, zf0 ! local scalars + REAL(wp) :: zphi1, zphi0, zsin_alpha, zim05, zjm05, zbeta, znorme ! - - !!------------------------------------------------------------------------------- ! ! !== beta-plane with regular grid-spacing and rotated domain ==! (GYRE configuration) @@ -84,22 +86,22 @@ CONTAINS zlam1 = -85._wp ! position of gridpoint (i,j) = (1,jpjglo) zphi1 = 29._wp ! - ze1 = 106000._wp / REAL( nn_GYRE ,dp ) ! gridspacing in meters + ze1 = 106000._wp / REAL( nn_GYRE , wp ) ! gridspacing in meters ! zsin_alpha = - SQRT( 2._wp ) * 0.5_wp ! angle: 45 degrees zcos_alpha = SQRT( 2._wp ) * 0.5_wp ze1deg = ze1 / (ra * rad) - zlam0 = zlam1 + zcos_alpha * ze1deg * REAL( Ni0glo - 2,dp ) - zphi0 = zphi1 + zsin_alpha * ze1deg * REAL( Nj0glo - 2,dp ) + zlam0 = zlam1 + zcos_alpha * ze1deg * REAL( Ni0glo - 2, wp ) + zphi0 = zphi1 + zsin_alpha * ze1deg * REAL( Nj0glo - 2, wp ) #if defined key_agrif ! ! Upper left longitude and latitude from parent: ! Laurent: Should be modify in case of an east-west cyclic parent grid IF (.NOT.Agrif_root()) THEN - zlam0 = zlam1 + Agrif_irhox() * REAL(Agrif_Parent(Ni0glo) -2,dp) * ze1deg * zcos_alpha & + zlam0 = zlam1 + Agrif_irhox() * REAL(Agrif_Parent(Ni0glo) -2, wp) * ze1deg * zcos_alpha & & + ( Agrif_Ix()*Agrif_irhox()-(0.5_wp+nbghostcells)) * ze1deg * zcos_alpha & & + ( Agrif_Iy()*Agrif_irhoy()-(0.5_wp+nbghostcells)) * ze1deg * zsin_alpha - zphi0 = zphi1 + Agrif_irhoy() * REAL(Agrif_Parent(Nj0glo) -2,dp) * ze1deg * zsin_alpha & + zphi0 = zphi1 + Agrif_irhoy() * REAL(Agrif_Parent(Nj0glo) -2, wp) * ze1deg * zsin_alpha & & - ( Agrif_Ix()*Agrif_irhox()-nbghostcells ) * ze1deg * zsin_alpha & & + ( Agrif_Iy()*Agrif_irhoy()-nbghostcells ) * ze1deg * zcos_alpha ENDIF @@ -115,8 +117,8 @@ CONTAINS ENDIF ! DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) - zim1 = REAL( mig0(ji),dp ) - 1. ; zim05 = REAL( mig0(ji),dp ) - 1.5 - zjm1 = REAL( mjg0(jj),dp ) - 1. ; zjm05 = REAL( mjg0(jj),dp ) - 1.5 + zim1 = REAL( mig0(ji), wp ) - 1. ; zim05 = REAL( mig0(ji), wp ) - 1.5 + zjm1 = REAL( mjg0(jj), wp ) - 1. ; zjm05 = REAL( mjg0(jj), wp ) - 1.5 ! !glamt(i,j) longitude at T-point !gphit(i,j) latitude at T-point diff --git a/src/OCE/USR/usrdef_istate.F90 b/src/OCE/USR/usrdef_istate.F90 index c0699ebbbfaee90a8614f91f41023d729452e819..fde9ea53ad670d4e479c497a2037bab019bf3248 100644 --- a/src/OCE/USR/usrdef_istate.F90 +++ b/src/OCE/USR/usrdef_istate.F90 @@ -44,7 +44,7 @@ CONTAINS !! ** Method : - set temprature field !! - set salinity field !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] diff --git a/src/OCE/USR/usrdef_sbc.F90 b/src/OCE/USR/usrdef_sbc.F90 index 5723e708c800b2f16f85ac7eff35de9721ce354b..6f20cd47c3e1e1f37de92da4b6f460ee22dddd96 100644 --- a/src/OCE/USR/usrdef_sbc.F90 +++ b/src/OCE/USR/usrdef_sbc.F90 @@ -61,22 +61,21 @@ CONTAINS INTEGER :: zmonth0 ! initial month INTEGER :: zday0 ! initial day INTEGER :: zday_year0 ! initial day since january 1st - REAL(dp) :: ztau , ztau_sais ! wind intensity and of the seasonal cycle - REAL(dp) :: ztime ! time in hour - REAL(dp) :: ztimemax , ztimemin ! 21th June, and 21th decem. if date0 = 1st january - REAL(dp) :: ztimemax1, ztimemin1 ! 21th June, and 21th decem. if date0 = 1st january - REAL(dp) :: ztimemax2, ztimemin2 ! 21th June, and 21th decem. if date0 = 1st january - REAL(dp) :: ztaun ! intensity - REAL(dp) :: zemp_S, zemp_N, zemp_sais, zTstar - REAL(dp) :: zcos_sais1, zcos_sais2, ztrp, zconv, t_star - REAL(dp) :: zsumemp, zsurf - REAL(dp) :: esumemp - REAL(dp) :: zrhoa = 1.22 ! Air density kg/m3 - REAL(dp) :: zcdrag = 1.5e-3 ! drag coefficient - REAL(dp) :: ztx, zty, zmod, zcoef ! temporary variables - REAL(dp) :: zyydd ! number of days in one year + REAL(wp) :: ztau , ztau_sais ! wind intensity and of the seasonal cycle + REAL(wp) :: ztime ! time in hour + REAL(wp) :: ztimemax , ztimemin ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztimemax1, ztimemin1 ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztimemax2, ztimemin2 ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztaun ! intensity + REAL(wp) :: zemp_S, zemp_N, zemp_sais, zTstar + REAL(wp) :: zcos_sais1, zcos_sais2, ztrp, zconv, t_star + REAL(wp) :: zsumemp, zsurf + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: ztx, zty, zmod, zcoef ! temporary variables + REAL(wp) :: zyydd ! number of days in one year !!--------------------------------------------------------------------- - zyydd = REAL(nyear_len(1),dp) + zyydd = REAL(nyear_len(1),wp) ! ---------------------------- ! ! heat and freshwater fluxes ! @@ -131,7 +130,7 @@ CONTAINS ENDIF END_2D - esumemp = GLOB_SUM( 'usrdef_sbc', REAL(emp(:,:),dp) ) + zsumemp = GLOB_SUM( 'usrdef_sbc', REAL(emp (:,:),dp) ) zsurf = GLOB_SUM( 'usrdef_sbc', REAL(tmask(:,:,1),dp) ) zsumemp = zsumemp / zsurf ! Default GYRE configuration diff --git a/src/OCE/USR/usrdef_zgr.F90 b/src/OCE/USR/usrdef_zgr.F90 index ed1228ac025dc0f91d43b3b2ffdb8e73c5ad5a9c..a312a64b55c92a4de880ef119c7b4be01650972a 100644 --- a/src/OCE/USR/usrdef_zgr.F90 +++ b/src/OCE/USR/usrdef_zgr.F90 @@ -49,16 +49,17 @@ CONTAINS !!---------------------------------------------------------------------- LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag - REAL(dp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] - REAL(dp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m] - REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] - REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] - REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [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 ! i-scale factors INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level ! INTEGER :: inum ! local logical unit - REAL(dp) :: z_zco, z_zps, z_sco, z_cav - REAL(dp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + REAL(WP) :: z_zco, z_zps, z_sco, z_cav + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace !!---------------------------------------------------------------------- ! IF(lwp) WRITE(numout,*) @@ -119,12 +120,12 @@ CONTAINS !! Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766. !! Madec and Imbard, 1996, Clim. Dyn. !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] - REAL(dp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + 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] ! INTEGER :: jk ! dummy loop indices - REAL(dp) :: zt, zw ! local scalars - REAL(dp) :: zsur, za0, za1, zkth, zacr ! Values for the Madec & Imbard (1996) function + REAL(wp) :: zt, zw ! local scalars + REAL(wp) :: zsur, za0, za1, zkth, zacr ! Values for the Madec & Imbard (1996) function !!---------------------------------------------------------------------- ! ! Set parameters of z(k) function @@ -152,8 +153,8 @@ CONTAINS ! ------------------------- ! DO jk = 1, jpk ! depth at T and W-points - zw = REAL( jk ,dp ) - zt = REAL( jk ,dp ) + 0.5_wp + zw = REAL( jk , wp ) + zt = REAL( jk , wp ) + 0.5_wp pdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG( COSH( (zw-zkth) / zacr ) ) ) pdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG( COSH( (zt-zkth) / zacr ) ) ) END DO @@ -189,7 +190,7 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , DIMENSION(:,:), INTENT(out) :: k_top , k_bot ! first & last wet ocean level ! - REAL(dp), DIMENSION(jpi,jpj) :: z2d ! 2D local workspace + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D local workspace !!---------------------------------------------------------------------- ! IF(lwp) WRITE(numout,*) @@ -197,7 +198,7 @@ CONTAINS IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' IF(lwp) WRITE(numout,*) ' GYRE case : closed flat box ocean without ocean cavities' ! - z2d(:,:) = REAL( jpkm1 ,dp ) ! flat bottom + z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom ! k_bot(:,:) = NINT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere ! @@ -217,11 +218,12 @@ CONTAINS !! !! ** Method : set 3D coord. arrays to reference 1D array !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(:) , INTENT(in ) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] - REAL(dp), DIMENSION(:) , INTENT(in ) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pdept, pdepw ! grid-point depth [m] - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pe3w , pe3uw, pe3vw ! - - - + REAL(wp), DIMENSION(:) , INTENT(in ) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(in ) :: 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) :: 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 :: jk !!---------------------------------------------------------------------- diff --git a/src/OCE/ZDF/zdf_oce.F90 b/src/OCE/ZDF/zdf_oce.F90 index a02bac0c42a85f0798f501ef6f5c74f4be2e0ff4..ac79e16a8b08b19ba30e059303f6cd908095a7c1 100644 --- a/src/OCE/ZDF/zdf_oce.F90 +++ b/src/OCE/ZDF/zdf_oce.F90 @@ -28,30 +28,30 @@ MODULE zdf_oce ! ! convection LOGICAL , PUBLIC :: ln_zdfevd !: convection: enhanced vertical diffusion flag INTEGER , PUBLIC :: nn_evdm !: =0/1 flag to apply enhanced avm or not - REAL(dp), PUBLIC :: rn_evd !: vertical eddy coeff. for enhanced vert. diff. (m2/s) + REAL(wp), PUBLIC :: rn_evd !: vertical eddy coeff. for enhanced vert. diff. (m2/s) LOGICAL , PUBLIC :: ln_zdfnpc !: convection: non-penetrative convection flag INTEGER , PUBLIC :: nn_npc !: non penetrative convective scheme call frequency INTEGER , PUBLIC :: nn_npcp !: non penetrative convective scheme print frequency ! ! double diffusion LOGICAL , PUBLIC :: ln_zdfddm !: double diffusive mixing flag - REAL(dp), PUBLIC :: rn_avts !: maximum value of avs for salt fingering - REAL(dp), PUBLIC :: rn_hsbfr !: heat/salt buoyancy flux ratio + REAL(wp), PUBLIC :: rn_avts !: maximum value of avs for salt fingering + REAL(wp), PUBLIC :: rn_hsbfr !: heat/salt buoyancy flux ratio ! ! gravity wave-induced vertical mixing LOGICAL , PUBLIC :: ln_zdfswm !: surface wave-induced mixing flag LOGICAL , PUBLIC :: ln_zdfiwm !: internal wave-induced mixing flag LOGICAL , PUBLIC :: ln_zdfmfc !: convection: eddy diffusivity Mass Flux Convection ! ! coefficients - REAL(dp), PUBLIC :: rn_avm0 !: vertical eddy viscosity (m2/s) - REAL(dp), PUBLIC :: rn_avt0 !: vertical eddy diffusivity (m2/s) + REAL(wp), PUBLIC :: rn_avm0 !: vertical eddy viscosity (m2/s) + REAL(wp), PUBLIC :: rn_avt0 !: vertical eddy diffusivity (m2/s) INTEGER , PUBLIC :: nn_avb !: constant or profile background on avt (=0/1) INTEGER , PUBLIC :: nn_havtb !: horizontal shape or not for avtb (=0/1) ! ! convection - REAL(dp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm, avt, avs !: vertical mixing coefficients (w-point) [m2/s] - REAL(dp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm_k , avt_k !: Kz computed by turbulent closure alone [m2/s] - REAL(dp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: en !: now turbulent kinetic energy [m2/s2] - REAL(dp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: avmb , avtb !: background profile of avm and avt [m2/s] - REAL(dp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: avtb_2d !: horizontal shape of background Kz profile [-] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm, avt, avs !: vertical mixing coefficients (w-point) [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm_k , avt_k !: Kz computed by turbulent closure alone [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: en !: now turbulent kinetic energy [m2/s2] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: avmb , avtb !: background profile of avm and avt [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: avtb_2d !: horizontal shape of background Kz profile [-] !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) diff --git a/src/OCE/ZDF/zdfddm.F90 b/src/OCE/ZDF/zdfddm.F90 index 3f4b65cc82d6bf68095b294461e523cfa3566f54..a829a1e225fb1a3d9e9a90d53874cc5d2ee76829 100644 --- a/src/OCE/ZDF/zdfddm.F90 +++ b/src/OCE/ZDF/zdfddm.F90 @@ -70,19 +70,19 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: kt ! ocean time-step index INTEGER, INTENT(in ) :: Kmm ! ocean time level index - REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: p_avm ! Kz on momentum (w-points) - REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: p_avt ! Kz on temperature (w-points) - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: p_avs ! Kz on salinity (w-points) + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm ! Kz on momentum (w-points) + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avt ! Kz on temperature (w-points) + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_avs ! Kz on salinity (w-points) ! INTEGER :: ji, jj , jk ! dummy loop indices - REAL(dp) :: zaw, zbw, zrw ! local scalars - REAL(dp) :: zdt, zds - REAL(dp) :: zinr ! - - - REAL(dp) :: zrr ! - - - REAL(dp) :: zavft ! - - - REAL(dp) :: zavfs ! - - - REAL(dp) :: zavdt, zavds ! - - - REAL(dp), DIMENSION(A2D(nn_hls)) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3 + REAL(wp) :: zaw, zbw, zrw ! local scalars + REAL(wp) :: zdt, zds + REAL(wp) :: zinr ! - - + REAL(wp) :: zrr ! - - + REAL(wp) :: zavft ! - - + REAL(wp) :: zavfs ! - - + REAL(wp) :: zavdt, zavds ! - - + REAL(wp), DIMENSION(A2D(nn_hls)) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3 !!---------------------------------------------------------------------- ! ! ! =============== @@ -157,11 +157,11 @@ CONTAINS END DO ! End of slab ! ! =============== ! - IF(sn_cfctl%l_prtctl) THEN + ! IF(sn_cfctl%l_prtctl) THEN !CALL prt_ctl(tab3d_1=avt , clinfo1=' ddm - t: ', tab3d_2=avs , clinfo2=' s: ') - ENDIF + ! ENDIF ! END SUBROUTINE zdf_ddm !!====================================================================== -END MODULE zdfddm +END MODULE zdfddm \ No newline at end of file diff --git a/src/OCE/ZDF/zdfdrg.F90 b/src/OCE/ZDF/zdfdrg.F90 index 4aeb040c8412b39b340251b9ff3a3b1646fca6b8..20633157780bb3be8ed84bdd3c0480a835ee5e8e 100644 --- a/src/OCE/ZDF/zdfdrg.F90 +++ b/src/OCE/ZDF/zdfdrg.F90 @@ -48,16 +48,16 @@ MODULE zdfdrg LOGICAL , PUBLIC :: ln_drgimp ! implicit top/bottom friction flag LOGICAL , PUBLIC :: ln_drgice_imp ! implicit ice-ocean drag ! !!* Namelist namdrg_top & _bot: TOP or BOTTOM coefficient namelist * - REAL(dp) :: rn_Cd0 !: drag coefficient [ - ] - REAL(dp) :: rn_Uc0 !: characteristic velocity (linear case: tau=rho*Cd0*Uc0*u) [m/s] - REAL(dp) :: rn_Cdmax !: drag value maximum (ln_loglayer=T) [ - ] - REAL(dp) :: rn_z0 !: roughness (ln_loglayer=T) [ m ] - REAL(dp) :: rn_ke0 !: background kinetic energy (non-linear case) [m2/s2] + REAL(wp) :: rn_Cd0 !: drag coefficient [ - ] + REAL(wp) :: rn_Uc0 !: characteristic velocity (linear case: tau=rho*Cd0*Uc0*u) [m/s] + REAL(wp) :: rn_Cdmax !: drag value maximum (ln_loglayer=T) [ - ] + REAL(wp) :: rn_z0 !: roughness (ln_loglayer=T) [ m ] + REAL(wp) :: rn_ke0 !: background kinetic energy (non-linear case) [m2/s2] LOGICAL :: ln_boost !: =T regional boost of Cd0 ; =F Cd0 horizontally uniform - REAL(dp) :: rn_boost !: local boost factor [ - ] + REAL(wp) :: rn_boost !: local boost factor [ - ] - REAL(dp), PUBLIC :: r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top ! set from namdrg_top namelist values - REAL(dp), PUBLIC :: r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot ! - - namdrg_bot - - + REAL(wp), PUBLIC :: r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top ! set from namdrg_top namelist values + REAL(wp), PUBLIC :: r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot ! - - namdrg_bot - - INTEGER :: ndrg ! choice of the type of drag coefficient ! ! associated indices: @@ -69,8 +69,8 @@ MODULE zdfdrg LOGICAL , PUBLIC :: l_zdfdrg !: flag to update at each time step the top/bottom Cd LOGICAL :: l_log_not_linssh !: flag to update at each time step the position ot the velocity point ! - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rCd0_top, rCd0_bot !: precomputed top/bottom drag coeff. at t-point (>0) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rCdU_top, rCdU_bot !: top/bottom drag coeff. at t-point (<0) [m/s] + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rCd0_top, rCd0_bot !: precomputed top/bottom drag coeff. at t-point (>0) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rCdU_top, rCdU_bot !: top/bottom drag coeff. at t-point (<0) [m/s] !! * Substitutions # include "do_loop_substitute.h90" @@ -103,16 +103,16 @@ CONTAINS INTEGER , INTENT(in ) :: Kmm ! ocean time level index ! ! !! !== top or bottom variables ==! INTEGER , DIMENSION(:,:), INTENT(in ) :: k_mk ! wet level (1st or last) - REAL(dp) , INTENT(in ) :: pCdmin ! min drag value - REAL(dp) , INTENT(in ) :: pCdmax ! max drag value - REAL(dp) , INTENT(in ) :: pz0 ! roughness - REAL(dp) , INTENT(in ) :: pke0 ! background tidal KE - REAL(dp), DIMENSION(:,:), INTENT(in ) :: pCd0 ! masked precomputed part of Cd0 - REAL(dp), DIMENSION(:,:), INTENT( out) :: pCdU ! = - Cd*|U| (t-points) [m/s] + REAL(wp) , INTENT(in ) :: pCdmin ! min drag value + REAL(wp) , INTENT(in ) :: pCdmax ! max drag value + REAL(wp) , INTENT(in ) :: pz0 ! roughness + REAL(wp) , INTENT(in ) :: pke0 ! background tidal KE + REAL(wp), DIMENSION(:,:), INTENT(in ) :: pCd0 ! masked precomputed part of Cd0 + REAL(wp), DIMENSION(:,:), INTENT( out) :: pCdU ! = - Cd*|U| (t-points) [m/s] !! INTEGER :: ji, jj ! dummy loop indices INTEGER :: imk ! local integers - REAL(dp):: zzz, zut, zvt, zcd ! local scalars + REAL(wp):: zzz, zut, zvt, zcd ! local scalars !!---------------------------------------------------------------------- ! IF( l_log_not_linssh ) THEN !== "log layer" ==! compute Cd and -Cd*|U| @@ -137,7 +137,7 @@ CONTAINS END_2D ENDIF ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pCdU, clinfo1=' Cd*U ') + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pCdU, clinfo1=' Cd*U ') ! END SUBROUTINE zdf_drg @@ -161,8 +161,8 @@ CONTAINS !! INTEGER :: ji, jj ! dummy loop indexes INTEGER :: ikbu, ikbv ! local integers - REAL(dp) :: zm1_2dt ! local scalar - REAL(dp) :: zCdu, zCdv ! - - + REAL(wp) :: zm1_2dt ! local scalar + REAL(wp) :: zCdu, zCdv ! - - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv !!--------------------------------------------------------------------- ! @@ -208,8 +208,8 @@ CONTAINS DEALLOCATE( ztrdu, ztrdv ) ENDIF ! ! print mean trends (used for debugging) - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pua, clinfo1=' bfr - Ua: ', mask1=umask, & - ! & tab3d_2=pva, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pua, clinfo1=' bfr - Ua: ', mask1=umask, & + ! & tab3d_2=pva, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) ! END SUBROUTINE zdf_drg_exp @@ -294,18 +294,18 @@ CONTAINS !!---------------------------------------------------------------------- CHARACTER(len=6) , INTENT(in ) :: cd_topbot ! top/ bot indicator INTEGER , DIMENSION(:,:), INTENT(in ) :: k_mk ! 1st/last wet level - REAL(dp) , INTENT( out) :: pCdmin, pCdmax ! min and max drag coef. [-] - REAL(dp) , INTENT( out) :: pz0 ! roughness [m] - REAL(dp) , INTENT( out) :: pke0 ! background KE [m2/s2] - REAL(dp), DIMENSION(:,:), INTENT( out) :: pCd0 ! masked precomputed part of the non-linear drag coefficient - REAL(dp), DIMENSION(:,:), INTENT( out) :: pCdU ! minus linear drag*|U| at t-points [m/s] + REAL(wp) , INTENT( out) :: pCdmin, pCdmax ! min and max drag coef. [-] + REAL(wp) , INTENT( out) :: pz0 ! roughness [m] + REAL(wp) , INTENT( out) :: pke0 ! background KE [m2/s2] + REAL(wp), DIMENSION(:,:), INTENT( out) :: pCd0 ! masked precomputed part of the non-linear drag coefficient + REAL(wp), DIMENSION(:,:), INTENT( out) :: pCdU ! minus linear drag*|U| at t-points [m/s] !! CHARACTER(len=40) :: cl_namdrg, cl_file, cl_varname, cl_namref, cl_namcfg ! local names INTEGER :: ji, jj ! dummy loop indexes LOGICAL :: ll_top, ll_bot ! local logical INTEGER :: ios, inum, imk ! local integers - REAL(dp):: zmsk, zzz, zcd ! local scalars - REAL(dp), DIMENSION(jpi,jpj) :: zmsk_boost ! 2D workspace + REAL(wp):: zmsk, zzz, zcd ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zmsk_boost ! 2D workspace !! NAMELIST/namdrg_top/ rn_Cd0, rn_Uc0, rn_Cdmax, rn_ke0, rn_z0, ln_boost, rn_boost NAMELIST/namdrg_bot/ rn_Cd0, rn_Uc0, rn_Cdmax, rn_ke0, rn_z0, ln_boost, rn_boost diff --git a/src/OCE/ZDF/zdfevd.F90 b/src/OCE/ZDF/zdfevd.F90 index 11920b3402dfcc7a7405805f19e5c002aac2ba0f..c72d816f08b211095539404f2b3261cee896fcb1 100644 --- a/src/OCE/ZDF/zdfevd.F90 +++ b/src/OCE/ZDF/zdfevd.F90 @@ -58,11 +58,11 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! ocean time-step indexocean time step INTEGER , INTENT(in ) :: Kmm, Krhs ! time level indices - REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) ! INTEGER :: ji, jj, jk ! dummy loop indices ! NOTE: [tiling] use a SAVE array to store diagnostics, then send after all tiles are finished. This is necessary because p_avt/p_avm are modified on adjacent tiles when using nn_hls > 1. zavt_evd/zavm_evd are then zero on some points when subsequently calculated for these tiles. - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: zavt_evd, zavm_evd + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: zavt_evd, zavm_evd !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile diff --git a/src/OCE/ZDF/zdfgls.F90 b/src/OCE/ZDF/zdfgls.F90 index 89c3369392aacb669dd86ccc99d31b32fc0a0400..7582a721592086832bb71a8d5519033168f295d9 100644 --- a/src/OCE/ZDF/zdfgls.F90 +++ b/src/OCE/ZDF/zdfgls.F90 @@ -47,11 +47,11 @@ MODULE zdfgls PUBLIC gls_rst ! called in zdfphy ! - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hmxl_n !: now mixing length - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zwall !: wall function - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_surf !: Squared surface velocity scale at T-points - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_top !: Squared top velocity scale at T-points - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_bot !: Squared bottom velocity scale at T-points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hmxl_n !: now mixing length + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zwall !: wall function + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_surf !: Squared surface velocity scale at T-points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_top !: Squared top velocity scale at T-points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_bot !: Squared bottom velocity scale at T-points ! !! ** Namelist namzdf_gls ** LOGICAL :: ln_length_lim ! use limit on the dissipation rate under stable stratification (Galperin et al. 1988) @@ -63,54 +63,54 @@ MODULE zdfgls INTEGER :: nn_z0_ice ! Roughness accounting for sea ice INTEGER :: nn_stab_func ! stability functions G88, KC or Canuto (=0/1/2) INTEGER :: nn_clos ! closure 0/1/2/3 MY82/k-eps/k-w/gen - REAL(dp) :: rn_clim_galp ! Holt 2008 value for k-eps: 0.267 - REAL(dp) :: rn_epsmin ! minimum value of dissipation (m2/s3) - REAL(dp) :: rn_emin ! minimum value of TKE (m2/s2) - REAL(dp) :: rn_charn ! Charnock constant for surface breaking waves mixing : 1400. (standard) or 2.e5 (Stacey value) - REAL(dp) :: rn_crban ! Craig and Banner constant for surface breaking waves mixing - REAL(dp) :: rn_hsro ! Minimum surface roughness - REAL(dp) :: rn_hsri ! Ice ocean roughness - REAL(dp) :: rn_frac_hs ! Fraction of wave height as surface roughness (if nn_z0_met > 1) + REAL(wp) :: rn_clim_galp ! Holt 2008 value for k-eps: 0.267 + REAL(wp) :: rn_epsmin ! minimum value of dissipation (m2/s3) + REAL(wp) :: rn_emin ! minimum value of TKE (m2/s2) + REAL(wp) :: rn_charn ! Charnock constant for surface breaking waves mixing : 1400. (standard) or 2.e5 (Stacey value) + REAL(wp) :: rn_crban ! Craig and Banner constant for surface breaking waves mixing + REAL(wp) :: rn_hsro ! Minimum surface roughness + REAL(wp) :: rn_hsri ! Ice ocean roughness + REAL(wp) :: rn_frac_hs ! Fraction of wave height as surface roughness (if nn_z0_met > 1) - REAL(dp) :: rcm_sf = 0.73_wp ! Shear free turbulence parameters - REAL(dp) :: ra_sf = -2.0_wp ! Must be negative -2 < ra_sf < -1 - REAL(dp) :: rl_sf = 0.2_wp ! 0 area constant) - REAL(dp) :: App_max ! Maximum of the convective area + REAL(wp) :: rn_cemf ! entrain of T/S + REAL(wp) :: rn_cwmf ! detrain of T/S + REAL(wp) :: rn_cent ! entrain of the convective mass flux + REAL(wp) :: rn_cdet ! detrain of the convective mass flux + REAL(wp) :: rn_cap ! Factor of computation for convective area (negative => area constant) + REAL(wp) :: App_max ! Maximum of the convective area LOGICAL, PUBLIC, SAVE :: ln_edmfuv !: EDMF flag for velocity ! ! !! * Substitutions # include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" # include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.2 , NEMO Consortium (2018) @@ -95,34 +96,34 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: Kmm, Krhs ! time level indices REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation - REAL(dp), DIMENSION(A2D(nn_hls),jpk,2) :: ztsp ! T/S of the plume - REAL(dp), DIMENSION(A2D(nn_hls),jpk,2) :: ztse ! T/S at W point - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zrwp ! - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zrwp2 ! - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zapp ! - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zedmf ! - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zepsT, zepsW ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: ztsp ! T/S of the plume + REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: ztse ! T/S at W point + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zrwp ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zrwp2 ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zapp ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zedmf ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zepsT, zepsW ! ! - REAL(dp), DIMENSION(A2D(nn_hls)) :: zustar, zustar2 ! - REAL(dp), DIMENSION(A2D(nn_hls)) :: zuws, zvws, zsws, zfnet ! - REAL(dp), DIMENSION(A2D(nn_hls)) :: zfbuo, zrautbm1, zrautb, zraupl - REAL(dp), DIMENSION(A2D(nn_hls)) :: zwpsurf ! - REAL(dp), DIMENSION(A2D(nn_hls)) :: zop0 , zsp0 ! - REAL(dp), DIMENSION(A2D(nn_hls)) :: zrwp_0, zrwp2_0 ! - REAL(dp), DIMENSION(A2D(nn_hls)) :: zapp0 ! - REAL(dp), DIMENSION(A2D(nn_hls)) :: zphp, zph, zphpm1, zphm1, zNHydro - REAL(dp), DIMENSION(A2D(nn_hls)) :: zhcmo ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zustar, zustar2 ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zuws, zvws, zsws, zfnet ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zfbuo, zrautbm1, zrautb, zraupl + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwpsurf ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zop0 , zsp0 ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zrwp_0, zrwp2_0 ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zapp0 ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zphp, zph, zphpm1, zphm1, zNHydro + REAL(wp), DIMENSION(A2D(nn_hls)) :: zhcmo ! ! - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zn2 ! N^2 - REAL(dp), DIMENSION(A2D(nn_hls),2 ) :: zab, zabm1, zabp ! alpha and beta + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zn2 ! N^2 + REAL(wp), DIMENSION(A2D(nn_hls),2 ) :: zab, zabm1, zabp ! alpha and beta REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value - REAL(dp) :: zrho, zrhop - REAL(dp) :: zcnh, znum, zden, zcoef1, zcoef2 - REAL(dp) :: zca, zcb, zcd, zrw, zxl, zcdet, zctre - REAL(dp) :: zaw, zbw, zxw - REAL(dp) :: alpha + REAL(wp) :: zrho, zrhop + REAL(wp) :: zcnh, znum, zden, zcoef1, zcoef2 + REAL(wp) :: zca, zcb, zcd, zrw, zxl, zcdet, zctre + REAL(wp) :: zaw, zbw, zxw + REAL(wp) :: alpha ! INTEGER, INTENT(in ) :: kt ! ocean time-step index ! ! @@ -211,7 +212,7 @@ CONTAINS ! Compute the buoyancy acceleration on T-points at jk-1 zrautbm1(:,:) = zrautb(:,:) - CALL eos( pts (:,:,jk ,:,Kmm) , zrautb(:,:) ) + CALL eos( CASTSP(pts (:,:,jk ,:,Kmm)) , zrautb(:,:) ) CALL eos( ztsp(:,:,jk-1,: ) , zraupl(:,:) ) DO_2D( 0, 0, 0, 0 ) @@ -395,8 +396,9 @@ CONTAINS SUBROUTINE diag_mfc( zdiagi, zdiagd, zdiags, p2dt, Kaa ) - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: zdiagi, zdiagd, zdiags ! inout: tridaig. terms - REAL(dp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: zdiags! inout: tridaig. terms + REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: zdiagi, zdiagd! inout: tridaig. terms + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step INTEGER , INTENT(in ) :: Kaa ! ocean time level indices INTEGER :: ji, jj, jk ! dummy loop arguments @@ -442,7 +444,7 @@ CONTAINS ! INTEGER :: jk ! dummy loop indices INTEGER :: ios ! Local integer output status for namelist read - REAL(dp):: zcr ! local scalar + REAL(wp):: zcr ! local scalar !! NAMELIST/namzdf_mfc/ ln_edmfuv, rn_cemf, rn_cwmf, rn_cent, rn_cdet, rn_cap, App_max !!---------------------------------------------------------- diff --git a/src/OCE/ZDF/zdfmxl.F90 b/src/OCE/ZDF/zdfmxl.F90 index db5f20f74cda6453d93979173a84dd1da08e077f..4005894f0f7fd7867fd5f1d3c77db57c5759bc00 100644 --- a/src/OCE/ZDF/zdfmxl.F90 +++ b/src/OCE/ZDF/zdfmxl.F90 @@ -28,12 +28,12 @@ MODULE zdfmxl PUBLIC zdf_mxl, zdf_mxl_turb, zdf_mxl_alloc ! called by zdfphy.F90 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmln !: number of level in the mixed layer (used by LDF, ZDF, TRD, TOP) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmld !: mixing layer depth (turbocline) [m] (used by TOP) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlp !: mixed layer depth (rho=rho0+zdcrit) [m] (used by LDF) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlpt !: depth of the last T-point inside the mixed layer [m] (used by LDF) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmld !: mixing layer depth (turbocline) [m] (used by TOP) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlp !: mixed layer depth (rho=rho0+zdcrit) [m] (used by LDF) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlpt !: depth of the last T-point inside the mixed layer [m] (used by LDF) - REAL(dp), PUBLIC :: rho_c = 0.01_wp !: density criterion for mixed layer depth - REAL(dp), PUBLIC :: avt_c = 5.e-4_wp ! Kz criterion for the turbocline depth + REAL(wp), PUBLIC :: rho_c = 0.01_wp !: density criterion for mixed layer depth + REAL(wp), PUBLIC :: avt_c = 5.e-4_wp ! Kz criterion for the turbocline depth !! * Substitutions # include "do_loop_substitute.h90" @@ -77,7 +77,7 @@ CONTAINS ! INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: iik, ikt ! local integer - REAL(dp) :: zN2_c ! local scalar + REAL(wp) :: zN2_c ! local scalar !!---------------------------------------------------------------------- ! IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile @@ -115,7 +115,7 @@ CONTAINS ENDIF ENDIF ! - !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=REAL(nmln,dp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ' ) + ! IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ' ) ! END SUBROUTINE zdf_mxl @@ -162,4 +162,4 @@ CONTAINS ! END SUBROUTINE zdf_mxl_turb !!====================================================================== -END MODULE zdfmxl +END MODULE zdfmxl \ No newline at end of file diff --git a/src/OCE/ZDF/zdfosm.F90 b/src/OCE/ZDF/zdfosm.F90 index 1c7b2b681ffbcae930b8c21fb6bd837609b463d7..65094865081cd98963311afd6222968c8c8f47a5 100644 --- a/src/OCE/ZDF/zdfosm.F90 +++ b/src/OCE/ZDF/zdfosm.F90 @@ -100,15 +100,15 @@ MODULE zdfosm LOGICAL, PUBLIC :: ln_osm_mle !: Flag to activate the Mixed Layer Eddy (MLE) ! ! parameterisation, needed by tra_mle_init in ! ! tramle.F90 - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamu !: Non-local u-momentum flux - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamv !: Non-local v-momentum flux - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamt !: Non-local temperature flux (gamma/o) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghams !: Non-local salinity flux (gamma/o) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbl !: Boundary layer depth - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hml !: ML depth - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmle !: Depth of layer affexted by mixed layer eddies in Fox-Kemper parametrization - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dbdx_mle !: Zonal buoyancy gradient in ML - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dbdy_mle !: Meridional buoyancy gradient in ML + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamu !: Non-local u-momentum flux + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamv !: Non-local v-momentum flux + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamt !: Non-local temperature flux (gamma/o) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghams !: Non-local salinity flux (gamma/o) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbl !: Boundary layer depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hml !: ML depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmle !: Depth of layer affexted by mixed layer eddies in Fox-Kemper parametrization + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dbdx_mle !: Zonal buoyancy gradient in ML + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dbdy_mle !: Meridional buoyancy gradient in ML INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mld_prof !: Level of base of MLE layer INTERFACE zdf_osm_velocity_rotation @@ -127,9 +127,9 @@ MODULE zdfosm MODULE PROCEDURE zdf_osm_iomput_3d END INTERFACE - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: etmean ! Averaging operator for avt - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dh ! Depth of pycnocline - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_ft ! Inverse of the modified Coriolis parameter at t-pts + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: etmean ! Averaging operator for avt + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dh ! Depth of pycnocline + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_ft ! Inverse of the modified Coriolis parameter at t-pts ! Layer indices INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nbld ! Level of boundary layer base INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmld ! Level of mixed-layer depth (pycnocline top) @@ -146,99 +146,99 @@ MODULE zdfosm LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_flux ! Surface flux extends below OSBL into MLE layer LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_mle ! MLE layer increases in hickness. ! Scales - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swth0 ! Surface heat flux (Kinematic) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sws0 ! Surface freshwater flux - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swb0 ! Surface buoyancy flux - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: suw0 ! Surface u-momentum flux - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sustar ! Friction velocity - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: scos_wind ! Cos angle of surface stress - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssin_wind ! Sin angle of surface stress - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swthav ! Heat flux - bl average - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swsav ! Freshwater flux - bl average - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swbav ! Buoyancy flux - bl average - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sustke ! Surface Stokes drift - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dstokes ! Penetration depth of the Stokes drift - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swstrl ! Langmuir velocity scale - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swstrc ! Convective velocity scale - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sla ! Trubulent Langmuir number - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: svstr ! Velocity scale that tends to sustar for large Langmuir number - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: shol ! Stability parameter for boundary layer + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swth0 ! Surface heat flux (Kinematic) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sws0 ! Surface freshwater flux + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swb0 ! Surface buoyancy flux + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: suw0 ! Surface u-momentum flux + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sustar ! Friction velocity + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: scos_wind ! Cos angle of surface stress + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssin_wind ! Sin angle of surface stress + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swthav ! Heat flux - bl average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swsav ! Freshwater flux - bl average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swbav ! Buoyancy flux - bl average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sustke ! Surface Stokes drift + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dstokes ! Penetration depth of the Stokes drift + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swstrl ! Langmuir velocity scale + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swstrc ! Convective velocity scale + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sla ! Trubulent Langmuir number + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: svstr ! Velocity scale that tends to sustar for large Langmuir number + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: shol ! Stability parameter for boundary layer ! Layer averages: BL - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_bl ! Temperature average - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_bl ! Salinity average - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_bl ! Velocity average (u) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_bl ! Velocity average (v) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_bl ! Buoyancy average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_bl ! Temperature average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_bl ! Salinity average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_bl ! Velocity average (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_bl ! Velocity average (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_bl ! Buoyancy average ! Difference between layer average and parameter at the base of the layer: BL - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dt_bl ! Temperature difference - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_ds_bl ! Salinity difference - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_du_bl ! Velocity difference (u) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dv_bl ! Velocity difference (v) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_db_bl ! Buoyancy difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dt_bl ! Temperature difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_ds_bl ! Salinity difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_du_bl ! Velocity difference (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dv_bl ! Velocity difference (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_db_bl ! Buoyancy difference ! Layer averages: ML - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_ml ! Temperature average - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_ml ! Salinity average - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_ml ! Velocity average (u) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_ml ! Velocity average (v) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_ml ! Buoyancy average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_ml ! Temperature average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_ml ! Salinity average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_ml ! Velocity average (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_ml ! Velocity average (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_ml ! Buoyancy average ! Difference between layer average and parameter at the base of the layer: ML - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dt_ml ! Temperature difference - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_ds_ml ! Salinity difference - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_du_ml ! Velocity difference (u) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dv_ml ! Velocity difference (v) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_db_ml ! Buoyancy difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dt_ml ! Temperature difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_ds_ml ! Salinity difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_du_ml ! Velocity difference (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dv_ml ! Velocity difference (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_db_ml ! Buoyancy difference ! Layer averages: MLE - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_mle ! Temperature average - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_mle ! Salinity average - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_mle ! Velocity average (u) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_mle ! Velocity average (v) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_mle ! Buoyancy average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_mle ! Temperature average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_mle ! Salinity average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_mle ! Velocity average (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_mle ! Velocity average (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_mle ! Buoyancy average ! Diagnostic output - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: osmdia2d ! Auxiliary array for diagnostic output - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: osmdia3d ! Auxiliary array for diagnostic output + REAL(WP), ALLOCATABLE, SAVE, DIMENSION(:,:) :: osmdia2d ! Auxiliary array for diagnostic output + REAL(WP), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: osmdia3d ! Auxiliary array for diagnostic output LOGICAL :: ln_dia_pyc_scl = .FALSE. ! Output of pycnocline scalar-gradient profiles LOGICAL :: ln_dia_pyc_shr = .FALSE. ! Output of pycnocline velocity-shear profiles ! !!* namelist namzdf_osm * LOGICAL :: ln_use_osm_la ! Use namelist rn_osm_la - REAL(dp) :: rn_osm_la ! Turbulent Langmuir number - REAL(dp) :: rn_osm_dstokes ! Depth scale of Stokes drift - REAL(dp) :: rn_zdfosm_adjust_sd = 1.0_wp ! Factor to reduce Stokes drift by - REAL(dp) :: rn_osm_hblfrac = 0.1_wp ! For nn_osm_wave = 3/4 specify fraction in top of hbl + REAL(wp) :: rn_osm_la ! Turbulent Langmuir number + REAL(wp) :: rn_osm_dstokes ! Depth scale of Stokes drift + REAL(wp) :: rn_zdfosm_adjust_sd = 1.0_wp ! Factor to reduce Stokes drift by + REAL(wp) :: rn_osm_hblfrac = 0.1_wp ! For nn_osm_wave = 3/4 specify fraction in top of hbl LOGICAL :: ln_zdfosm_ice_shelter ! Flag to activate ice sheltering - REAL(dp) :: rn_osm_hbl0 = 10.0_wp ! Initial value of hbl for 1D runs + REAL(wp) :: rn_osm_hbl0 = 10.0_wp ! Initial value of hbl for 1D runs INTEGER :: nn_ave ! = 0/1 flag for horizontal average on avt INTEGER :: nn_osm_wave = 0 ! = 0/1/2 flag for getting stokes drift from La# / PM wind-waves/Inputs into ! ! sbcwave INTEGER :: nn_osm_SD_reduce ! = 0/1/2 flag for getting effective stokes drift from surface value LOGICAL :: ln_dia_osm ! Use namelist rn_osm_la LOGICAL :: ln_kpprimix = .TRUE. ! Shear instability mixing - REAL(dp) :: rn_riinfty = 0.7_wp ! Local Richardson Number limit for shear instability - REAL(dp) :: rn_difri = 0.005_wp ! Maximum shear mixing at Rig = 0 (m2/s) + REAL(wp) :: rn_riinfty = 0.7_wp ! Local Richardson Number limit for shear instability + REAL(wp) :: rn_difri = 0.005_wp ! Maximum shear mixing at Rig = 0 (m2/s) LOGICAL :: ln_convmix = .TRUE. ! Convective instability mixing - REAL(dp) :: rn_difconv = 1.0_wp ! Diffusivity when unstable below BL (m2/s) + REAL(wp) :: rn_difconv = 1.0_wp ! Diffusivity when unstable below BL (m2/s) ! OSMOSIS mixed layer eddy parametrization constants INTEGER :: nn_osm_mle ! = 0/1 flag for horizontal average on avt - REAL(dp) :: rn_osm_mle_ce ! MLE coefficient + REAL(wp) :: rn_osm_mle_ce ! MLE coefficient ! Parameters used in nn_osm_mle = 0 case - REAL(dp) :: rn_osm_mle_lf ! Typical scale of mixed layer front - REAL(dp) :: rn_osm_mle_time ! Time scale for mixing momentum across the mixed layer + REAL(wp) :: rn_osm_mle_lf ! Typical scale of mixed layer front + REAL(wp) :: rn_osm_mle_time ! Time scale for mixing momentum across the mixed layer ! Parameters used in nn_osm_mle = 1 case - REAL(dp) :: rn_osm_mle_lat ! Reference latitude for a 5 km scale of ML front + REAL(wp) :: rn_osm_mle_lat ! Reference latitude for a 5 km scale of ML front LOGICAL :: ln_osm_hmle_limit ! If true arbitrarily restrict hmle to rn_osm_hmle_limit*zmld - REAL(dp) :: rn_osm_hmle_limit ! If ln_osm_hmle_limit true arbitrarily restrict hmle to rn_osm_hmle_limit*zmld - REAL(dp) :: rn_osm_mle_rho_c ! Density criterion for definition of MLD used by FK - REAL(dp) :: rb_c ! ML buoyancy criteria = g rho_c /rho0 where rho_c is defined in zdfmld - REAL(dp) :: rc_f ! MLE coefficient (= rn_ce / (5 km * fo) ) in nn_osm_mle=1 case - REAL(dp) :: rn_osm_mle_thresh ! Threshold buoyancy for deepening of MLE layer below OSBL base - REAL(dp) :: rn_osm_bl_thresh ! Threshold buoyancy for deepening of OSBL base - REAL(dp) :: rn_osm_mle_tau ! Adjustment timescale for MLE + REAL(wp) :: rn_osm_hmle_limit ! If ln_osm_hmle_limit true arbitrarily restrict hmle to rn_osm_hmle_limit*zmld + REAL(wp) :: rn_osm_mle_rho_c ! Density criterion for definition of MLD used by FK + REAL(wp) :: rb_c ! ML buoyancy criteria = g rho_c /rho0 where rho_c is defined in zdfmld + REAL(wp) :: rc_f ! MLE coefficient (= rn_ce / (5 km * fo) ) in nn_osm_mle=1 case + REAL(wp) :: rn_osm_mle_thresh ! Threshold buoyancy for deepening of MLE layer below OSBL base + REAL(wp) :: rn_osm_bl_thresh ! Threshold buoyancy for deepening of OSBL base + REAL(wp) :: rn_osm_mle_tau ! Adjustment timescale for MLE ! General constants - REAL(dp) :: epsln = 1.0e-20_wp ! A small positive number to ensure no div by zero - REAL(dp) :: depth_tol = 1.0e-6_wp ! A small-ish positive number to give a hbl slightly shallower than gdepw - REAL(dp) :: pthird = 1.0_wp/3.0_wp ! 1/3 - REAL(dp) :: p2third = 2.0_wp/3.0_wp ! 2/3 + REAL(wp) :: epsln = 1.0e-20_wp ! A small positive number to ensure no div by zero + REAL(wp) :: depth_tol = 1.0e-6_wp ! A small-ish positive number to give a hbl slightly shallower than gdepw + REAL(wp) :: pthird = 1.0_wp/3.0_wp ! 1/3 + REAL(wp) :: p2third = 2.0_wp/3.0_wp ! 2/3 !! * Substitutions # include "do_loop_substitute.h90" @@ -351,58 +351,58 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! Ocean time step INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! Ocean time level indices - REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: p_avm, p_avt ! Momentum and tracer Kz (w-points) + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm, p_avt ! Momentum and tracer Kz (w-points) !! INTEGER :: ji, jj, jk, jl, jm, jkflt ! Dummy loop indices !! - REAL(dp) :: zthermal, zbeta - REAL(dp) :: zesh2, zri, zfri ! Interior Richardson mixing + REAL(wp) :: zthermal, zbeta + REAL(wp) :: zesh2, zri, zfri ! Interior Richardson mixing !! Scales - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zrad0 ! Surface solar temperature flux (deg m/s) - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zradh ! Radiative flux at bl base (Buoyancy units) - REAL(dp) :: zradav ! Radiative flux, bl average (Buoyancy Units) - REAL(dp) :: zvw0 ! Surface v-momentum flux - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zwb0tot ! Total surface buoyancy flux including insolation - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zwb_ent ! Buoyancy entrainment flux - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zwb_min - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zwb_fk_b ! MLE buoyancy flux averaged over OSBL - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zwb_fk ! Max MLE buoyancy flux - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zdiff_mle ! Extra MLE vertical diff - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zvel_mle ! Velocity scale for dhdt with stable ML and FK + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zrad0 ! Surface solar temperature flux (deg m/s) + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zradh ! Radiative flux at bl base (Buoyancy units) + REAL(wp) :: zradav ! Radiative flux, bl average (Buoyancy Units) + REAL(wp) :: zvw0 ! Surface v-momentum flux + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb0tot ! Total surface buoyancy flux including insolation + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_min + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_fk_b ! MLE buoyancy flux averaged over OSBL + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_fk ! Max MLE buoyancy flux + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdiff_mle ! Extra MLE vertical diff + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zvel_mle ! Velocity scale for dhdt with stable ML and FK !! Mixed-layer variables INTEGER, DIMENSION(A2D(nn_hls-1)) :: jk_nlev ! Number of levels INTEGER, DIMENSION(A2D(nn_hls-1)) :: jk_ext ! Offset for external level !! - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zhbl ! BL depth - grid - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zhml ! ML depth - grid + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhbl ! BL depth - grid + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhml ! ML depth - grid !! - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zhmle ! MLE depth - grid - REAL(dp), DIMENSION(A2D(nn_hls)) :: zmld ! ML depth on grid + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhmle ! MLE depth - grid + REAL(wp), DIMENSION(A2D(nn_hls)) :: zmld ! ML depth on grid !! - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zdh ! Pycnocline depth - grid - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zdhdt ! BL depth tendency - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zdtdz_bl_ext, zdsdz_bl_ext ! External temperature/salinity gradients - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zdbdz_bl_ext ! External buoyancy gradients - REAL(dp), DIMENSION(A2D(nn_hls)) :: zdtdx, zdtdy, zdsdx, zdsdy ! Horizontal gradients for Fox-Kemper parametrization + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdh ! Pycnocline depth - grid + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdhdt ! BL depth tendency + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdtdz_bl_ext, zdsdz_bl_ext ! External temperature/salinity gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(A2D(nn_hls)) :: zdtdx, zdtdy, zdsdx, zdsdy ! Horizontal gradients for Fox-Kemper parametrization !! - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zdbds_mle ! Magnitude of horizontal buoyancy gradient + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdbds_mle ! Magnitude of horizontal buoyancy gradient !! Flux-gradient relationship variables - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zshear ! Shear production + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zshear ! Shear production !! - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zhbl_t ! Holds boundary layer depth updated by full timestep + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhbl_t ! Holds boundary layer depth updated by full timestep !! For calculating Ri#-dependent mixing - REAL(dp), DIMENSION(A2D(nn_hls)) :: z2du ! u-shear^2 - REAL(dp), DIMENSION(A2D(nn_hls)) :: z2dv ! v-shear^2 - REAL(dp) :: zrimix ! Spatial form of ri#-induced diffusion + REAL(wp), DIMENSION(A2D(nn_hls)) :: z2du ! u-shear^2 + REAL(wp), DIMENSION(A2D(nn_hls)) :: z2dv ! v-shear^2 + REAL(wp) :: zrimix ! Spatial form of ri#-induced diffusion !! Temporary variables - REAL(dp) :: znd ! Temporary non-dimensional depth - REAL(dp) :: zz0, zz1, zfac - REAL(dp) :: zus_x, zus_y ! Temporary Stokes drift - REAL(dp), DIMENSION(A2D(nn_hls-1),jpk) :: zviscos ! Viscosity - REAL(dp), DIMENSION(A2D(nn_hls-1),jpk) :: zdiffut ! t-diffusivity - REAL(dp) :: zabsstke - REAL(dp) :: zsqrtpi, z_two_thirds, zthickness - REAL(dp) :: z2k_times_thickness, zsqrt_depth, zexp_depth, zf, zexperfc + REAL(wp) :: znd ! Temporary non-dimensional depth + REAL(wp) :: zz0, zz1, zfac + REAL(wp) :: zus_x, zus_y ! Temporary Stokes drift + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk) :: zviscos ! Viscosity + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk) :: zdiffut ! t-diffusivity + REAL(wp) :: zabsstke + REAL(wp) :: zsqrtpi, z_two_thirds, zthickness + REAL(wp) :: z2k_times_thickness, zsqrt_depth, zexp_depth, zf, zexperfc !! For debugging REAL(wp), PARAMETER :: pp_large = -1e10_wp !!---------------------------------------------------------------------- @@ -940,7 +940,7 @@ CONTAINS CALL zdf_osm_iomput( "zws0", tmask(A2D(0),1) * sws0(A2D(0)) ) ! CALL zdf_osm_iomput( "zwb0", tmask(A2D(0),1) * swb0(A2D(0)) ) ! CALL zdf_osm_iomput( "zwbav", tmask(A2D(0),1) * swth0(A2D(0)) ) ! Upward BL-avged turb buoyancy flux - CALL zdf_osm_iomput( "ibld", tmask(A2D(0),1) * REAL(nbld(A2D(0)),dp) ) ! Boundary-layer max k + CALL zdf_osm_iomput( "ibld", tmask(A2D(0),1) * nbld(A2D(0)) ) ! Boundary-layer max k CALL zdf_osm_iomput( "zdt_bl", tmask(A2D(0),1) * av_dt_bl(A2D(0)) ) ! dt at ml base CALL zdf_osm_iomput( "zds_bl", tmask(A2D(0),1) * av_ds_bl(A2D(0)) ) ! ds at ml base CALL zdf_osm_iomput( "zdb_bl", tmask(A2D(0),1) * av_db_bl(A2D(0)) ) ! db at ml base @@ -964,11 +964,11 @@ CONTAINS & sustar(A2D(0))**2 * sustke(A2D(0)) ) CALL zdf_osm_iomput( "zhbl", tmask(A2D(0),1) * zhbl(A2D(0)) ) ! BL depth internal to zdf_osm routine CALL zdf_osm_iomput( "zhml", tmask(A2D(0),1) * zhml(A2D(0)) ) ! ML depth internal to zdf_osm routine - CALL zdf_osm_iomput( "imld", tmask(A2D(0),1) * REAL(nmld(A2D(0)),dp) ) ! Index for ML depth internal to zdf_osm + CALL zdf_osm_iomput( "imld", tmask(A2D(0),1) * nmld(A2D(0)) ) ! Index for ML depth internal to zdf_osm ! ! routine - CALL zdf_osm_iomput( "jp_ext", tmask(A2D(0),1) * REAL(jk_ext(A2D(0)),dp) ) ! =1 if pycnocline resolved internal to + CALL zdf_osm_iomput( "jp_ext", tmask(A2D(0),1) * jk_ext(A2D(0)) ) ! =1 if pycnocline resolved internal to ! ! zdf_osm routine - CALL zdf_osm_iomput( "j_ddh", tmask(A2D(0),1) * REAL(n_ddh(A2D(0)),dp) ) ! Index forpyc thicknessh internal to + CALL zdf_osm_iomput( "j_ddh", tmask(A2D(0),1) * n_ddh(A2D(0)) ) ! Index forpyc thicknessh internal to ! ! zdf_osm routine CALL zdf_osm_iomput( "zshear", tmask(A2D(0),1) * zshear(A2D(0)) ) ! Shear production of TKE internal to ! ! zdf_osm routine @@ -980,7 +980,7 @@ CONTAINS CALL zdf_osm_iomput( "zmld", tmask(A2D(0),1) * zmld(A2D(0)) ) ! FK target layer depth CALL zdf_osm_iomput( "zwb_fk", tmask(A2D(0),1) * zwb_fk(A2D(0)) ) ! FK b flux CALL zdf_osm_iomput( "zwb_fk_b", tmask(A2D(0),1) * zwb_fk_b(A2D(0)) ) ! FK b flux averaged over ML - CALL zdf_osm_iomput( "mld_prof", tmask(A2D(0),1) * REAL(mld_prof(A2D(0)),dp) ) ! FK layer max k + CALL zdf_osm_iomput( "mld_prof", tmask(A2D(0),1) * mld_prof(A2D(0)) ) ! FK layer max k CALL zdf_osm_iomput( "zdtdx", umask(A2D(0),1) * zdtdx(A2D(0)) ) ! FK dtdx at u-pt CALL zdf_osm_iomput( "zdtdy", vmask(A2D(0),1) * zdtdy(A2D(0)) ) ! FK dtdy at v-pt CALL zdf_osm_iomput( "zdsdx", umask(A2D(0),1) * zdsdx(A2D(0)) ) ! FK dtdx at u-pt @@ -995,8 +995,8 @@ CONTAINS ! v grids IF ( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Finalise ghamu, ghamv, hbl, and hmle only after full domain has been ! ! processed - IF ( nn_hls == 1 ) CALL lbc_lnk( 'zdfosm', ghamu, 'W', 1.0_dp, & - & ghamv, 'W', 1.0_dp ) + IF ( nn_hls == 1 ) CALL lbc_lnk( 'zdfosm', ghamu, 'W', 1.0_wp, & + & ghamv, 'W', 1.0_wp ) DO jk = 2, jpkm1 DO jj = Njs0, Nje0 DO ji = Nis0, Nie0 @@ -1010,8 +1010,8 @@ CONTAINS END DO END DO ! Lateral boundary conditions on final outputs for hbl, on T-grid (sign unchanged) - CALL lbc_lnk( 'zdfosm', hbl, 'T', 1.0_dp, & - & hmle, 'T', 1.0_dp ) + CALL lbc_lnk( 'zdfosm', hbl, 'T', 1.0_wp, & + & hmle, 'T', 1.0_wp ) ! CALL zdf_osm_iomput( "ghamt", tmask * ghamt ) ! CALL zdf_osm_iomput( "ghams", tmask * ghams ) ! @@ -1039,20 +1039,20 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kbb, Kmm ! Ocean time-level indices INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: knlev ! Number of levels to average over. - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pt, ps ! Average temperature and salinity - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pb ! Average buoyancy - REAL(dp), DIMENSION(jpi,jpj), INTENT( out) :: pu, pv ! Average current components + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pt, ps ! Average temperature and salinity + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pb ! Average buoyancy + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pu, pv ! Average current components INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ), OPTIONAL :: kp_ext ! External-level offsets - REAL(dp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdt ! Difference between average temperature, - REAL(dp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pds ! salinity, - REAL(dp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdb ! buoyancy, and - REAL(dp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdu, pdv ! velocity components and the OSBL + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdt ! Difference between average temperature, + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pds ! salinity, + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdb ! buoyancy, and + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdu, pdv ! velocity components and the OSBL !! INTEGER :: jk, jkflt, jkmax, ji, jj ! Loop indices INTEGER :: ibld_ext ! External-layer index - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zthick ! Layer thickness - REAL(dp) :: zthermal ! Thermal expansion coefficient - REAL(dp) :: zbeta ! Haline contraction coefficient + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zthick ! Layer thickness + REAL(wp) :: zthermal ! Thermal expansion coefficient + REAL(wp) :: zbeta ! Haline contraction coefficient !!---------------------------------------------------------------------- ! ! Averages over depth of boundary layer @@ -1142,11 +1142,11 @@ CONTAINS !! ssin_wind !! !!---------------------------------------------------------------------- - REAL(dp), INTENT(inout), DIMENSION(jpi,jpj) :: pu, pv ! Components of current + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: pu, pv ! Components of current LOGICAL, OPTIONAL, INTENT(in ) :: fwd ! Forward (default) or reverse rotation !! INTEGER :: ji, jj ! Loop indices - REAL(dp) :: ztmp, zfwd ! Auxiliary variables + REAL(wp) :: ztmp, zfwd ! Auxiliary variables !!---------------------------------------------------------------------- ! zfwd = 1.0_wp @@ -1173,13 +1173,13 @@ CONTAINS !! the depth index specified in array knlev !! !!---------------------------------------------------------------------- - REAL(dp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pu, pv ! Components of current + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pu, pv ! Components of current LOGICAL, OPTIONAL, INTENT(in ) :: fwd ! Forward (default) or reverse rotation INTEGER, OPTIONAL, INTENT(in ) :: ktop ! Minimum depth index INTEGER, OPTIONAL, INTENT(in ), DIMENSION(A2D(nn_hls-1)) :: knlev ! Array of maximum depth indices !! INTEGER :: ji, jj, jk, jktop, jkmax ! Loop indices - REAL(dp) :: ztmp, zfwd ! Auxiliary variables + REAL(wp) :: ztmp, zfwd ! Auxiliary variables LOGICAL :: llkbot ! Auxiliary variable !!---------------------------------------------------------------------- ! @@ -1221,19 +1221,19 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_ent ! Buoyancy fluxes at base - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_min ! of well-mixed layer - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pshear ! Production of TKE due to shear across the pycnocline - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_ent ! Buoyancy fluxes at base + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_min ! of well-mixed layer + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pshear ! Production of TKE due to shear across the pycnocline + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth !! INTEGER :: jj, ji ! Loop indices !! - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zekman - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zri_p, zri_b ! Richardson numbers - REAL(dp) :: zshear_u, zshear_v, zwb_shr - REAL(dp) :: zwcor, zrf_conv, zrf_shear, zrf_langmuir, zr_stokes + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zekman + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zri_p, zri_b ! Richardson numbers + REAL(wp) :: zshear_u, zshear_v, zwb_shr + REAL(wp) :: zwcor, zrf_conv, zrf_shear, zrf_langmuir, zr_stokes !! REAL(wp), PARAMETER :: pp_a_shr = 0.4_wp, pp_b_shr = 6.5_wp, pp_a_wb_s = 0.8_wp REAL(wp), PARAMETER :: pp_alpha_c = 0.2_wp, pp_alpha_lc = 0.03_wp @@ -1385,11 +1385,11 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: kbase ! OSBL base layer index - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdtdz, pdsdz ! External gradients of temperature, salinity - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdbdz ! and buoyancy + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdtdz, pdsdz ! External gradients of temperature, salinity + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdbdz ! and buoyancy !! INTEGER :: ji, jj, jkb, jkb1 - REAL(dp) :: zthermal, zbeta + REAL(wp) :: zthermal, zbeta !! REAL(wp), PARAMETER :: pp_large = -1e10_wp !!---------------------------------------------------------------------- @@ -1428,19 +1428,19 @@ CONTAINS !! ** Method : !! !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdhdt ! Rate of change of hbl - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_min - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk ! Max MLE buoyancy flux - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pvel_mle ! Vvelocity scale for dhdt with stable ML and FK + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdhdt ! Rate of change of hbl + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_min + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk ! Max MLE buoyancy flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pvel_mle ! Vvelocity scale for dhdt with stable ML and FK !! INTEGER :: jj, ji - REAL(dp) :: zgamma_b_nd, zgamma_dh_nd, zpert, zpsi, zari - REAL(dp) :: zvel_max, zddhdt + REAL(wp) :: zgamma_b_nd, zgamma_dh_nd, zpert, zpsi, zari + REAL(wp) :: zvel_max, zddhdt !! REAL(wp), PARAMETER :: pp_alpha_b = 0.3_wp REAL(wp), PARAMETER :: pp_ddh = 2.5_wp, pp_ddh_2 = 3.5_wp ! Also in pycnocline_depth @@ -1598,15 +1598,15 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdhdt ! Rates of change of hbl - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phbl ! BL depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl_t ! BL depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdhdt ! Rates of change of hbl + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl_t ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL !! INTEGER :: jk, jj, ji, jm - REAL(dp) :: zhbl_s, zvel_max, zdb - REAL(dp) :: zthermal, zbeta + REAL(wp) :: zhbl_s, zvel_max, zdb + REAL(wp) :: zthermal, zbeta !!---------------------------------------------------------------------- ! DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) @@ -1698,18 +1698,18 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdh ! Pycnocline thickness - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phml ! ML depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdh ! Pycnocline thickness + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phml ! ML depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL !! INTEGER :: jj, ji INTEGER :: inhml - REAL(dp) :: zari, ztau, zdh_ref, zddhdt, zvel_max - REAL(dp) :: ztmp ! Auxiliary variable + REAL(wp) :: zari, ztau, zdh_ref, zddhdt, zvel_max + REAL(wp) :: ztmp ! Auxiliary variable !! REAL(wp), PARAMETER :: pp_ddh = 2.5_wp, pp_ddh_2 = 3.5_wp ! Also in pycnocline_depth !!---------------------------------------------------------------------- @@ -1859,19 +1859,19 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: kp_ext ! External-level offsets - REAL(dp), DIMENSION(A2D(nn_hls-1),jpk), INTENT( out) :: pdbdz ! Gradients in the pycnocline - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: palpha - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline thickness - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! Rates of change of hbl + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT( out) :: pdbdz ! Gradients in the pycnocline + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: palpha + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline thickness + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! Rates of change of hbl !! INTEGER :: jk, jj, ji - REAL(dp) :: zbgrad - REAL(dp) :: zgamma_b_nd, znd - REAL(dp) :: zzeta_m - REAL(dp) :: ztmp ! Auxiliary variable + REAL(wp) :: zbgrad + REAL(wp) :: zgamma_b_nd, znd + REAL(wp) :: zzeta_m + REAL(wp) :: ztmp ! Auxiliary variable !! REAL(wp), PARAMETER :: pp_gamma_b = 2.25_wp REAL(wp), PARAMETER :: pp_large = -1e10_wp @@ -1969,29 +1969,29 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kbb, Kmm ! Ocean time-level indices - REAL(dp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(inout) :: pdiffut ! t-diffusivity - REAL(dp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(inout) :: pviscos ! Viscosity - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pshear ! Shear production - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_min + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(inout) :: pdiffut ! t-diffusivity + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(inout) :: pviscos ! Viscosity + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pshear ! Shear production + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_min !! INTEGER :: ji, jj, jk ! Loop indices !! Scales used to calculate eddy diffusivity and viscosity profiles - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zdifml_sc, zvisml_sc - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zdifpyc_n_sc, zdifpyc_s_sc - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zvispyc_n_sc, zvispyc_s_sc - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zbeta_d_sc, zbeta_v_sc - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zb_coup, zc_coup_vis, zc_coup_dif - !! - REAL(dp) :: zvel_sc_pyc, zvel_sc_ml, zstab_fac, zz_b - REAL(dp) :: za_cubic, zb_d_cubic, zc_d_cubic, zd_d_cubic, zb_v_cubic, zc_v_cubic, zd_v_cubic - - REAL(dp) :: zznd_ml, zznd_pyc, ztmp - REAL(dp) :: zmsku, zmskv + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdifml_sc, zvisml_sc + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdifpyc_n_sc, zdifpyc_s_sc + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zvispyc_n_sc, zvispyc_s_sc + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zbeta_d_sc, zbeta_v_sc + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zb_coup, zc_coup_vis, zc_coup_dif + !! + REAL(wp) :: zvel_sc_pyc, zvel_sc_ml, zstab_fac, zz_b + REAL(wp) :: za_cubic, zb_d_cubic, zc_d_cubic, zd_d_cubic, & ! Coefficients in cubic polynomial specifying diffusivity + & zb_v_cubic, zc_v_cubic, zd_v_cubic ! and viscosity in pycnocline + REAL(wp) :: zznd_ml, zznd_pyc, ztmp + REAL(wp) :: zmsku, zmskv !! REAL(wp), PARAMETER :: pp_dif_ml = 0.8_wp, pp_vis_ml = 0.375_wp REAL(wp), PARAMETER :: pp_dif_pyc = 0.15_wp, pp_vis_pyc = 0.142_wp @@ -2165,48 +2165,48 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kmm ! Time-level index INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: kp_ext ! Offset for external level - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pshear ! Shear production - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdtdz_bl_ext ! External temperature gradients - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdsdz_bl_ext ! External salinity gradients - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients - REAL(dp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(in ) :: pdiffut ! t-diffusivity - REAL(dp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(in ) :: pviscos ! Viscosity - !! - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zalpha_pyc ! - REAL(dp), DIMENSION(A2D(nn_hls-1),jpk) :: zdbdz_pyc ! Parametrised gradient of buoyancy in the pycnocline - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: z3ddz_pyc_1, z3ddz_pyc_2 ! Pycnocline gradient/shear profiles + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pshear ! Shear production + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdtdz_bl_ext ! External temperature gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdsdz_bl_ext ! External salinity gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(in ) :: pdiffut ! t-diffusivity + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(in ) :: pviscos ! Viscosity + !! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zalpha_pyc ! + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk) :: zdbdz_pyc ! Parametrised gradient of buoyancy in the pycnocline + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: z3ddz_pyc_1, z3ddz_pyc_2 ! Pycnocline gradient/shear profiles !! INTEGER :: ji, jj, jk, jkm_bld, jkf_mld, jkm_mld ! Loop indices INTEGER :: istat ! Memory allocation status - REAL(dp) :: zznd_d, zznd_ml, zznd_pyc, znd ! Temporary non-dimensional depths - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zsc_wth_1,zsc_ws_1 ! Temporary scales - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zsc_uw_1, zsc_uw_2 ! Temporary scales - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zsc_vw_1, zsc_vw_2 ! Temporary scales - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: ztau_sc_u ! Dissipation timescale at base of WML - REAL(dp) :: zbuoy_pyc_sc, zdelta_pyc ! - REAL(dp) :: zl_c,zl_l,zl_eps ! Used to calculate turbulence length scale - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: za_cubic, zb_cubic ! Coefficients in cubic polynomial specifying - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zc_cubic, zd_cubic ! diffusivity in pycnocline - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zwt_pyc_sc_1, zws_pyc_sc_1 ! - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zzeta_pyc ! - REAL(dp) :: zomega, zvw_max ! - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zuw_bse,zvw_bse ! Momentum, heat, and salinity fluxes - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zwth_ent,zws_ent ! at the top of the pycnocline - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: zsc_wth_pyc, zsc_ws_pyc ! Scales for pycnocline transport term - REAL(dp) :: ztmp ! - REAL(dp) :: ztgrad, zsgrad, zbgrad ! Variables used to calculate pycnocline + REAL(wp) :: zznd_d, zznd_ml, zznd_pyc, znd ! Temporary non-dimensional depths + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_wth_1,zsc_ws_1 ! Temporary scales + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_uw_1, zsc_uw_2 ! Temporary scales + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_vw_1, zsc_vw_2 ! Temporary scales + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: ztau_sc_u ! Dissipation timescale at base of WML + REAL(wp) :: zbuoy_pyc_sc, zdelta_pyc ! + REAL(wp) :: zl_c,zl_l,zl_eps ! Used to calculate turbulence length scale + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: za_cubic, zb_cubic ! Coefficients in cubic polynomial specifying + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zc_cubic, zd_cubic ! diffusivity in pycnocline + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwt_pyc_sc_1, zws_pyc_sc_1 ! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zzeta_pyc ! + REAL(wp) :: zomega, zvw_max ! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zuw_bse,zvw_bse ! Momentum, heat, and salinity fluxes + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwth_ent,zws_ent ! at the top of the pycnocline + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_wth_pyc, zsc_ws_pyc ! Scales for pycnocline transport term + REAL(wp) :: ztmp ! + REAL(wp) :: ztgrad, zsgrad, zbgrad ! Variables used to calculate pycnocline !! ! gradients - REAL(dp) :: zugrad, zvgrad ! Variables for calculating pycnocline shear - REAL(dp) :: zdtdz_pyc ! Parametrized gradient of temperature in + REAL(wp) :: zugrad, zvgrad ! Variables for calculating pycnocline shear + REAL(wp) :: zdtdz_pyc ! Parametrized gradient of temperature in !! ! pycnocline - REAL(dp) :: zdsdz_pyc ! Parametrised gradient of salinity in + REAL(wp) :: zdsdz_pyc ! Parametrised gradient of salinity in !! ! pycnocline - REAL(dp) :: zdudz_pyc ! u-shear across the pycnocline - REAL(dp) :: zdvdz_pyc ! v-shear across the pycnocline + REAL(wp) :: zdudz_pyc ! u-shear across the pycnocline + REAL(wp) :: zdvdz_pyc ! v-shear across the pycnocline !!---------------------------------------------------------------------- ! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> @@ -2702,26 +2702,26 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kmm ! Time-level index - REAL(dp), DIMENSION(A2D(nn_hls)), INTENT( out) :: pmld ! == Estimated FK BLD used for MLE horizontal gradients == ! - REAL(dp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdtdx ! Horizontal gradient for Fox-Kemper parametrization - REAL(dp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdtdy ! Horizontal gradient for Fox-Kemper parametrization - REAL(dp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdsdx ! Horizontal gradient for Fox-Kemper parametrization - REAL(dp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdsdy ! Horizontal gradient for Fox-Kemper parametrization - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT( out) :: pmld ! == Estimated FK BLD used for MLE horizontal gradients == ! + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdtdx ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdtdy ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdsdx ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdsdy ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient !! INTEGER :: ji, jj, jk ! Dummy loop indices INTEGER, DIMENSION(A2D(nn_hls)) :: jk_mld_prof ! Base level of MLE layer INTEGER :: ikt, ikmax ! Local integers - REAL(dp) :: zc - REAL(dp) :: zN2_c ! Local buoyancy difference from 10m value - REAL(dp), DIMENSION(A2D(nn_hls)) :: ztm - REAL(dp), DIMENSION(A2D(nn_hls)) :: zsm - REAL(dp), DIMENSION(A2D(nn_hls),jpts) :: ztsm_midu - REAL(dp), DIMENSION(A2D(nn_hls),jpts) :: ztsm_midv - REAL(dp), DIMENSION(A2D(nn_hls),jpts) :: zabu - REAL(dp), DIMENSION(A2D(nn_hls),jpts) :: zabv - REAL(dp), DIMENSION(A2D(nn_hls)) :: zmld_midu - REAL(dp), DIMENSION(A2D(nn_hls)) :: zmld_midv + REAL(wp) :: zc + REAL(wp) :: zN2_c ! Local buoyancy difference from 10m value + REAL(wp), DIMENSION(A2D(nn_hls)) :: ztm + REAL(wp), DIMENSION(A2D(nn_hls)) :: zsm + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: ztsm_midu + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: ztsm_midv + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zabu + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zabv + REAL(wp), DIMENSION(A2D(nn_hls)) :: zmld_midu + REAL(wp), DIMENSION(A2D(nn_hls)) :: zmld_midv !!---------------------------------------------------------------------- ! ! == MLD used for MLE ==! @@ -2811,20 +2811,20 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kmm ! Time-level index - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pwb_fk - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phmle ! MLE depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pwb_fk + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phmle ! MLE depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient !! INTEGER :: ji, jj, jk ! Dummy loop indices - REAL(dp), DIMENSION(A2D(nn_hls-1)) :: znd_param - REAL(dp) :: zthermal, zbeta - REAL(dp) :: zbuoy - REAL(dp) :: ztmp - REAL(dp) :: zpe_mle_layer - REAL(dp) :: zpe_mle_ref - REAL(dp) :: zdbdz_mle_int + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: znd_param + REAL(wp) :: zthermal, zbeta + REAL(wp) :: zbuoy + REAL(wp) :: ztmp + REAL(wp) :: zpe_mle_layer + REAL(wp) :: zpe_mle_ref + REAL(wp) :: zdbdz_mle_int !!---------------------------------------------------------------------- ! znd_param(:,:) = 0.0_wp @@ -2923,23 +2923,23 @@ CONTAINS !! !!---------------------------------------------------------------------- INTEGER, INTENT(in ) :: Kmm ! Time-level index - REAL(dp), DIMENSION(A2D(nn_hls)), INTENT(in ) :: pmld ! == Estimated FK BLD used for MLE horiz gradients == ! - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phmle ! MLE depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pvel_mle ! Velocity scale for dhdt with stable ML and FK - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdiff_mle ! Extra MLE vertical diff - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth - REAL(dp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb0tot ! Total surface buoyancy flux including insolation + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(in ) :: pmld ! == Estimated FK BLD used for MLE horiz gradients == ! + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phmle ! MLE depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pvel_mle ! Velocity scale for dhdt with stable ML and FK + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdiff_mle ! Extra MLE vertical diff + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb0tot ! Total surface buoyancy flux including insolation !! INTEGER :: ji, jj, jk ! Dummy loop indices - REAL(dp) :: ztmp - REAL(dp) :: zdbdz - REAL(dp) :: zdtdz - REAL(dp) :: zdsdz - REAL(dp) :: zthermal - REAL(dp) :: zbeta - REAL(dp) :: zbuoy - REAL(dp) :: zdb_mle + REAL(wp) :: ztmp + REAL(wp) :: zdbdz + REAL(wp) :: zdtdz + REAL(wp) :: zdsdz + REAL(wp) :: zthermal + REAL(wp) :: zbeta + REAL(wp) :: zbuoy + REAL(wp) :: zdb_mle !!---------------------------------------------------------------------- ! ! Calculate vertical buoyancy, heat and salinity fluxes due to MLE @@ -3000,7 +3000,7 @@ CONTAINS !! INTEGER :: ios ! Local integer INTEGER :: ji, jj, jk ! Dummy loop indices - REAL(dp) :: z1_t2 + REAL(wp) :: z1_t2 !! REAL(wp), PARAMETER :: pp_large = -1e10_wp !! @@ -3231,9 +3231,9 @@ CONTAINS INTEGER :: id1, id2, id3 ! iom enquiry index INTEGER :: ji, jj, jk ! Dummy loop indices INTEGER :: iiki, ikt ! Local integer - REAL(dp) :: zhbf ! Tempory scalars - REAL(dp) :: zN2_c ! Local scalar - REAL(dp) :: rho_c = 0.01_wp ! Density criterion for mixed layer depth + REAL(wp) :: zhbf ! Tempory scalars + REAL(wp) :: zN2_c ! Local scalar + REAL(wp) :: rho_c = 0.01_wp ! Density criterion for mixed layer depth INTEGER, DIMENSION(jpi,jpj) :: imld_rst ! Level of mixed-layer depth (pycnocline top) !!---------------------------------------------------------------------- ! @@ -3338,7 +3338,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! Active tracers and RHS of tracer equation !! INTEGER :: ji, jj, jk - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace !!---------------------------------------------------------------------- ! IF ( kt == nit000 ) THEN @@ -3372,10 +3372,10 @@ CONTAINS DEALLOCATE( ztrdt, ztrds ) END IF ! - !IF ( sn_cfctl%l_prtctl ) THEN - ! CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' osm - Ta: ', mask1=tmask, & - ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) - !END IF + ! IF ( sn_cfctl%l_prtctl ) THEN + !CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' osm - Ta: ', mask1=tmask, & + ! & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! END IF ! END SUBROUTINE tra_osm @@ -3442,7 +3442,7 @@ CONTAINS !! !!---------------------------------------------------------------------- CHARACTER(LEN=*), INTENT(in ) :: cdname - REAL(dp), DIMENSION(:,:), INTENT(in ) :: posmdia2d + REAL(wp), DIMENSION(:,:), INTENT(in ) :: posmdia2d !!---------------------------------------------------------------------- ! IF ( ln_dia_osm .AND. iom_use( cdname ) ) THEN @@ -3465,7 +3465,7 @@ CONTAINS !! !!---------------------------------------------------------------------- CHARACTER(LEN=*), INTENT(in ) :: cdname - REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: posmdia3d + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: posmdia3d !!---------------------------------------------------------------------- ! IF ( ln_dia_osm .AND. iom_use( cdname ) ) THEN @@ -3481,4 +3481,4 @@ CONTAINS !!====================================================================== -END MODULE zdfosm +END MODULE zdfosm \ No newline at end of file diff --git a/src/OCE/ZDF/zdfphy.F90 b/src/OCE/ZDF/zdfphy.F90 index 86be089425aa1b89c688c0902f502d843fc5211c..963dd3aacd2c618af64b10de9a2d924ae5e54ca9 100644 --- a/src/OCE/ZDF/zdfphy.F90 +++ b/src/OCE/ZDF/zdfphy.F90 @@ -57,7 +57,7 @@ MODULE zdfphy LOGICAL, PUBLIC :: l_zdfsh2 ! shear production term flag (=F for CST, =T otherwise (i.e. TKE, GLS, RIC)) - REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm_k_n !: AFNRG avm_k used for calculation of zsh2 with tiling + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm_k_n !: "Now" avm_k used for calculation of zsh2 with tiling !! * Substitutions # include "do_loop_substitute.h90" @@ -255,7 +255,7 @@ CONTAINS INTEGER, INTENT(in) :: Kbb, Kmm, Krhs ! ocean time level indices ! INTEGER :: ji, jj, jk ! dummy loop indice - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zsh2 ! shear production + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zsh2 ! shear production !! --------------------------------------------------------------------- ! IF( ln_timing ) CALL timing_start('zdf_phy') @@ -352,15 +352,15 @@ CONTAINS ! !* Lateral boundary conditions (sign unchanged) IF(nn_hls==1) THEN IF( l_zdfsh2 ) THEN - CALL lbc_lnk( 'zdfphy', avm_k, 'W', 1.0_dp , avt_k, 'W', 1.0_dp, & - & avm , 'W', 1.0_dp , avt , 'W', 1.0_dp , avs , 'W', 1.0_dp ) + CALL lbc_lnk( 'zdfphy', avm_k, 'W', 1.0_wp , avt_k, 'W', 1.0_wp, & + & avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) ELSE - CALL lbc_lnk( 'zdfphy', avm , 'W', 1.0_dp , avt , 'W', 1.0_dp , avs , 'W', 1.0_dp ) + CALL lbc_lnk( 'zdfphy', avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) ENDIF ! IF( l_zdfdrg ) THEN ! drag have been updated (non-linear cases) - IF( ln_isfcav ) THEN ; CALL lbc_lnk( 'zdfphy', rCdU_top, 'T', 1.0_dp , rCdU_bot, 'T', 1.0_dp ) ! top & bot drag - ELSE ; CALL lbc_lnk( 'zdfphy', rCdU_bot, 'T', 1.0_dp ) ! bottom drag only + IF( ln_isfcav ) THEN ; CALL lbc_lnk( 'zdfphy', rCdU_top, 'T', 1.0_wp , rCdU_bot, 'T', 1.0_wp ) ! top & bot drag + ELSE ; CALL lbc_lnk( 'zdfphy', rCdU_bot, 'T', 1.0_wp ) ! bottom drag only ENDIF ENDIF ENDIF @@ -402,4 +402,4 @@ CONTAINS END FUNCTION zdf_phy_alloc !!====================================================================== -END MODULE zdfphy +END MODULE zdfphy \ No newline at end of file diff --git a/src/OCE/ZDF/zdfric.F90 b/src/OCE/ZDF/zdfric.F90 index f992a251ccfde496ce73c5e3abb0bcd849836804..386c62bddfe7af433a4d6ef0a160051cff123d8c 100644 --- a/src/OCE/ZDF/zdfric.F90 +++ b/src/OCE/ZDF/zdfric.F90 @@ -39,13 +39,13 @@ MODULE zdfric ! !!* Namelist namzdf_ric : Richardson number dependent Kz * INTEGER :: nn_ric ! coefficient of the parameterization - REAL(dp) :: rn_avmri ! maximum value of the vertical eddy viscosity - REAL(dp) :: rn_alp ! coefficient of the parameterization - REAL(dp) :: rn_ekmfc ! Ekman Factor Coeff - REAL(dp) :: rn_mldmin ! minimum mixed layer (ML) depth - REAL(dp) :: rn_mldmax ! maximum mixed layer depth - REAL(dp) :: rn_wtmix ! Vertical eddy Diff. in the ML - REAL(dp) :: rn_wvmix ! Vertical eddy Visc. in the ML + REAL(wp) :: rn_avmri ! maximum value of the vertical eddy viscosity + REAL(wp) :: rn_alp ! coefficient of the parameterization + REAL(wp) :: rn_ekmfc ! Ekman Factor Coeff + REAL(wp) :: rn_mldmin ! minimum mixed layer (ML) depth + REAL(wp) :: rn_mldmax ! maximum mixed layer depth + REAL(wp) :: rn_wtmix ! Vertical eddy Diff. in the ML + REAL(wp) :: rn_wvmix ! Vertical eddy Visc. in the ML LOGICAL :: ln_mldw ! Use or not the MLD parameters !! * Substitutions @@ -147,12 +147,12 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! ocean time-step INTEGER , INTENT(in ) :: Kmm ! ocean time level index - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term - REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) !! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zcfRi, zav, zustar, zhek ! local scalars - REAL(dp), DIMENSION(A2D(nn_hls)) :: zh_ekm ! 2D workspace + REAL(wp) :: zcfRi, zav, zustar, zhek ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zh_ekm ! 2D workspace !!---------------------------------------------------------------------- ! ! !== avm and avt = F(Richardson number) ==! diff --git a/src/OCE/ZDF/zdfsh2.F90 b/src/OCE/ZDF/zdfsh2.F90 index bf7a02235d2ef5470e2e44a44bfc4e9e8c21ba7b..7b9a7fe144a385f46c686e4f7e26253381b28315 100644 --- a/src/OCE/ZDF/zdfsh2.F90 +++ b/src/OCE/ZDF/zdfsh2.F90 @@ -55,11 +55,11 @@ CONTAINS !! References : Bruchard, OM 2002 !! --------------------------------------------------------------------- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm ! vertical eddy viscosity (w-points) - REAL(dp), DIMENSION(A2D(nn_hls),jpk) , INTENT( out) :: p_sh2 ! shear production of TKE (w-points) + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm ! vertical eddy viscosity (w-points) + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT( out) :: p_sh2 ! shear production of TKE (w-points) ! INTEGER :: ji, jj, jk ! dummy loop arguments - REAL(dp), DIMENSION(A2D(nn_hls)) :: zsh2u, zsh2v ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls)) :: zsh2u, zsh2v ! 2D workspace !!-------------------------------------------------------------------- ! DO jk = 2, jpkm1 !* Shear production at uw- and vw-points (energy conserving form) diff --git a/src/OCE/ZDF/zdfswm.F90 b/src/OCE/ZDF/zdfswm.F90 index ce5840c1fff9835dd0339bf40cad927d2b6b0ada..be2aa94e93491c4c0a2964c27edc0bf39d2a5175 100644 --- a/src/OCE/ZDF/zdfswm.F90 +++ b/src/OCE/ZDF/zdfswm.F90 @@ -55,11 +55,11 @@ CONTAINS !!--------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! ocean time step INTEGER , INTENT(in ) :: Kmm ! time level index - REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) - REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points) + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points) ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp):: zcoef, zqb ! local scalar + REAL(wp):: zcoef, zqb ! local scalar !!--------------------------------------------------------------------- ! zcoef = 1._wp * 0.353553_wp diff --git a/src/OCE/ZDF/zdftke.F90 b/src/OCE/ZDF/zdftke.F90 index a1c086a3ebeb330751c840c0e52535e9a0d8de2f..56ecec04a1a33391b2bd4161a4ecb88bce7a459c 100644 --- a/src/OCE/ZDF/zdftke.F90 +++ b/src/OCE/ZDF/zdftke.F90 @@ -72,33 +72,33 @@ MODULE zdftke LOGICAL :: ln_mxl0 ! mixing length scale surface value as function of wind stress or not LOGICAL :: ln_mxhsw ! mixing length scale surface value as a fonction of wave height INTEGER :: nn_mxlice ! type of scaling under sea-ice (=0/1/2/3) - REAL(dp) :: rn_mxlice ! ice thickness value when scaling under sea-ice + REAL(wp) :: rn_mxlice ! ice thickness value when scaling under sea-ice INTEGER :: nn_mxl ! type of mixing length (=0/1/2/3) - REAL(dp) :: rn_mxl0 ! surface min value of mixing length (kappa*z_o=0.4*0.1 m) [m] + REAL(wp) :: rn_mxl0 ! surface min value of mixing length (kappa*z_o=0.4*0.1 m) [m] INTEGER :: nn_pdl ! Prandtl number or not (ratio avt/avm) (=0/1) - REAL(dp) :: rn_ediff ! coefficient for avt: avt=rn_ediff*mxl*sqrt(e) - REAL(dp) :: rn_ediss ! coefficient of the Kolmogoroff dissipation - REAL(dp) :: rn_ebb ! coefficient of the surface input of tke - REAL(dp) :: rn_emin ! minimum value of tke [m2/s2] - REAL(dp) :: rn_emin0 ! surface minimum value of tke [m2/s2] - REAL(dp) :: rn_bshear ! background shear (>0) currently a numerical threshold (do not change it) + REAL(wp) :: rn_ediff ! coefficient for avt: avt=rn_ediff*mxl*sqrt(e) + REAL(wp) :: rn_ediss ! coefficient of the Kolmogoroff dissipation + REAL(wp) :: rn_ebb ! coefficient of the surface input of tke + REAL(wp) :: rn_emin ! minimum value of tke [m2/s2] + REAL(wp) :: rn_emin0 ! surface minimum value of tke [m2/s2] + REAL(wp) :: rn_bshear ! background shear (>0) currently a numerical threshold (do not change it) INTEGER :: nn_etau ! type of depth penetration of surface tke (=0/1/2/3) INTEGER :: nn_htau ! type of tke profile of penetration (=0/1) INTEGER :: nn_bc_surf! surface condition (0/1=Dir/Neum) ! Only applicable for wave coupling INTEGER :: nn_bc_bot ! surface condition (0/1=Dir/Neum) ! Only applicable for wave coupling - REAL(dp) :: rn_efr ! fraction of TKE surface value which penetrates in the ocean + REAL(wp) :: rn_efr ! fraction of TKE surface value which penetrates in the ocean LOGICAL :: ln_lc ! Langmuir cells (LC) as a source term of TKE or not - REAL(dp) :: rn_lc ! coef to compute vertical velocity of Langmuir cells + REAL(wp) :: rn_lc ! coef to compute vertical velocity of Langmuir cells INTEGER :: nn_eice ! attenutaion of langmuir & surface wave breaking under ice (=0/1/2/3) - REAL(dp) :: ri_cri ! critic Richardson number (deduced from rn_ediff and rn_ediss values) - REAL(dp) :: rmxl_min ! minimum mixing length value (deduced from rn_ediff and rn_emin values) [m] - REAL(dp) :: rhftau_add = 1.e-3_wp ! add offset applied to HF part of taum (nn_etau=3) - REAL(dp) :: rhftau_scl = 1.0_wp ! scale factor applied to HF part of taum (nn_etau=3) + REAL(wp) :: ri_cri ! critic Richardson number (deduced from rn_ediff and rn_ediss values) + REAL(wp) :: rmxl_min ! minimum mixing length value (deduced from rn_ediff and rn_emin values) [m] + REAL(wp) :: rhftau_add = 1.e-3_wp ! add offset applied to HF part of taum (nn_etau=3) + REAL(wp) :: rhftau_scl = 1.0_wp ! scale factor applied to HF part of taum (nn_etau=3) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htau ! depth of tke penetration (nn_htau) - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dissl ! now mixing lenght of dissipation - REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: apdlr ! now mixing lenght of dissipation + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htau ! depth of tke penetration (nn_htau) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dissl ! now mixing lenght of dissipation + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: apdlr ! now mixing lenght of dissipation !! * Substitutions # include "do_loop_substitute.h90" @@ -169,8 +169,8 @@ CONTAINS !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! ocean time step INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices - REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term - REAL(dp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) !!---------------------------------------------------------------------- ! CALL tke_tke( Kbb, Kmm, p_sh2, p_avm, p_avt ) ! now tke (en) @@ -201,24 +201,24 @@ CONTAINS USE zdf_oce , ONLY : en ! ocean vertical physics !! INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices - REAL(dp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in ) :: p_sh2 ! shear production term - REAL(dp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) ! INTEGER :: ji, jj, jk ! dummy loop arguments - REAL(dp) :: zetop, zebot, zmsku, zmskv ! local scalars - REAL(dp) :: zrhoa = 1.22 ! Air density kg/m3 - REAL(dp) :: zcdrag = 1.5e-3 ! drag coefficient - REAL(dp) :: zbbrau, zbbirau, zri ! local scalars - REAL(dp) :: zfact1, zfact2, zfact3 ! - - - REAL(dp) :: ztx2 , zty2 , zcof ! - - - REAL(dp) :: ztau , zdif ! - - - REAL(dp) :: zus , zwlc , zind ! - - - REAL(dp) :: zzd_up, zzd_lw ! - - - REAL(dp) :: ztaui, ztauj, z1_norm + REAL(wp) :: zetop, zebot, zmsku, zmskv ! local scalars + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: zbbrau, zbbirau, zri ! local scalars + REAL(wp) :: zfact1, zfact2, zfact3 ! - - + REAL(wp) :: ztx2 , zty2 , zcof ! - - + REAL(wp) :: ztau , zdif ! - - + REAL(wp) :: zus , zwlc , zind ! - - + REAL(wp) :: zzd_up, zzd_lw ! - - + REAL(wp) :: ztaui, ztauj, z1_norm INTEGER , DIMENSION(A2D(nn_hls)) :: imlc - REAL(dp), DIMENSION(A2D(nn_hls)) :: zice_fra, zhlc, zus3, zWlc2 - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zpelc, zdiag, zd_up, zd_lw - REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztmp ! for diags + REAL(wp), DIMENSION(A2D(nn_hls)) :: zice_fra, zhlc, zus3, zWlc2 + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpelc, zdiag, zd_up, zd_lw + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztmp ! for diags !!-------------------------------------------------------------------- ! zbbrau = rn_ebb / rho0 ! Local constant initialisation @@ -533,13 +533,13 @@ CONTAINS USE zdf_oce , ONLY : en, avtb, avmb, avtb_2d ! ocean vertical physics !! INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices - REAL(dp), DIMENSION(:,:,:), INTENT( out) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) ! INTEGER :: ji, jj, jk ! dummy loop indices - REAL(dp) :: zrn2, zraug, zcoef, zav ! local scalars - REAL(dp) :: zdku, zdkv, zsqen ! - - - REAL(dp) :: zemxl, zemlm, zemlp, zmaxice ! - - - REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zmxlm, zmxld ! 3D workspace + REAL(wp) :: zrn2, zraug, zcoef, zav ! local scalars + REAL(wp) :: zdku, zdkv, zsqen ! - - + REAL(wp) :: zemxl, zemlm, zemlp, zmaxice ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zmxlm, zmxld ! 3D workspace !!-------------------------------------------------------------------- ! ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @@ -690,10 +690,10 @@ CONTAINS END_3D ENDIF ! - IF(sn_cfctl%l_prtctl) THEN + ! IF(sn_cfctl%l_prtctl) THEN !CALL prt_ctl( tab3d_1=en , clinfo1=' tke - e: ', tab3d_2=p_avt, clinfo2=' t: ' ) !CALL prt_ctl( tab3d_1=p_avm, clinfo1=' tke - m: ' ) - ENDIF + ! ENDIF ! END SUBROUTINE tke_avn diff --git a/src/OCE/exampl.mod b/src/OCE/exampl.mod new file mode 100644 index 0000000000000000000000000000000000000000..47785acd6a14a04f6083637e49f1266e0e0e82ec Binary files /dev/null and b/src/OCE/exampl.mod differ diff --git a/src/OCE/lib_fortran.F90 b/src/OCE/lib_fortran.F90 index 9dfe247c3ee04f058938fdc92ea4d56641a88f00..299a7c0047f4dc4eda95f0e50bae3cc381135057 100644 --- a/src/OCE/lib_fortran.F90 +++ b/src/OCE/lib_fortran.F90 @@ -119,7 +119,7 @@ CONTAINS !!----------------------------------------------------------------------- ! COMPLEX(dp):: ctmp - REAL(wp) :: ztmp + REAL(dp) :: ztmp INTEGER :: ji, jj ! dummy loop indices INTEGER :: ipi, ipj ! dimensions !!----------------------------------------------------------------------- @@ -142,13 +142,13 @@ CONTAINS FUNCTION local_sum_3d( ptab ) !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptab ! array on which operation is applied + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptab ! array on which operation is applied COMPLEX(dp) :: local_sum_3d ! !!----------------------------------------------------------------------- ! COMPLEX(dp):: ctmp - REAL(wp) :: ztmp + REAL(dp) :: ztmp INTEGER :: ji, jj, jk ! dummy loop indices INTEGER :: ipi, ipj, ipk ! dimensions !!----------------------------------------------------------------------- @@ -288,10 +288,10 @@ CONTAINS !!---------------------------------------------------------------------- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine REAL(dp), DIMENSION(:,:,:), INTENT(in) :: ptab ! array on which operation is applied - REAL(wp), DIMENSION(SIZE(ptab,3)) :: ptmp + REAL(dp), DIMENSION(SIZE(ptab,3)) :: ptmp ! COMPLEX(dp), DIMENSION(:), ALLOCATABLE :: ctmp - REAL(wp) :: ztmp + REAL(dp) :: ztmp INTEGER :: ji , jj , jk ! dummy loop indices INTEGER :: ipi, ipj, ipk ! dimensions INTEGER :: iis, iie, ijs, ije ! loop start and end @@ -322,7 +322,7 @@ CONTAINS END DO CALL mpp_sum( cdname, ctmp(:) ) ! sum over the global domain ! - ptmp = REAL( ctmp(:),dp ) + ptmp = REAL( ctmp(:), dp ) ! DEALLOCATE( ctmp ) ! @@ -332,10 +332,10 @@ CONTAINS !!---------------------------------------------------------------------- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: ptab ! array on which operation is applied - REAL(wp), DIMENSION(SIZE(ptab,4)) :: ptmp + REAL(dp), DIMENSION(SIZE(ptab,4)) :: ptmp ! COMPLEX(dp), DIMENSION(:), ALLOCATABLE :: ctmp - REAL(wp) :: ztmp + REAL(dp) :: ztmp INTEGER :: ji , jj , jk , jl ! dummy loop indices INTEGER :: ipi, ipj, ipk, ipl ! dimensions INTEGER :: iis, iie, ijs, ije ! loop start and end @@ -369,7 +369,7 @@ CONTAINS END DO CALL mpp_sum( cdname, ctmp(:) ) ! sum over the global domain ! - ptmp = REAL( ctmp(:),dp ) + ptmp = REAL( ctmp(:), dp ) ! DEALLOCATE( ctmp ) ! @@ -378,8 +378,8 @@ CONTAINS FUNCTION glob_min_vec_3d( cdname, ptab ) RESULT( ptmp ) !!---------------------------------------------------------------------- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine - REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptab ! array on which operation is applied - REAL(wp), DIMENSION(SIZE(ptab,3)) :: ptmp + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,3)) :: ptmp ! INTEGER :: jk ! dummy loop indice & dimension INTEGER :: ipk ! dimension @@ -398,7 +398,7 @@ CONTAINS !!---------------------------------------------------------------------- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: ptab ! array on which operation is applied - REAL(wp), DIMENSION(SIZE(ptab,4)) :: ptmp + REAL(dp), DIMENSION(SIZE(ptab,4)) :: ptmp ! INTEGER :: jk , jl ! dummy loop indice & dimension INTEGER :: ipk, ipl ! dimension @@ -421,7 +421,7 @@ CONTAINS !!---------------------------------------------------------------------- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptab ! array on which operation is applied - REAL(wp), DIMENSION(SIZE(ptab,3)) :: ptmp + REAL(dp), DIMENSION(SIZE(ptab,3)) :: ptmp ! INTEGER :: jk ! dummy loop indice & dimension INTEGER :: ipk ! dimension @@ -439,8 +439,8 @@ CONTAINS FUNCTION glob_max_vec_4d( cdname, ptab ) RESULT( ptmp ) !!---------------------------------------------------------------------- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine - REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: ptab ! array on which operation is applied - REAL(wp), DIMENSION(SIZE(ptab,4)) :: ptmp + REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,4)) :: ptmp ! INTEGER :: jk , jl ! dummy loop indice & dimension INTEGER :: ipk, ipl ! dimension @@ -467,7 +467,7 @@ CONTAINS !! !! !! ** Method : The code uses the compensated summation with doublet - !! (sum,error) emulated useing complex numbers. ydda is the + !! (sum,error) emulated using complex numbers. ydda is the !! scalar to add to the summ yddb !! !! ** Action : This does only work for MPI. diff --git a/src/OCE/lib_fortran_generic.h90 b/src/OCE/lib_fortran_generic.h90 index ea276d847a86e768b27f6ea6ed9fca073f93f435..77d46540aafe44f2c68c342749d3dbe6b7dc3d6d 100644 --- a/src/OCE/lib_fortran_generic.h90 +++ b/src/OCE/lib_fortran_generic.h90 @@ -65,7 +65,7 @@ END DO END DO CALL mpp_sum( cdname, ctmp ) ! sum over the global domain - glob_sum_/**/XD = REAL(ctmp,dp) + glob_sum_/**/XD = REAL(ctmp,wp) END FUNCTION glob_sum_/**/XD diff --git a/src/OCE/module_example.F90 b/src/OCE/module_example.F90 index f7169af03b9aaf16109e70a164cad6ee52cfd531..5635061e5c56cc0190d1db557c563400fc73c569 100644 --- a/src/OCE/module_example.F90 +++ b/src/OCE/module_example.F90 @@ -1,5 +1,4 @@ MODULE exampl - USE par_kind !!====================================================================== !! *** MODULE exampl *** !! Ocean physics: brief description of the purpose of the module @@ -17,6 +16,7 @@ MODULE exampl !! exa_mpl_init : name of the module for a routine) !! exa_mpl_stp : Please try to use 3 letter block for routine names !!---------------------------------------------------------------------- + USE par_kind USE module_name1 ! brief description of the used module USE module_name2 ! .... diff --git a/src/OCE/nemogcm.F90 b/src/OCE/nemogcm.F90 index 87e9a97716b6e3074cc514697b0fc63f5b06a3b9..fd7c0aaf918c3f863c293da93925fda49ba4aca2 100644 --- a/src/OCE/nemogcm.F90 +++ b/src/OCE/nemogcm.F90 @@ -111,7 +111,7 @@ CONTAINS !! Madec, 2008, internal report, IPSL. !!---------------------------------------------------------------------- INTEGER :: istp ! time step index - REAL(dp):: zstptiming ! elapsed time for 1 time step + REAL(wp):: zstptiming ! elapsed time for 1 time step !!---------------------------------------------------------------------- ! #if defined key_agrif diff --git a/src/OCE/oce.F90 b/src/OCE/oce.F90 index 89ee4dc9da0436a54ce91df2cafd93988e506fa3..ec5c05ad27c5fee3ae760fbd3beb372debb3cede 100644 --- a/src/OCE/oce.F90 +++ b/src/OCE/oce.F90 @@ -21,50 +21,52 @@ MODULE oce !! dynamics and tracer fields !! -------------------------- REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: uu , vv !: horizontal velocities [m/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ww !: vertical velocity [m/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wi !: vertical vel. (adaptive-implicit) [m/s] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv !: horizontal divergence [s-1] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ww !: vertical velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wi !: vertical vel. (adaptive-implicit) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv !: horizontal divergence [s-1] REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: ts !: 4D T-S fields [Celsius,psu] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_b, rab_n !: thermal/haline expansion coef. [Celsius-1,psu-1] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rn2b , rn2 !: brunt-vaisala frequency**2 [s-2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_b, rab_n !: thermal/haline expansion coef. [Celsius-1,psu-1] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rn2b , rn2 !: brunt-vaisala frequency**2 [s-2] ! - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rhd !: in situ density anomalie rhd=(rho-rho0)/rho0 [no units] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rhd !: in situ density anomalie rhd=(rho-rho0)/rho0 [no units] REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rhop !: potential volumic mass [kg/m3] - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: Cu_adv !: vertical Courant number (adaptive-implicit) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: Cu_adv !: vertical Courant number (adaptive-implicit) !! free surface !! ------------ - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ssh, uu_b, vv_b !: SSH [m] and barotropic velocities [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uu_b, vv_b!: SSH [m] and barotropic velocities [m/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ssh!: SSH [m] and barotropic velocities [m/s] REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssh_frc !: Forcing term in external mode for SSH [m/s] !! Arrays at barotropic time step: ! befbefore! before ! now ! after ! - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubb_e , ub_e , un_e , ua_e !: u-external velocity - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vbb_e , vb_e , vn_e , va_e !: v-external velocity - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshbb_e, sshb_e, sshn_e, ssha_e !: external ssh - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_e !: external u-depth - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_e !: external v-depth - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hur_e !: inverse of u-depth - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hvr_e !: inverse of v-depth - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_b , vb2_b !: Half step fluxes (ln_bt_fw=T) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_bf , vn_bf !: Asselin filtered half step fluxes (ln_bt_fw=T) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubb_e , ub_e , un_e , ua_e !: u-external velocity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vbb_e , vb_e , vn_e , va_e !: v-external velocity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshbb_e, sshb_e!: external ssh + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshn_e, ssha_e!: external ssh + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_e !: external u-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_e !: external v-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hur_e !: inverse of u-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hvr_e !: inverse of v-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_b , vb2_b !: Half step fluxes (ln_bt_fw=T) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_bf , vn_bf !: Asselin filtered half step fluxes (ln_bt_fw=T) #if defined key_agrif REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_i_b, vb2_i_b !: Half step time integrated fluxes #endif !! interpolated gradient (only used in zps case) !! --------------------- - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtsu, gtsv !: horizontal gradient of T, S bottom u-point - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gru , grv !: horizontal gradient of rd at bottom u-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtsu, gtsv !: horizontal gradient of T, S bottom u-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gru , grv !: horizontal gradient of rd at bottom u-point !! (ISF) interpolated gradient (only used for ice shelf case) !! --------------------- - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtui, gtvi !: horizontal gradient of T, S and rd at top u-point - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: grui, grvi !: horizontal gradient of T, S and rd at top v-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtui, gtvi !: horizontal gradient of T, S and rd at top u-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: grui, grvi !: horizontal gradient of T, S and rd at top v-point !! (ISF) ice load - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: riceload + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: riceload !! Energy budget of the leads (open water embedded in sea ice) - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fraqsr_1lev !: fraction of solar net radiation absorbed in the first ocean level [-] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fraqsr_1lev !: fraction of solar net radiation absorbed in the first ocean level [-] INTEGER, PUBLIC, DIMENSION(2) :: noce_array !: unused array but seems to be needed to prevent agrif from creating an empty module !! Shallow Water Eq. case (SWE) diff --git a/src/OCE/par_kind.F90 b/src/OCE/par_kind.F90 index 1ed7b7e623dae0c46af7d820599a7deb0e12c63c..9226b96f2ac9b4a2c5f839ee2cfbe2cc3831a0d6 100644 --- a/src/OCE/par_kind.F90 +++ b/src/OCE/par_kind.F90 @@ -30,7 +30,7 @@ MODULE par_kind INTEGER, PUBLIC, PARAMETER :: i4 = SELECTED_INT_KIND( 9) !: single precision (integer 4) INTEGER, PUBLIC, PARAMETER :: i8 = SELECTED_INT_KIND(14) !: double precision (integer 8) - ! !!** Integer ** + ! !!** Integer ** INTEGER, PUBLIC, PARAMETER :: lc = 256 !: Lenght of Character strings INTEGER, PUBLIC, PARAMETER :: lca = 400 !: Lenght of Character arrays @@ -39,4 +39,4 @@ MODULE par_kind !! $Id: par_kind.F90 14433 2021-02-11 08:06:49Z smasson $ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- -END MODULE par_kind \ No newline at end of file +END MODULE par_kind diff --git a/src/OCE/stpctl.F90 b/src/OCE/stpctl.F90 index acae5894afc0efe351898a77dfcd67b3b1d7af45..a074da997c521aaae643aa8840b02e863a5a962e 100644 --- a/src/OCE/stpctl.F90 +++ b/src/OCE/stpctl.F90 @@ -40,6 +40,8 @@ MODULE stpctl !! $Id: stpctl.F90 15023 2021-06-18 14:35:25Z gsamson $ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" CONTAINS SUBROUTINE stp_ctl( kt, Kmm ) @@ -66,9 +68,9 @@ CONTAINS INTEGER :: idtime, istatus INTEGER , DIMENSION(jptst) :: iareasum, iareamin, iareamax INTEGER , DIMENSION(3,jptst) :: iloc ! min/max loc indices - REAL(dp) :: zzz, zminsal, zmaxsal ! local real - REAL(dp), DIMENSION(jpvar+1) :: zmax - REAL(dp), DIMENSION(jptst) :: zmaxlocal + REAL(wp) :: zzz, zminsal, zmaxsal ! local real + REAL(wp), DIMENSION(jpvar+1) :: zmax + REAL(wp), DIMENSION(jptst) :: zmaxlocal LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce LOGICAL, DIMENSION(jpi,jpj,jpk) :: llmsk CHARACTER(len=20) :: clname @@ -153,7 +155,7 @@ CONTAINS ELSE zmax(5:8) = 0._wp ENDIF - zmax(jpvar+1) = REAL( nstop,dp ) ! stop indicator + zmax(jpvar+1) = REAL( nstop, wp ) ! stop indicator ! ! !== get global extrema ==! ! !== done by all processes if writting run.stat ==! @@ -207,10 +209,10 @@ CONTAINS llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), llmsk(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain - CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:, Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) ) + CALL mpp_maxloc( 'stpctl', CASTDP(ABS( uu(:,:,:, Kmm))), llmsk(:,:,:), zzz, iloc(1:3,2) ) llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,3) ) - CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,4) ) + CALL mpp_maxloc( 'stpctl', CASTDP(ts(:,:,:,jp_sal,Kmm)) , llmsk(:,:,:), zzz, iloc(1:3,4) ) ! find which subdomain has the max. iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 DO ji = 1, jptst @@ -278,7 +280,7 @@ CONTAINS !!---------------------------------------------------------------------- CHARACTER(len=*), INTENT( out) :: cdline CHARACTER(len=*), INTENT(in ) :: cdprefix - REAL(dp), INTENT(in ) :: pval + REAL(wp), INTENT(in ) :: pval INTEGER, DIMENSION(3), INTENT(in ) :: kloc INTEGER, INTENT(in ) :: kt, ksum, kmin, kmax ! @@ -291,27 +293,27 @@ CONTAINS !!---------------------------------------------------------------------- WRITE(clkt , '(i9)') kt - WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij ,dp))) + 1 ! how many digits to we need to write ? (we decide max = 9) + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij ,wp))) + 1 ! how many digits to we need to write ? (we decide max = 9) !!! WRITE(clsum, '(i'//clfmt//')') ksum ! this is creating a compilation error with AGRIF cl4 = '(i'//clfmt//')' ; WRITE(clsum, cl4) ksum - WRITE(clfmt, '(i1)') INT(LOG10(REAL(MAX(1,jpnij-1),dp))) + 1 ! how many digits to we need to write ? (we decide max = 9) + WRITE(clfmt, '(i1)') INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1 ! how many digits to we need to write ? (we decide max = 9) cl4 = '(i'//clfmt//')' ; WRITE(clmin, cl4) kmin-1 WRITE(clmax, cl4) kmax-1 ! - WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,dp))) + 1 ! how many digits to we need to write jpiglo? (we decide max = 9) + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1 ! how many digits to we need to write jpiglo? (we decide max = 9) cl4 = '(i'//clfmt//')' ; WRITE(cli, cl4) kloc(1) ! this is ok with AGRIF - WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,dp))) + 1 ! how many digits to we need to write jpjglo? (we decide max = 9) + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1 ! how many digits to we need to write jpjglo? (we decide max = 9) cl4 = '(i'//clfmt//')' ; WRITE(clj, cl4) kloc(2) ! this is ok with AGRIF ! IF( ksum == 1 ) THEN ; WRITE(clsuff,9100) TRIM(clmin) ELSE ; WRITE(clsuff,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax) ENDIF IF(kloc(3) == 0) THEN - ifmtk = INT(LOG10(REAL(jpk,dp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9) + ifmtk = INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9) clk = REPEAT(' ', ifmtk) ! create the equivalent in blank string WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(clsuff) ELSE - WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,dp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9) + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9) !!! WRITE(clk, '(i'//clfmt//')') kloc(3) ! this is creating a compilation error with AGRIF cl4 = '(i'//clfmt//')' ; WRITE(clk, cl4) kloc(3) ! this is ok with AGRIF WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), TRIM(clk), TRIM(clsuff) @@ -326,4 +328,4 @@ CONTAINS !!====================================================================== -END MODULE stpctl \ No newline at end of file +END MODULE stpctl diff --git a/src/OCE/stpmlf.F90 b/src/OCE/stpmlf.F90 index d450c3d6c61adb76c9c940e5f470c5a725ddf0a1..1b4ffb767506ffefd3c381730841ee3dbdb56400 100644 --- a/src/OCE/stpmlf.F90 +++ b/src/OCE/stpmlf.F90 @@ -70,7 +70,8 @@ CONTAINS #if defined key_agrif RECURSIVE SUBROUTINE stp_MLF( ) - INTEGER :: kstp ! ocean time-step inde + INTEGER :: kstp ! ocean time-step index + #else SUBROUTINE stp_MLF( kstp ) INTEGER, INTENT(in) :: kstp ! ocean time-step index @@ -92,7 +93,7 @@ CONTAINS !! -8- Outputs and diagnostics !!---------------------------------------------------------------------- INTEGER :: ji, jj, jk, jtile ! dummy loop indice - REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zgdept + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zgdept !! --------------------------------------------------------------------- #if defined key_agrif IF( nstop > 0 ) RETURN ! avoid to go further if an error was detected during previous time step (child grid) @@ -460,8 +461,6 @@ CONTAINS ! END SUBROUTINE stp_MLF - - SUBROUTINE mlf_baro_corr( Kmm, Kaa, puu, pvv ) !!---------------------------------------------------------------------- !! *** ROUTINE mlf_baro_corr *** @@ -480,7 +479,7 @@ CONTAINS REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities ! INTEGER :: ji,jj, jk ! dummy loop indices - REAL(dp), DIMENSION(jpi,jpj) :: zue, zve + REAL(wp), DIMENSION(jpi,jpj) :: zue, zve !!---------------------------------------------------------------------- ! Ensure below that barotropic velocities match time splitting estimate @@ -551,12 +550,12 @@ CONTAINS & , pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) ! ! lbc_lnk needed for zdf_sh2 when using nn_hls = 2, moved here to allow tiling in zdf_phy - IF( nn_hls == 2 .AND. l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_dp ) + IF( nn_hls == 2 .AND. l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_wp ) ! dom_qco_r3c defines over [nn_hls, nn_hls-1, nn_hls, nn_hls-1] IF( nn_hls == 2 .AND. .NOT. lk_linssh ) THEN - CALL lbc_lnk( 'finalize_lbc', r3u(:,:,Kaa), 'U', 1._dp, r3v(:,:,Kaa), 'V', 1._dp, & - & r3u_f(:,:), 'U', 1._dp, r3v_f(:,:), 'V', 1._dp ) + CALL lbc_lnk( 'finalize_lbc', r3u(:,:,Kaa), 'U', 1._wp, r3v(:,:,Kaa), 'V', 1._wp, & + & r3u_f(:,:), 'U', 1._wp, r3v_f(:,:), 'V', 1._wp ) ENDIF ! !* BDY open boundaries IF( ln_bdy ) THEN diff --git a/src/OCE/timing.F90 b/src/OCE/timing.F90 index 8722b236bc531bcfee1e07aea8496df99173e67e..d78f5802367a78470bbc783600ad1492fd617744 100644 --- a/src/OCE/timing.F90 +++ b/src/OCE/timing.F90 @@ -396,7 +396,7 @@ CONTAINS IF ( ztot /= 0._wp ) zperc = timing_glob(4*ji-1) / ztot * 100. WRITE(numtime,'(A28,F11.6,A2, F4.1,A3,A25,I8)') 'Waiting global time : ',timing_glob(4*ji-1) & & , ' (', zperc,' %)', ' on MPI rank : ', ji - IF ( timing_glob(4*ji) /= 0._wp ) zsypd = rn_Dt * REAL(nitend-nit000-1,dp) / (timing_glob(4*ji) * 365.) + IF ( timing_glob(4*ji) /= 0._wp ) zsypd = rn_Dt * REAL(nitend-nit000-1, wp) / (timing_glob(4*ji) * 365.) WRITE(numtime,'(A28,F11.6,A7,F10.3,A2,A15,I8)') 'Total time : ',timing_glob(4*ji ) & & , ' (SYPD: ', zsypd, ')', ' on MPI rank : ', ji END DO @@ -656,19 +656,19 @@ CONTAINS iall_rank(:) = (/ (idum,idum=0,jpnij-1) /) ! Compute elapse user time - zavg_etime = tot_etime/REAL(jpnij,dp) + zavg_etime = tot_etime/REAL(jpnij,wp) zmax_etime = MAXVAL(all_etime(:)) zmin_etime = MINVAL(all_etime(:)) ! Compute CPU user time - zavg_ctime = tot_ctime/REAL(jpnij,dp) + zavg_ctime = tot_ctime/REAL(jpnij,wp) zmax_ctime = MAXVAL(all_ctime(:)) zmin_ctime = MINVAL(all_ctime(:)) ! Compute cpu/elapsed ratio zall_ratio(:) = all_ctime(:) / all_etime(:) ztot_ratio = SUM(all_ctime(:))/SUM(all_etime(:)) - zavg_ratio = SUM(zall_ratio(:))/REAL(jpnij,dp) + zavg_ratio = SUM(zall_ratio(:))/REAL(jpnij,wp) zmax_ratio = MAXVAL(zall_ratio(:)) zmin_ratio = MINVAL(zall_ratio(:)) diff --git a/src/OCE/trc_oce.F90 b/src/OCE/trc_oce.F90 index 84798b3bc536c05dee2620fb496bb7f74fdeb532..ed57a5d2b432e4ea133693f047f897d6456b39fa 100644 --- a/src/OCE/trc_oce.F90 +++ b/src/OCE/trc_oce.F90 @@ -25,12 +25,12 @@ MODULE trc_oce LOGICAL , PUBLIC :: l_co2cpl = .false. !: atmospheric pco2 recieved from oasis LOGICAL , PUBLIC :: l_offline = .false. !: offline passive tracers flag - REAL(dp), PUBLIC :: r_si2 !: largest depth of extinction (blue & 0.01 mg.m-3) (RGB) + REAL(wp), PUBLIC :: r_si2 !: largest depth of extinction (blue & 0.01 mg.m-3) (RGB) LOGICAL , PUBLIC :: ln_trcdc2dm !: Diurnal cycle for TOP ! - REAL(dp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: etot3 !: light absortion coefficient - REAL(dp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: oce_co2 !: ocean carbon flux - REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_mean !: daily mean qsr + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: etot3 !: light absortion coefficient + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: oce_co2 !: ocean carbon flux + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_mean !: daily mean qsr #if defined key_top !!---------------------------------------------------------------------- @@ -75,12 +75,12 @@ CONTAINS !! !! Reference : Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(3,61), INTENT(out) :: prgb ! tabulated attenuation coefficient + REAL(wp), DIMENSION(3,61), INTENT(out) :: prgb ! tabulated attenuation coefficient ! INTEGER :: jc ! dummy loop indice INTEGER :: irgb ! temporary integer - REAL(dp) :: zchl ! temporary scalar - REAL(dp), DIMENSION(4,61) :: zrgb ! tabulated attenuation coefficient (formerly read in U9X3LY9HRH6L) + REAL(wp) :: zchl ! temporary scalar + REAL(wp), DIMENSION(4,61) :: zrgb ! tabulated attenuation coefficient (formerly read in 'kRGB61.txt') !!---------------------------------------------------------------------- ! IF(lwp) THEN @@ -180,11 +180,11 @@ CONTAINS !! ** input : xkrgb(61) precomputed array corresponding to the !! attenuation coefficient (from JM Andre) !!---------------------------------------------------------------------- - REAL(dp), DIMENSION(3,61), INTENT(out) :: prgb ! tabulated attenuation coefficient + REAL(wp), DIMENSION(3,61), INTENT(out) :: prgb ! tabulated attenuation coefficient ! INTEGER :: jc, jb ! dummy loop indice INTEGER :: irgb ! temporary integer - REAL(dp) :: zchl ! temporary scalar + REAL(wp) :: zchl ! temporary scalar INTEGER :: numlight !!---------------------------------------------------------------------- ! @@ -231,13 +231,13 @@ CONTAINS !! - pqsr_frc = Qsr * (1-rn_abs)/3 = 0.33e2 W/m2 (3 bands case & equi-partition) !! !!---------------------------------------------------------------------- - REAL(dp), INTENT(in) :: prldex ! longest depth of extinction + REAL(wp), INTENT(in) :: prldex ! longest depth of extinction REAL(wp), INTENT(in) :: pqsr_frc ! frac. solar radiation which penetrates ! INTEGER :: jk, pjl ! levels - REAL(dp) :: zhext ! deepest level till which light penetrates - REAL(dp) :: zprec = 15._wp ! precision to reach -LOG10(1.e-15) - REAL(dp) :: zem ! temporary scalar + REAL(wp) :: zhext ! deepest level till which light penetrates + REAL(wp) :: zprec = 15._wp ! precision to reach -LOG10(1.e-15) + REAL(wp) :: zem ! temporary scalar !!---------------------------------------------------------------------- ! ! It is not necessary to compute anything below the following depth